module Compiler.Scheme.Common import Compiler.Commonimport Compiler.CompileExprimport Compiler.Inline import Core.Contextimport Core.Nameimport Core.TT import Data.Listimport Data.Vect import System.Info %default covering exportfirstExists : List String -> IO (Maybe String)firstExists [] = pure NothingfirstExists (x :: xs) = if !(exists x) then pure (Just x) else firstExists xs schString : String -> StringschString s = concatMap okchar (unpack s)  where    okchar : Char -> String    okchar c = if isAlphaNum c || c =='_'                  then cast c                  else "C-" ++ show (cast {to=Int} c) exportschName : Name -> StringschName (NS ns n) = showSep "-" ns ++ "-" ++ schName nschName (UN n) = schString nschName (MN n i) = schString n ++ "-" ++ show ischName (PV n d) = "pat--" ++ schName nschName (DN _ n) = schName nschName (RF n) = "rf--" ++ schString nschName (Nested (i, x) n) = "n--" ++ show i ++ "-" ++ show x ++ "-" ++ schName nschName (CaseBlock x y) = "case--" ++ show x ++ "-" ++ show yschName (WithBlock x y) = "with--" ++ show x ++ "-" ++ show yschName (Resolved i) = "fn--" ++ show i -- local variable names as scheme names - we need to invent new names for the locals-- because there might be shadows in the original expression which can't be resolved-- by the same scoping rules. (e.g. something that computes \x, x => x + x where the-- names are the same but refer to different bindings in the scope)public exportdata SVars : List Name -> Type where     Nil : SVars []     (::) : (svar : String) -> SVars ns -> SVars (n :: ns) extendSVars : (xs : List Name) -> SVars ns -> SVars (xs ++ ns)extendSVars {ns} xs vs = extSVars' (cast (length ns)) xs vs  where    extSVars' : Int -> (xs : List Name) -> SVars ns -> SVars (xs ++ ns)    extSVars' i [] vs = vs    extSVars' i (x :: xs) vs = schName (MN "v" i) :: extSVars' (i + 1) xs vs exportinitSVars : (xs : List Name) -> SVars xsinitSVars xs = rewrite sym (appendNilRightNeutral xs) in extendSVars xs [] lookupSVar : {idx : Nat} -> .(IsVar n idx xs) -> SVars xs -> StringlookupSVar First (n :: ns) = nlookupSVar (Later p) (n :: ns) = lookupSVar p ns exportschConstructor : (String -> String) -> Name -> Maybe Int -> List String -> StringschConstructor _ _ (Just t) args    = "(vector " ++ show t ++ " " ++ showSep " " args ++ ")"schConstructor schString n Nothing args    = "(vector " ++ schString (show n) ++ " " ++ showSep " " args ++ ")" ||| Generate scheme for a plain function.op : String -> List String -> Stringop o args = "(" ++ o ++ " " ++ showSep " " args ++ ")" ||| Generate scheme for a boolean operation.boolop : String -> List String -> Stringboolop o args = "(or (and " ++ op o args ++ " 1) 0)" ||| Generate scheme for a primitive function.schOp : PrimFn arity -> Vect arity String -> StringschOp (Add IntType) [x, y] = op "b+" [x, y, "63"]schOp (Sub IntType) [x, y] = op "b-" [x, y, "63"]schOp (Mul IntType) [x, y] = op "b*" [x, y, "63"]schOp (Div IntType) [x, y] = op "b/" [x, y, "63"]schOp (Add ty) [x, y] = op "+" [x, y]schOp (Sub ty) [x, y] = op "-" [x, y]schOp (Mul ty) [x, y] = op "*" [x, y]schOp (Div IntegerType) [x, y] = op "quotient" [x, y]schOp (Div ty) [x, y] = op "/" [x, y]schOp (Mod ty) [x, y] = op "remainder" [x, y]schOp (Neg ty) [x] = op "-" [x]schOp (ShiftL ty) [x, y] = op "blodwen-shl" [x, y]schOp (ShiftR ty) [x, y] = op "blodwen-shr" [x, y]schOp (BAnd ty) [x, y] = op "blodwen-and" [x, y]schOp (BOr ty) [x, y] = op "blodwen-or" [x, y]schOp (BXOr ty) [x, y] = op "blodwen-xor" [x, y]schOp (LT CharType) [x, y] = boolop "char<?" [x, y]schOp (LTE CharType) [x, y] = boolop "char<=?" [x, y]schOp (EQ CharType) [x, y] = boolop "char=?" [x, y]schOp (GTE CharType) [x, y] = boolop "char>=?" [x, y]schOp (GT CharType) [x, y] = boolop "char>?" [x, y]schOp (LT StringType) [x, y] = boolop "string<?" [x, y]schOp (LTE StringType) [x, y] = boolop "string<=?" [x, y]schOp (EQ StringType) [x, y] = boolop "string=?" [x, y]schOp (GTE StringType) [x, y] = boolop "string>=?" [x, y]schOp (GT StringType) [x, y] = boolop "string>?" [x, y]schOp (LT ty) [x, y] = boolop "<" [x, y]schOp (LTE ty) [x, y] = boolop "<=" [x, y]schOp (EQ ty) [x, y] = boolop "=" [x, y]schOp (GTE ty) [x, y] = boolop ">=" [x, y]schOp (GT ty) [x, y] = boolop ">" [x, y]schOp StrLength [x] = op "string-length" [x]schOp StrHead [x] = op "string-ref" [x, "0"]schOp StrTail [x] = op "substring" [x, "1", op "string-length" [x]]schOp StrIndex [x, i] = op "string-ref" [x, i]schOp StrCons [x, y] = op "string-cons" [x, y]schOp StrAppend [x, y] = op "string-append" [x, y]schOp StrReverse [x] = op "string-reverse" [x]schOp StrSubstr [x, y, z] = op "string-substr" [x, y, z] -- `e` is Euler's number, which approximates to: 2.718281828459045schOp DoubleExp [x] = op "exp" [x] -- Base is `e`. Same as: `pow(e, x)`schOp DoubleLog [x] = op "log" [x] -- Base is `e`.schOp DoubleSin [x] = op "sin" [x]schOp DoubleCos [x] = op "cos" [x]schOp DoubleTan [x] = op "tan" [x]schOp DoubleASin [x] = op "asin" [x]schOp DoubleACos [x] = op "acos" [x]schOp DoubleATan [x] = op "atan" [x]schOp DoubleSqrt [x] = op "sqrt" [x]schOp DoubleFloor [x] = op "floor" [x]schOp DoubleCeiling [x] = op "ceiling" [x] schOp (Cast IntType StringType) [x] = op "number->string" [x]schOp (Cast IntegerType StringType) [x] = op "number->string" [x]schOp (Cast DoubleType StringType) [x] = op "number->string" [x]schOp (Cast CharType StringType) [x] = op "string" [x] schOp (Cast IntType IntegerType) [x] = xschOp (Cast DoubleType IntegerType) [x] = op "exact-floor" [x]schOp (Cast CharType IntegerType) [x] = op "char->integer" [x]schOp (Cast StringType IntegerType) [x] = op "cast-string-int" [x] schOp (Cast IntegerType IntType) [x] = xschOp (Cast DoubleType IntType) [x] = op "exact-floor" [x]schOp (Cast StringType IntType) [x] = op "cast-string-int" [x]schOp (Cast CharType IntType) [x] = op "char->integer" [x] schOp (Cast IntegerType DoubleType) [x] = op "exact->inexact" [x]schOp (Cast IntType DoubleType) [x] = op "exact->inexact" [x]schOp (Cast StringType DoubleType) [x] = op "cast-string-double" [x] schOp (Cast IntType CharType) [x] = op "integer->char" [x] schOp (Cast from to) [x] = "(blodwen-error-quit \"Invalid cast " ++ show from ++ "->" ++ show to ++ "\")" schOp BelieveMe [_,_,x] = xschOp Crash [_,msg] = "(blodwen-error-quit (string-append \"ERROR: \" " ++ msg ++ "))" ||| Extended primitives for the scheme backend, outside the standard set of primFnpublic exportdata ExtPrim = CCall | SchemeCall             | NewIORef | ReadIORef | WriteIORef             | NewArray | ArrayGet | ArraySet             | GetField | SetField             | VoidElim             | SysOS | SysCodegen             | Unknown Name exportShow ExtPrim where  show CCall = "CCall"  show SchemeCall = "SchemeCall"  show NewIORef = "NewIORef"  show ReadIORef = "ReadIORef"  show WriteIORef = "WriteIORef"  show NewArray = "NewArray"  show ArrayGet = "ArrayGet"  show ArraySet = "ArraySet"  show GetField = "GetField"  show SetField = "SetField"  show VoidElim = "VoidElim"  show SysOS = "SysOS"  show SysCodegen = "SysCodegen"  show (Unknown n) = "Unknown " ++ show n ||| Match on a user given name to get the scheme primitivetoPrim : Name -> ExtPrimtoPrim pn@(NS _ n)    = cond [(n == UN "prim__schemeCall", SchemeCall),            (n == UN "prim__cCall", CCall),            (n == UN "prim__newIORef", NewIORef),            (n == UN "prim__readIORef", ReadIORef),            (n == UN "prim__writeIORef", WriteIORef),            (n == UN "prim__newArray", NewArray),            (n == UN "prim__arrayGet", ArrayGet),            (n == UN "prim__arraySet", ArraySet),            (n == UN "prim__getField", GetField),            (n == UN "prim__setField", SetField),            (n == UN "void", VoidElim),            (n == UN "prim__os", SysOS),            (n == UN "prim__codegen", SysCodegen)            ]           (Unknown pn)toPrim pn = Unknown pn exportmkWorld : String -> StringmkWorld res = res -- MkIORes is a newtype now! schConstructor 0 [res, "#f"] -- MkIORes schConstant : (String -> String) -> Constant -> StringschConstant _ (I x) = show xschConstant _ (BI x) = show xschConstant schString (Str x) = schString xschConstant _ (Ch x)   = if (the Int (cast x) >= 32 && the Int (cast x) < 127)        then "#\\" ++ cast x        else "(integer->char " ++ show (the Int (cast x)) ++ ")"schConstant _ (Db x) = show xschConstant _ WorldVal = "#f"schConstant _ IntType = "#t"schConstant _ IntegerType = "#t"schConstant _ StringType = "#t"schConstant _ CharType = "#t"schConstant _ DoubleType = "#t"schConstant _ WorldType = "#t" schCaseDef : Maybe String -> StringschCaseDef Nothing = ""schCaseDef (Just tm) = "(else " ++ tm ++ ")" exportschArglist : List Name -> StringschArglist [] = ""schArglist [x] = schName xschArglist (x :: xs) = schName x ++ " " ++ schArglist xs mutual  used : Name -> NamedCExp -> Bool  used n (NmLocal fc n') = n == n'  used n (NmRef _ _) = False  used n (NmLam _ _ sc) = used n sc  used n (NmLet _ _ v sc) = used n v || used n sc  used n (NmApp _ f args) = used n f || or (map Delay (map (used n) args))  used n (NmCon _ _ _ args) = or (map Delay (map (used n) args))  used n (NmOp _ _ args) = or (map Delay (toList (map (used n) args)))  used n (NmExtPrim _ _ args) = or (map Delay (map (used n) args))  used n (NmForce _ t) = used n t  used n (NmDelay _ t) = used n t  used n (NmConCase _ sc alts def)      = used n sc || or (map Delay (map (usedCon n) alts))            || maybe False (used n) def  used n (NmConstCase _ sc alts def)      = used n sc || or (map Delay (map (usedConst n) alts))            || maybe False (used n) def  used n _ = False   usedCon : Name -> NamedConAlt -> Bool  usedCon n (MkNConAlt _ _ _ sc) = used n sc   usedConst : Name -> NamedConstAlt -> Bool  usedConst n (MkNConstAlt _ sc) = used n sc parameters (schExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String,            schString : String -> String)  showTag : Name -> Maybe Int -> String  showTag n (Just i) = show i  showTag n Nothing = schString (show n)   mutual    schConAlt : Int -> String -> NamedConAlt -> Core String    schConAlt i target (MkNConAlt n tag args sc)        = pure $ "((" ++ showTag n tag ++ ") "                      ++ bindArgs 1 args !(schExp i sc) ++ ")"      where        bindArgs : Int -> (ns : List Name) -> String -> String        bindArgs i [] body = body        bindArgs i (n :: ns) body            = if used n sc                 then "(let ((" ++ schName n ++ " " ++ "(vector-ref " ++ target ++ " " ++ show i ++ "))) "                    ++ bindArgs (i + 1) ns body ++ ")"                 else bindArgs (i + 1) ns body     schConUncheckedAlt : Int -> String -> NamedConAlt -> Core String    schConUncheckedAlt i target (MkNConAlt n tag args sc)        = pure $ bindArgs 1 args !(schExp i sc)      where        bindArgs : Int -> (ns : List Name) -> String -> String        bindArgs i [] body = body        bindArgs i (n :: ns) body            = if used n sc                 then "(let ((" ++ schName n ++ " " ++ "(vector-ref " ++ target ++ " " ++ show i ++ "))) "                    ++ bindArgs (i + 1) ns body ++ ")"                 else bindArgs (i + 1) ns body     schConstAlt : Int -> String -> NamedConstAlt -> Core String    schConstAlt i target (MkNConstAlt c exp)        = pure $ "((equal? " ++ target ++ " " ++ schConstant schString c ++ ") " ++ !(schExp i exp) ++ ")"     -- oops, no traverse for Vect in Core    schArgs : Int -> Vect n NamedCExp -> Core (Vect n String)    schArgs i [] = pure []    schArgs i (arg :: args) = pure $ !(schExp i arg) :: !(schArgs i args)     export    schExp : Int -> NamedCExp -> Core String    schExp i (NmLocal fc n) = pure $ schName n    schExp i (NmRef fc n) = pure $ schName n    schExp i (NmLam fc x sc)       = do sc' <- schExp i  sc            pure $ "(lambda (" ++ schName x ++ ") " ++ sc' ++ ")"    schExp i (NmLet fc x val sc)       = do val' <- schExp i val            sc' <- schExp i sc            pure $ "(let ((" ++ schName x ++ " " ++ val' ++ ")) " ++ sc' ++ ")"    schExp i (NmApp fc x [])        = pure $ "(" ++ !(schExp i x) ++ ")"    schExp i (NmApp fc x args)        = pure $ "(" ++ !(schExp i x) ++ " " ++ showSep " " !(traverse (schExp i) args) ++ ")"    schExp i (NmCon fc x tag args)        = pure $ schConstructor schString x tag !(traverse (schExp i) args)    schExp i (NmOp fc op args)        = pure $ schOp op !(schArgs i args)    schExp i (NmExtPrim fc p args)        = schExtPrim i (toPrim p) args    schExp i (NmForce fc t) = pure $ "(" ++ !(schExp i t) ++ ")"    schExp i (NmDelay fc t) = pure $ "(lambda () " ++ !(schExp i t) ++ ")"    schExp i (NmConCase fc sc [] def)        = do tcode <- schExp (i+1) sc             defc <- maybe (pure "'erased") (schExp i) def             let n = "sc" ++ show i             pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) "                     ++ defc ++ ")"    schExp i (NmConCase fc sc [alt] Nothing)        = do tcode <- schExp (i+1) sc             let n = "sc" ++ show i             pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) " ++                    !(schConUncheckedAlt (i+1) n alt) ++ ")"    schExp i (NmConCase fc sc alts Nothing)        = do tcode <- schExp (i+1) sc             let n = "sc" ++ show i             pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (case (vector-ref " ++ n ++ " 0) "                     ++ !(showAlts n alts) ++                     "))"      where        showAlts : String -> List NamedConAlt -> Core String        showAlts n [] = pure ""        showAlts n [alt]           = pure $ "(else " ++ !(schConUncheckedAlt (i + 1) n alt) ++ ")"        showAlts n (alt :: alts)           = pure $ !(schConAlt (i + 1) n alt) ++ " " ++                    !(showAlts n alts)    schExp i (NmConCase fc sc alts def)        = do tcode <- schExp (i+1) sc             defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i v))) def             let n = "sc" ++ show i             pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (case (vector-ref " ++ n ++ " 0) "                     ++ showSep " " !(traverse (schConAlt (i+1) n) alts)                     ++ schCaseDef defc ++ "))"    schExp i (NmConstCase fc sc alts Nothing)        = do tcode <- schExp (i+1) sc             let n = "sc" ++ show i             pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (cond "                      ++ !(showConstAlts n alts)                      ++ "))"      where        showConstAlts : String -> List NamedConstAlt -> Core String        showConstAlts n [] = pure ""        showConstAlts n [MkNConstAlt c exp]           = pure $ "(else " ++ !(schExp (i + 1) exp) ++ ")"        showConstAlts n (alt :: alts)           = pure $ !(schConstAlt (i + 1) n alt) ++ " " ++                    !(showConstAlts n alts)    schExp i (NmConstCase fc sc alts def)        = do defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i v))) def             tcode <- schExp (i+1) sc             let n = "sc" ++ show i             pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (cond "                      ++ showSep " " !(traverse (schConstAlt (i+1) n) alts)                      ++ schCaseDef defc ++ "))"    schExp i (NmPrimVal fc c) = pure $ schConstant schString c    schExp i (NmErased fc) = pure "'erased"    schExp i (NmCrash fc msg) = pure $ "(blodwen-error-quit " ++ show msg ++ ")"   -- Need to convert the argument (a list of scheme arguments that may  -- have been constructed at run time) to a scheme list to be passed to apply  readArgs : Int -> NamedCExp -> Core String  readArgs i tm = pure $ "(blodwen-read-args " ++ !(schExp i tm) ++ ")"   fileOp : String -> String  fileOp op = "(blodwen-file-op (lambda () " ++ op ++ "))"   -- External primitives which are common to the scheme codegens (they can be  -- overridden)  export  schExtCommon : Int -> ExtPrim -> List NamedCExp -> Core String  schExtCommon i SchemeCall [ret, NmPrimVal fc (Str fn), args, world]     = pure $ mkWorld ("(apply " ++ fn ++" "                  ++ !(readArgs i args) ++ ")")  schExtCommon i SchemeCall [ret, fn, args, world]       = pure $ mkWorld ("(apply (eval (string->symbol " ++ !(schExp i fn) ++")) "                    ++ !(readArgs i args) ++ ")")  schExtCommon i NewIORef [_, val, world]      = pure $ mkWorld $ "(box " ++ !(schExp i val) ++ ")"  schExtCommon i ReadIORef [_, ref, world]      = pure $ mkWorld $ "(unbox " ++ !(schExp i ref) ++ ")"  schExtCommon i WriteIORef [_, ref, val, world]      = pure $ mkWorld $ "(set-box! "                           ++ !(schExp i ref) ++ " "                           ++ !(schExp i val) ++ ")"  schExtCommon i NewArray [_, size, val, world]      = pure $ mkWorld $ "(make-vector " ++ !(schExp i size) ++ " "                                         ++ !(schExp i val) ++ ")"  schExtCommon i ArrayGet [_, arr, pos, world]      = pure $ mkWorld $ "(vector-ref " ++ !(schExp i arr) ++ " "                                        ++ !(schExp i pos) ++ ")"  schExtCommon i ArraySet [_, arr, pos, val, world]      = pure $ mkWorld $ "(vector-set! " ++ !(schExp i arr) ++ " "                                         ++ !(schExp i pos) ++ " "                                         ++ !(schExp i val) ++ ")"  schExtCommon i VoidElim [_, _]      = pure "(display \"Error: Executed 'void'\")"  schExtCommon i SysOS []      = pure $ "(blodwen-os)"  schExtCommon i (Unknown n) args      = throw (InternalError ("Can't compile unknown external primitive " ++ show n))  schExtCommon i prim args      = throw (InternalError ("Badly formed external primitive " ++ show prim                                ++ " " ++ show args))   schDef : {auto c : Ref Ctxt Defs} ->           Name -> NamedDef -> Core String  schDef n (MkNmFun args exp)     = pure $ "(define " ++ schName !(getFullName n) ++ " (lambda (" ++ schArglist args ++ ") "                      ++ !(schExp 0 exp) ++ "))\n"  schDef n (MkNmError exp)     = pure $ "(define (" ++ schName !(getFullName n) ++ " . any-args) " ++ !(schExp 0 exp) ++ ")\n"  schDef n (MkNmForeign _ _ _) = pure "" -- compiled by specific back end  schDef n (MkNmCon t a _) = pure "" -- Nothing to compile here -- Convert the name to scheme code-- (There may be no code generated, for example if it's a constructor)exportgetScheme : {auto c : Ref Ctxt Defs} ->            (schExtPrim : Int -> ExtPrim -> List NamedCExp -> Core String) ->            (schString : String -> String) ->            (Name, FC, NamedDef) -> Core StringgetScheme schExtPrim schString (n, fc, d)    = schDef schExtPrim schString n d