101 withLastIdNamespace f = do |
101 withLastIdNamespace f = do |
102 li <- gets lastIdentifier |
102 li <- gets lastIdentifier |
103 nss <- gets namespaces |
103 nss <- gets namespaces |
104 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
104 withState' (\st -> st{currentScope = fromMaybe [] $ Map.lookup li (namespaces st)}) f |
105 |
105 |
106 withRecordNamespace :: [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
106 withRecordNamespace :: String -> [(String, BaseType)] -> State RenderState Doc -> State RenderState Doc |
107 withRecordNamespace [] = error "withRecordNamespace: empty record" |
107 withRecordNamespace _ [] = error "withRecordNamespace: empty record" |
108 withRecordNamespace recs = withState' f |
108 withRecordNamespace prefix recs = withState' f |
109 where |
109 where |
110 f st = st{currentScope = records ++ currentScope st} |
110 f st = st{currentScope = records ++ currentScope st} |
111 records = map (\(a, b) -> (map toLower a, (a, b))) recs |
111 records = map (\(a, b) -> (map toLower a, (prefix ++ a, b))) recs |
112 |
112 |
113 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
113 toCFiles :: Map.Map String [Record] -> (String, PascalUnit) -> IO () |
114 toCFiles _ (_, System _) = return () |
114 toCFiles _ (_, System _) = return () |
115 toCFiles ns p@(fn, pu) = do |
115 toCFiles ns p@(fn, pu) = do |
116 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
116 hPutStrLn stderr $ "Rendering '" ++ fn ++ "'..." |
117 toCFiles' p |
117 toCFiles' p |
118 where |
118 where |
119 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
119 toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p |
120 toCFiles' (fn, (Unit unitId interface implementation _ _)) = do |
120 toCFiles' (fn, (Unit unitId interface implementation _ _)) = do |
121 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState |
121 let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState |
122 writeFile (fn ++ ".h") $ "#pragma once\n" ++ (render a) |
122 writeFile (fn ++ ".h") $ "#pragma once\n\n" ++ (render a) |
123 writeFile (fn ++ ".c") $ (render2C s . implementation2C) implementation |
123 writeFile (fn ++ ".c") $ "#include \"pas2c.h\"\n#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation |
124 initialState = emptyState ns |
124 initialState = emptyState ns |
125 |
125 |
126 render2C :: RenderState -> State RenderState Doc -> String |
126 render2C :: RenderState -> State RenderState Doc -> String |
127 render2C a = render . flip evalState a |
127 render2C a = render . flip evalState a |
128 |
128 |
340 initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
340 initExpr2C (InitChar a) = return $ quotes $ text "\\x" <> text (showHex (read a) "") |
341 initExpr2C (InitReference i) = id2C IOLookup i |
341 initExpr2C (InitReference i) = id2C IOLookup i |
342 initExpr2C (InitRecord fields) = do |
342 initExpr2C (InitRecord fields) = do |
343 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
343 (fs :: [Doc]) <- mapM (\(Identifier a _, b) -> liftM (text "." <> text a <+> equals <+>) $ initExpr2C b) fields |
344 return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace |
344 return $ lbrace $+$ (nest 4 . vcat $ fs) $+$ rbrace |
|
345 initExpr2C (InitArray [value]) = initExpr2C value |
345 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
346 initExpr2C (InitArray values) = liftM (braces . vcat . punctuate comma) $ mapM initExpr2C values |
346 initExpr2C (InitRange _) = return $ text "<<range expression>>" |
347 initExpr2C (InitRange _) = return $ text "<<range expression>>" |
347 initExpr2C (InitSet _) = return $ text "<<set>>" |
348 initExpr2C (InitSet _) = return $ text "<<set>>" |
348 initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>" |
349 initExpr2C (BuiltInFunction {}) = return $ text "<<built-in function>>" |
349 initExpr2C a = error $ "Don't know how to render " ++ show a |
350 initExpr2C a = error $ "Don't know how to render " ++ show a |
424 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
425 text "case" <+> parens (hsep . punctuate (char ',') $ ie) <> char ':' <> nest 4 (ph $+$ text "break;") |
425 phrase2C wb@(WithBlock ref p) = do |
426 phrase2C wb@(WithBlock ref p) = do |
426 r <- ref2C ref |
427 r <- ref2C ref |
427 t <- gets lastType |
428 t <- gets lastType |
428 case t of |
429 case t of |
429 (BTRecord rs) -> do |
430 (BTRecord rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p |
430 ph <- withRecordNamespace rs $ phrase2C $ wrapPhrase p |
|
431 return $ text "namespace" <> parens r $$ ph |
|
432 a -> do |
431 a -> do |
433 ns <- gets currentScope |
432 ns <- gets currentScope |
434 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb ++ "\nnamespace: " ++ show (take 100 ns) |
433 error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb ++ "\nnamespace: " ++ show (take 100 ns) |
435 phrase2C (ForCycle i' e1' e2' p) = do |
434 phrase2C (ForCycle i' e1' e2' p) = do |
436 i <- id2C IOLookup i' |
435 i <- id2C IOLookup i' |
499 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
498 ref2C rf@(RecordField (Dereference ref1) ref2) = do |
500 r1 <- ref2C ref1 |
499 r1 <- ref2C ref1 |
501 t <- fromPointer (show ref1) =<< gets lastType |
500 t <- fromPointer (show ref1) =<< gets lastType |
502 ns <- gets currentScope |
501 ns <- gets currentScope |
503 r2 <- case t of |
502 r2 <- case t of |
504 BTRecord rs -> withRecordNamespace rs $ ref2C ref2 |
503 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
505 BTUnit -> withLastIdNamespace $ ref2C ref2 |
504 BTUnit -> withLastIdNamespace $ ref2C ref2 |
506 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
505 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
507 return $ |
506 return $ |
508 r1 <> text "->" <> r2 |
507 r1 <> text "->" <> r2 |
509 ref2C rf@(RecordField ref1 ref2) = do |
508 ref2C rf@(RecordField ref1 ref2) = do |
510 r1 <- ref2C ref1 |
509 r1 <- ref2C ref1 |
511 t <- gets lastType |
510 t <- gets lastType |
512 ns <- gets currentScope |
511 ns <- gets currentScope |
513 r2 <- case t of |
512 r2 <- case t of |
514 BTRecord rs -> withRecordNamespace rs $ ref2C ref2 |
513 BTRecord rs -> withRecordNamespace "" rs $ ref2C ref2 |
515 BTUnit -> withLastIdNamespace $ ref2C ref2 |
514 BTUnit -> withLastIdNamespace $ ref2C ref2 |
516 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
515 a -> error $ "dereferencing from " ++ show a ++ "\n" ++ show rf ++ "\n" ++ show (take 100 ns) |
517 return $ |
516 return $ |
518 r1 <> text "." <> r2 |
517 r1 <> text "." <> r2 |
519 ref2C d@(Dereference ref) = do |
518 ref2C d@(Dereference ref) = do |
520 r <- ref2C ref |
519 r <- ref2C ref |
521 t <- fromPointer (show d) =<< gets lastType |
520 t <- fromPointer (show d) =<< gets lastType |
522 modify (\st -> st{lastType = t}) |
521 modify (\st -> st{lastType = t}) |
523 return $ (parens $ text "*") <> r |
522 return $ (parens $ text "*" <> r) |
524 ref2C (FunCall params ref) = do |
523 ref2C (FunCall params ref) = do |
525 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
524 ps <- liftM (parens . hsep . punctuate (char ',')) $ mapM expr2C params |
526 r <- ref2C ref |
525 r <- ref2C ref |
527 t <- gets lastType |
526 t <- gets lastType |
528 case t of |
527 case t of |