sheepy-clone: comparison tools/pas2c/Pas2C.hs

equal deleted inserted replaced

-:7e05a397602f
+:b7f632c12784
 f "pointer" = BTPointerTo BTVoid
 f "boolean" = BTBool
 f "float" = BTFloat
 f "char" = BTChar
 f "string" = BTString
+f "ansistring" = BTAString
 f _ = error $ "Unknown system type: " ++ show st
 resolveType (PointerTo (SimpleType (Identifier i _))) = return . BTPointerTo $ BTUnresolved (map toLower i)
 resolveType (PointerTo t) = liftM BTPointerTo $ resolveType t
 resolveType (RecordType tv mtvs) = do
 tvs <- mapM f (concat $ tv : fromMaybe [] mtvs)
 resolveType (DeriveType (InitPrefixOp _ e)) = initExpr2C e >> gets lastType
 resolveType (DeriveType (BuiltInFunction{})) = return (BTInt True)
 resolveType (DeriveType (InitReference (Identifier{}))) = return BTBool -- TODO: derive from actual type
 resolveType (DeriveType _) = return BTUnknown
 resolveType String = return BTString
+resolveType AString = return BTAString
 resolveType VoidType = return BTVoid
 resolveType (Sequence ids) = return $ BTEnum $ map (\(Identifier i _) -> map toLower i) ids
 resolveType (RangeType _) = return $ BTVoid
 resolveType (Set t) = liftM BTSet $ resolveType t
 resolveType (VarParamType t) = liftM BTVarParam $ resolveType t
 baseType2C :: String -> BaseType -> Doc
 baseType2C _ BTFloat = text "float"
 baseType2C _ BTBool = text "bool"
 baseType2C _ BTString = text "string255"
+baseType2C _ BTAString = text "astring"
 baseType2C s a = error $ "baseType2C: " ++ show a ++ "\n" ++ s
 type2C :: TypeDecl -> State RenderState (Doc -> Doc)
 type2C (SimpleType i) = liftM (\i' a -> i' <+> a) $ id2C IOLookup i
 type2C t = do
 modify (\st -> st{lastType = rt})
 return r
 where
 type2C' VoidType = return (text "void" <+>)
 type2C' String = return (text "string255" <+>)--return (text ("string" ++ show l) <+>)
+type2C' AString = return (text "astring" <+>)
 type2C' (PointerTo (SimpleType i)) = do
 i' <- id2C IODeferred i
 lt <- gets lastType
 case lt of
 BTRecord _ _ -> return $ \a -> text "struct __" <> i' <+> text "*" <+> a
 case lt of
 -- assume pointer to char for simplicity
 BTPointerTo _ -> do
 e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2str" BTUnknown))
 return $ r <+> text "=" <+> e <> semi
+BTAString -> do
+e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "astr2str" BTUnknown))
+return $ r <+> text "=" <+> e <> semi
 BTString -> do
 e <- expr2C expr
 return $ r <+> text "=" <+> e <> semi
-_ -> error $ "Assignment to string from " ++ show asgn
+_ -> error $ "Assignment to string from " ++ show lt ++ "\n" ++ show asgn
+(BTAString, _) -> do
+void $ expr2C expr
+lt <- gets lastType
+case lt of
+-- assume pointer to char for simplicity
+BTPointerTo _ -> do
+e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "pchar2astr" BTUnknown))
+return $ r <+> text "=" <+> e <> semi
+BTString -> do
+e <- expr2C $ Reference $ FunCall [Reference $ RefExpression expr] (SimpleReference (Identifier "str2astr" BTUnknown))
+return $ r <+> text "=" <+> e <> semi
+BTAString -> do
+e <- expr2C expr
+return $ r <+> text "=" <+> e <> semi
+_ -> error $ "Assignment to ansistring from " ++ show lt ++ "\n" ++ show asgn
 (BTArray _ _ _, _) -> do
 case expr of
 Reference er -> do
 void $ ref2C er
 exprT <- gets lastType
 wrapPhrase p@(Phrases _) = p
 wrapPhrase p = Phrases [p]
 expr2C :: Expression -> State RenderState Doc
 expr2C (Expression s) = return $ text s
