450 extractTypes = concatMap f |
450 extractTypes = concatMap f |
451 where |
451 where |
452 f (VarDeclaration _ (ids, t) _) = replicate (length ids) t |
452 f (VarDeclaration _ (ids, t) _) = replicate (length ids) t |
453 f a = error $ "extractTypes: can't extract from " ++ show a |
453 f a = error $ "extractTypes: can't extract from " ++ show a |
454 |
454 |
455 initExpr2C :: InitExpression -> State RenderState Doc |
455 initExpr2C, initExpr2C' :: InitExpression -> State RenderState Doc |
456 initExpr2C InitNull = return $ text "NULL" |
456 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
457 initExpr2C (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C expr) |
457 initExpr2C a = initExpr2C' a |
458 initExpr2C (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C expr) |
458 initExpr2C' InitNull = return $ text "NULL" |
459 initExpr2C (InitBinOp op expr1 expr2) = do |
459 initExpr2C' (InitAddress expr) = liftM ((<>) (text "&")) (initExpr2C' expr) |
460 e1 <- initExpr2C expr1 |
460 initExpr2C' (InitPrefixOp op expr) = liftM (text (op2C op) <>) (initExpr2C' expr) |
461 e2 <- initExpr2C expr2 |
461 initExpr2C' (InitBinOp op expr1 expr2) = do |
|
462 e1 <- initExpr2C' expr1 |
|
463 e2 <- initExpr2C' expr2 |
462 return $ parens $ e1 <+> text (op2C op) <+> e2 |
464 return $ parens $ e1 <+> text (op2C op) <+> e2 |
463 initExpr2C (InitNumber s) = return $ text s |
465 initExpr2C' (InitNumber s) = return $ text s |
464 initExpr2C (InitFloat s) = return $ text s |
466 initExpr2C' (InitFloat s) = return $ text s |
465 initExpr2C (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
467 initExpr2C' (InitHexNumber s) = return $ text "0x" <> (text . map toLower $ s) |
466 initExpr2C (InitString [a]) = return . quotes $ text [a] |
468 initExpr2C' (InitString [a]) = return . quotes $ text [a] |
467 initExpr2C (InitString s) = return $ strInit s |
469 initExpr2C' (InitString s) = return $ strInit s |
468 initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
470 initExpr2C' (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
469 initExpr2C (InitReference i) = id2C IOLookup i |
471 initExpr2C' (InitReference i) = id2C IOLookup i |
470 initExpr2C (InitRecord fields) = do |
472 initExpr2C' (InitRecord fields) = do |
471 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
473 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
472 return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace |
474 return $ lbrace $+$ (nest 4 . vcat . punctuate comma $ fs) $+$ rbrace |
473 --initExpr2C (InitArray [value]) = initExpr2C value |
475 initExpr2C' (InitArray [value]) = initExpr2C value |
474 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
476 initExpr2C' r@(InitRange (Range i@(Identifier i' _))) = do |
475 initExpr2C r@(InitRange (Range i@(Identifier i' _))) = do |
|
476 id2C IOLookup i |
477 id2C IOLookup i |
477 t <- gets lastType |
478 t <- gets lastType |
478 case t of |
479 case t of |
479 BTEnum s -> return . int $ length s |
480 BTEnum s -> return . int $ length s |
480 BTInt -> case i' of |
481 BTInt -> case i' of |
481 "byte" -> return $ int 256 |
482 "byte" -> return $ int 256 |
482 _ -> error $ "InitRange identifier: " ++ i' |
483 _ -> error $ "InitRange identifier: " ++ i' |
483 _ -> error $ "InitRange: " ++ show r |
484 _ -> error $ "InitRange: " ++ show r |
484 initExpr2C (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
485 initExpr2C' (InitRange (RangeFromTo (InitNumber "0") r)) = initExpr2C $ BuiltInFunction "succ" [r] |
485 initExpr2C (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
486 initExpr2C' (InitRange (RangeFromTo (InitChar "0") (InitChar r))) = initExpr2C $ BuiltInFunction "succ" [InitNumber r] |
486 initExpr2C (InitRange a) = error $ show a --return $ text "<<range>>" |
487 initExpr2C' (InitRange a) = error $ show a --return $ text "<<range>>" |
487 initExpr2C (InitSet []) = return $ text "0" |
488 initExpr2C' (InitSet []) = return $ text "0" |
488 initExpr2C (InitSet a) = return $ text "<<set>>" |
489 initExpr2C' (InitSet a) = return $ text "<<set>>" |
489 initExpr2C (BuiltInFunction "low" [InitReference e]) = return $ |
490 initExpr2C' (BuiltInFunction "low" [InitReference e]) = return $ |
490 case e of |
491 case e of |
491 (Identifier "LongInt" _) -> int (-2^31) |
492 (Identifier "LongInt" _) -> int (-2^31) |
492 (Identifier "SmallInt" _) -> int (-2^15) |
493 (Identifier "SmallInt" _) -> int (-2^15) |
493 _ -> error $ "BuiltInFunction 'low': " ++ show e |
494 _ -> error $ "BuiltInFunction 'low': " ++ show e |
494 initExpr2C (BuiltInFunction "high" [e]) = do |
495 initExpr2C' (BuiltInFunction "high" [e]) = do |
495 initExpr2C e |
496 initExpr2C e |
496 t <- gets lastType |
497 t <- gets lastType |
497 case t of |
498 case t of |
498 (BTArray i _ _) -> initExpr2C $ BuiltInFunction "pred" [InitRange i] |
499 (BTArray i _ _) -> initExpr2C' $ BuiltInFunction "pred" [InitRange i] |
499 a -> error $ "BuiltInFunction 'high': " ++ show a |
500 a -> error $ "BuiltInFunction 'high': " ++ show a |
500 initExpr2C (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C e |
501 initExpr2C' (BuiltInFunction "succ" [BuiltInFunction "pred" [e]]) = initExpr2C' e |
501 initExpr2C (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C e |
502 initExpr2C' (BuiltInFunction "pred" [BuiltInFunction "succ" [e]]) = initExpr2C' e |
502 initExpr2C (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C e |
503 initExpr2C' (BuiltInFunction "succ" [e]) = liftM (<> text " + 1") $ initExpr2C' e |
503 initExpr2C (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C e |
504 initExpr2C' (BuiltInFunction "pred" [e]) = liftM (<> text " - 1") $ initExpr2C' e |
504 initExpr2C b@(BuiltInFunction _ _) = error $ show b |
505 initExpr2C' b@(BuiltInFunction _ _) = error $ show b |
505 initExpr2C a = error $ "initExpr2C: don't know how to render " ++ show a |
506 initExpr2C' a = error $ "initExpr2C: don't know how to render " ++ show a |
506 |
507 |
507 |
508 |
508 range2C :: InitExpression -> State RenderState [Doc] |
509 range2C :: InitExpression -> State RenderState [Doc] |
509 range2C (InitString [a]) = return [quotes $ text [a]] |
510 range2C (InitString [a]) = return [quotes $ text [a]] |
510 range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i |
511 range2C (InitRange (Range i)) = liftM (flip (:) []) $ id2C IOLookup i |