-expr2C (BinOp op expr1 expr2) = do
+expr2C bop@(BinOp op expr1 expr2) = do
 e1 <- expr2C expr1
 t1 <- gets lastType
 e2 <- expr2C expr2
 t2 <- gets lastType
 case (op2C op, t1, t2) of
+("+", BTAString, BTAString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcatA" (BTFunction False [(False, t1), (False, t2)] BTString))
+("+", BTAString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappendA" (BTFunction False [(False, t1), (False, t2)] BTAString))
+(_, BTAString, _) -> error $ "unhandled bin op with ansistring on the left side: " ++ show bop
+(_, _, BTAString) -> error $ "unhandled bin op with ansistring on the right side: " ++ show bop
 ("+", BTString, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strconcat" (BTFunction False [(False, t1), (False, t2)] BTString))
 ("+", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strappend" (BTFunction False [(False, t1), (False, t2)] BTString))
 ("+", BTChar, BTString) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strprepend" (BTFunction False [(False, t1), (False, t2)] BTString))
 ("+", BTChar, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_chrconcat" (BTFunction False [(False, t1), (False, t2)] BTString))
 ("==", BTString, BTChar) -> expr2C $ BuiltInFunCall [expr1, expr2] (SimpleReference $ Identifier "_strcomparec" (BTFunction False [(False, t1), (False, t2)] BTBool))
 e' <- expr2C e
 lt <- gets lastType
 modify (\s -> s{lastType = BTInt True})
 case lt of
 BTString -> return $ text "fpcrtl_Length" <> parens e'
+BTAString -> return $ text "fpcrtl_LengthA" <> parens e'
 BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
 BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
 _ -> error $ "length() called on " ++ show lt
+expr2C (BuiltInFunCall [e, e1, e2] (SimpleReference (Identifier "copy" _))) = do
+e1' <- expr2C e1
+e2' <- expr2C e2
+e' <- expr2C e
+lt <- gets lastType
+let f name = return $ text name <> parens (hsep $ punctuate (char ',') [e', e1', e2'])
+case lt of
+BTString -> f "fpcrtl_copy"
+BTAString -> f "fpcrtl_copyA"
+_ -> error $ "copy() called on " ++ show lt
 expr2C (BuiltInFunCall params ref) = do
 r <- ref2C ref
 t <- gets lastType
 ps <- mapM expr2C params
 case t of
 t <- gets lastType
 case t of
 (BTArray _ _ t') -> modify (\st -> st{lastType = t'})
 --         (BTFunctionReturn _ (BTArray _ _ t')) -> modify (\st -> st{lastType = t'})
 --         (BTFunctionReturn _ (BTString)) -> modify (\st -> st{lastType = BTChar})
-(BTString) -> modify (\st -> st{lastType = BTChar})
+BTString -> modify (\st -> st{lastType = BTChar})
+BTAString -> modify (\st -> st{lastType = BTChar})
 (BTPointerTo t) -> do
 t'' <- fromPointer (show t) =<< gets lastType
 case t'' of
 BTChar -> modify (\st -> st{lastType = BTChar})
 a -> error $ "Getting element of " ++ show a ++ "\nReference: " ++ show ae
 _ -> return $ text "&" <> parens r
 ref2C (TypeCast t'@(Identifier i _) expr) = do
 lt <- expr2C expr >> gets lastType
 case (map toLower i, lt) of
 ("pchar", BTString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pchar" $ BTPointerTo BTChar))
+("pchar", BTAString) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "_pcharA" $ BTPointerTo BTChar))
 ("shortstring", BTPointerTo _) -> ref2C $ FunCall [expr] (SimpleReference (Identifier "pchar2str" $ BTString))
 (a, _) -> do
 e <- expr2C expr
 t <- id2C IOLookup t'
 return . parens $ parens t <> e

changeset 10120	b7f632c12784
parent 10113	b26c2772e754
child 10121	8b65699beb56