5 | module Compiler.Scheme.Common

  7 | import Compiler.Common

  8 | import Compiler.CompileExpr

 10 | import Core.Context

 12 | import Libraries.Data.String.Builder

 14 | import Data.SortedSet

 15 | import Data.Vect

 17 | %default covering

 20 | firstExists : List String -> IO (Maybe String)

 21 | firstExists [] = pure Nothing

 22 | firstExists (x :: xs) = if !(exists x) then pure (Just x) else firstExists xs

 24 | schString : String -> Builder

 25 | schString s = concatMap okchar (unpack s)

 26 |   where

 27 |     okchar : Char -> Builder

 28 |     okchar c = if isAlphaNum c || c =='_'

 29 |                   then char c

 30 |                   else "C-" ++ showB (ord c)

 33 | schUserName : UserName -> Builder

 34 | schUserName (Basic n) = "u--" ++ schString n

 35 | schUserName (Field n) = "rf--" ++ schString n

 36 | schUserName Underscore = "u--_"

 39 | schName : Name -> Builder

 40 | schName (NS ns (UN (Basic n))) = schString (showNSWithSep "-" ns) ++ "-" ++ schString n

 41 | schName (UN n) = schUserName n

 42 | schName (NS ns n) = schString (showNSWithSep "-" ns) ++ "-" ++ schName n

 43 | schName (MN n i) = schString n ++ "-" ++ showB i

 44 | schName (PV n d) = "pat--" ++ schName n

 45 | schName (DN _ n) = schName n

 46 | schName (Nested (i, x) n) = "n--" ++ showB i ++ "-" ++ showB x ++ "-" ++ schName n

 47 | schName (CaseBlock x y) = "case--" ++ schString x ++ "-" ++ showB y

 48 | schName (WithBlock x y) = "with--" ++ schString x ++ "-" ++ showB y

 49 | schName (Resolved i) = "fn--" ++ showB i

 52 | schConstructor : (String -> Builder) -> Name -> Maybe Int -> List Builder -> Builder

 53 | schConstructor _ _ (Just t) args

 54 |     = "(vector " ++ showB t ++ " " ++ sepBy " " args ++ ")"

 55 | schConstructor schString n Nothing args

 56 |     = "(vector " ++ schString (show n) ++ " " ++ Builder.sepBy " " args ++ ")"

 59 | schRecordCon : (String -> Builder) -> Name -> List Builder -> Builder

 60 | schRecordCon _ _ args = "(vector " ++ sepBy " " args ++ ")"

 63 | op : String -> List Builder -> Builder

 64 | op o args = "(" ++ singleton o ++ " " ++ sepBy " " args ++ ")"

 67 | boolop : String -> List Builder -> Builder

 68 | boolop o args = "(or (and " ++ op o args ++ " 1) 0)"

 70 | add : Maybe IntKind -> Builder -> Builder -> Builder

 71 | add (Just $ Signed $ P n)   x y = op "bs+" [x, y, showB (n-1)]

 72 | add (Just $ Unsigned n)     x y = op "bu+" [x, y, showB n]

 73 | add _                       x y = op "+" [x, y]

 75 | sub : Maybe IntKind -> Builder -> Builder -> Builder

 76 | sub (Just $ Signed $ P n)   x y = op "bs-" [x, y, showB (n-1)]

 77 | sub (Just $ Unsigned n)     x y = op "bu-" [x, y, showB n]

 78 | sub _                       x y = op "-" [x, y]

 80 | mul : Maybe IntKind -> Builder -> Builder -> Builder

 81 | mul (Just $ Signed $ P n)   x y = op "bs*" [x, y, showB (n-1)]

 82 | mul (Just $ Unsigned n)     x y = op "bu*" [x, y, showB n]

 83 | mul _                       x y = op "*" [x, y]

 85 | div : Maybe IntKind -> Builder -> Builder -> Builder

 86 | div (Just $ Signed Unlimited) x y = op "blodwen-euclidDiv" [x, y]

 87 | div (Just $ Signed $ P n)     x y = op "bs/" [x, y, showB (n-1)]

 88 | div (Just $ Unsigned n)       x y = op "bu/" [x, y, showB n]

 89 | div _                         x y = op "/" [x, y]

 91 | shl : Maybe IntKind -> Builder -> Builder -> Builder

 92 | shl (Just $ Signed $ P n) x y = op "blodwen-bits-shl-signed"

 93 |                                    [x, y, showB (n-1)]

 94 | shl (Just $ Unsigned n)   x y = op "blodwen-bits-shl" [x, y, showB n]

 95 | shl _                     x y = op "blodwen-shl" [x, y]

 98 | constPrimitives : ConstantPrimitives' Builder

 99 | constPrimitives = MkConstantPrimitives {

100 |     charToInt    = \k     => pure . charTo k

101 |   , intToChar    = \_,x   => pure $ op "cast-int-char" [x]

102 |   , stringToInt  = \k     => pure . strTo k

103 |   , intToString  = \_,x   => pure $ op "number->string" [x]

104 |   , doubleToInt  = \k     => pure . dblTo k

105 |   , intToDouble  = \_,x   => pure $ op "exact->inexact" [x]

106 |   , intToInt     = \k1,k2 => pure . intTo k1 k2

107 |   }

108 |   where charTo : IntKind -> Builder -> Builder

109 |         charTo (Signed Unlimited) x = op "char->integer" [x]

110 |         charTo (Signed $ P n)     x = op "cast-char-boundedInt" [x, showB (n-1)]

111 |         charTo (Unsigned n)       x = op "cast-char-boundedUInt" [x, showB n]

113 |         strTo : IntKind -> Builder -> Builder

114 |         strTo (Signed Unlimited) x = op "cast-string-int" [x]

115 |         strTo (Signed $ P n)     x = op "cast-string-boundedInt" [x, showB (n-1)]

116 |         strTo (Unsigned n)       x = op "cast-string-boundedUInt" [x, showB n]

118 |         dblTo : IntKind -> Builder -> Builder

119 |         dblTo (Signed Unlimited) x = op "exact-truncate" [x]

120 |         dblTo (Signed $ P n)     x = op "exact-truncate-boundedInt" [x, showB (n-1)]

121 |         dblTo (Unsigned n)       x = op "exact-truncate-boundedUInt" [x, showB n]

123 |         intTo : IntKind -> IntKind -> Builder -> Builder

124 |         intTo _ (Signed Unlimited) x = x

125 |         intTo (Signed m) (Signed $ P n) x =

126 |           if P n >= m then x else op "blodwen-toSignedInt" [x, showB (n-1)]

128 |         -- Only if the precision of the target is greater

129 |         -- than the one of the source, there is no need to cast.

130 |         intTo (Unsigned m) (Signed $ P n) x =

131 |           if n > m then x else op "blodwen-toSignedInt" [x, showB (n-1)]

133 |         intTo (Signed _) (Unsigned n) x = op "blodwen-toUnsignedInt" [x, showB n]

135 |         intTo (Unsigned m) (Unsigned n) x =

136 |           if n >= m then x else op "blodwen-toUnsignedInt" [x, showB n]

139 | schOp : {0 arity : Nat} -> PrimFn arity -> Vect arity Builder -> Core Builder

140 | schOp (Add ty) [x, y] = pure $ add (intKind ty) x y

141 | schOp (Sub ty) [x, y] = pure $ sub (intKind ty) x y

142 | schOp (Mul ty) [x, y] = pure $ mul (intKind ty) x y

143 | schOp (Div ty) [x, y] = pure $ div (intKind ty) x y

144 | schOp (Mod ty) [x, y] = pure $ op "blodwen-euclidMod" [x, y]

145 | schOp (Neg ty) [x] = pure $ op "-" [x]

146 | schOp (ShiftL ty) [x, y] = pure $ shl (intKind ty) x y

147 | schOp (ShiftR ty) [x, y] = pure $ op "blodwen-shr" [x, y]

148 | schOp (BAnd ty) [x, y] = pure $ op "blodwen-and" [x, y]

149 | schOp (BOr ty) [x, y] = pure $ op "blodwen-or" [x, y]

150 | schOp (BXOr ty) [x, y] = pure $ op "blodwen-xor" [x, y]

151 | schOp (LT CharType) [x, y] = pure $ boolop "char<?" [x, y]

152 | schOp (LTE CharType) [x, y] = pure $ boolop "char<=?" [x, y]

153 | schOp (EQ CharType) [x, y] = pure $ boolop "char=?" [x, y]

154 | schOp (GTE CharType) [x, y] = pure $ boolop "char>=?" [x, y]

155 | schOp (GT CharType) [x, y] = pure $ boolop "char>?" [x, y]

156 | schOp (LT StringType) [x, y] = pure $ boolop "string<?" [x, y]

157 | schOp (LTE StringType) [x, y] = pure $ boolop "string<=?" [x, y]

158 | schOp (EQ StringType) [x, y] = pure $ boolop "string=?" [x, y]

159 | schOp (GTE StringType) [x, y] = pure $ boolop "string>=?" [x, y]

160 | schOp (GT StringType) [x, y] = pure $ boolop "string>?" [x, y]

161 | schOp (LT ty) [x, y] = pure $ boolop "<" [x, y]

162 | schOp (LTE ty) [x, y] = pure $ boolop "<=" [x, y]

163 | schOp (EQ ty) [x, y] = pure $ boolop "=" [x, y]

164 | schOp (GTE ty) [x, y] = pure $ boolop ">=" [x, y]

165 | schOp (GT ty) [x, y] = pure $ boolop ">" [x, y]

166 | schOp StrLength [x] = pure $ op "string-length" [x]

167 | schOp StrHead [x] = pure $ op "string-ref" [x, "0"]

168 | schOp StrTail [x] = pure $ op "substring" [x, "1", op "string-length" [x]]

169 | schOp StrIndex [x, i] = pure $ op "string-ref" [x, i]

170 | schOp StrCons [x, y] = pure $ op "string-cons" [x, y]

171 | schOp StrAppend [x, y] = pure $ op "string-append" [x, y]

172 | schOp StrReverse [x] = pure $ op "string-reverse" [x]

173 | schOp StrSubstr [x, y, z] = pure $ op "string-substr" [x, y, z]

176 | schOp DoubleExp [x] = pure $ op "flexp" [x] -- Base is `e`. Same as: `pow(e, x)`

177 | schOp DoubleLog [x] = pure $ op "fllog" [x] -- Base is `e`.

178 | schOp DoublePow [x, y] = pure $ op "flexpt" [x, y]

179 | schOp DoubleSin [x] = pure $ op "flsin" [x]

180 | schOp DoubleCos [x] = pure $ op "flcos" [x]

181 | schOp DoubleTan [x] = pure $ op "fltan" [x]

182 | schOp DoubleASin [x] = pure $ op "flasin" [x]

183 | schOp DoubleACos [x] = pure $ op "flacos" [x]

184 | schOp DoubleATan [x] = pure $ op "flatan" [x]

185 | schOp DoubleSqrt [x] = pure $ op "flsqrt" [x]

186 | schOp DoubleFloor [x] = pure $ op "flfloor" [x]

187 | schOp DoubleCeiling [x] = pure $ op "flceiling" [x]

189 | schOp (Cast DoubleType StringType)  [x] = pure $ op "number->string" [x]

190 | schOp (Cast CharType StringType)    [x] = pure $ op "string" [x]

191 | schOp (Cast StringType DoubleType)  [x] = pure $ op "cast-string-double" [x]

193 | schOp (Cast from to)                [x] = castInt constPrimitives from to x

195 | schOp BelieveMe [_,_,x] = pure x

196 | schOp Crash [_,msg] = pure $ "(blodwen-error-quit (string-append \"ERROR: \" " ++ msg ++ "))"

199 | public export

200 | data ExtPrim = NewIORef | ReadIORef | WriteIORef

201 |              | NewArray | ArrayGet | ArraySet

202 |              | GetField | SetField

203 |              | SysOS | SysCodegen

204 |              | OnCollect

205 |              | OnCollectAny

206 |              | Unknown Name

209 | Show ExtPrim where

210 |   show NewIORef = "NewIORef"

211 |   show ReadIORef = "ReadIORef"

212 |   show WriteIORef = "WriteIORef"

213 |   show NewArray = "NewArray"

214 |   show ArrayGet = "ArrayGet"

215 |   show ArraySet = "ArraySet"

216 |   show GetField = "GetField"

217 |   show SetField = "SetField"

218 |   show SysOS = "SysOS"

219 |   show SysCodegen = "SysCodegen"

220 |   show OnCollect = "OnCollect"

221 |   show OnCollectAny = "OnCollectAny"

222 |   show (Unknown n) = "Unknown " ++ show n

225 | toPrim : Name -> ExtPrim

226 | toPrim pn@(NS _ n)

227 |     = cond [(n == UN (Basic "prim__newIORef"), NewIORef),

228 |             (n == UN (Basic "prim__readIORef"), ReadIORef),

229 |             (n == UN (Basic "prim__writeIORef"), WriteIORef),

230 |             (n == UN (Basic "prim__newArray"), NewArray),

231 |             (n == UN (Basic "prim__arrayGet"), ArrayGet),

232 |             (n == UN (Basic "prim__arraySet"), ArraySet),

233 |             (n == UN (Basic "prim__getField"), GetField),

234 |             (n == UN (Basic "prim__setField"), SetField),

235 |             (n == UN (Basic "prim__os"), SysOS),

236 |             (n == UN (Basic "prim__codegen"), SysCodegen),

237 |             (n == UN (Basic "prim__onCollect"), OnCollect),

238 |             (n == UN (Basic "prim__onCollectAny"), OnCollectAny)

239 |             ]

240 |            (Unknown pn)

241 | toPrim pn = Unknown pn

244 | mkWorld : Builder -> Builder

245 | mkWorld res = res -- MkIORes is a newtype now! schConstructor 0 [res, "#f"] -- MkIORes

247 | schPrimType : PrimType -> Builder

248 | schPrimType _ = "#t"

250 | schConstant : (String -> Builder) -> Constant -> Builder

251 | schConstant _ (I x) = showB x

252 | schConstant _ (I8 x) = showB x

253 | schConstant _ (I16 x) = showB x

254 | schConstant _ (I32 x) = showB x

255 | schConstant _ (I64 x) = showB x

256 | schConstant _ (BI x) = showB x

257 | schConstant _ (B8 x) = showB x

258 | schConstant _ (B16 x) = showB x

259 | schConstant _ (B32 x) = showB x

260 | schConstant _ (B64 x) = showB x

261 | schConstant schString (Str x) = schString x

262 | schConstant _ (Ch x)

263 |    = if (ord x >= 32 && ord x < 127)

264 |         then "#\\" ++ char x

265 |         else "(integer->char " ++ showB (ord x) ++ ")"

266 | schConstant _ (Db x) = showB x

267 | schConstant _ (PrT t) = schPrimType t

268 | schConstant _ WorldVal = "#f"

270 | schCaseDef : Maybe Builder -> Builder

271 | schCaseDef Nothing = ""

272 | schCaseDef (Just tm) = "(else " ++ tm ++ ")"

275 | schArglist : List Name -> Builder

276 | schArglist xs = sepBy " " $ map schName xs

282 |   used : Name -> NamedCExp -> Bool

283 |   used n (NmLocal fc n') = n == n'

284 |   used n (NmRef {}) = False

285 |   used n (NmLam _ _ sc) = used n sc

286 |   used n (NmLet _ _ v sc) = used n v || used n sc

287 |   used n (NmApp _ f args) = used n f || any (used n) args

288 |   used n (NmCon _ _ _ _ args) = any (used n) args

289 |   used n (NmOp _ _ args) = any (used n) (toList args)

290 |   used n (NmExtPrim _ _ args) = any (used n) args

291 |   used n (NmForce _ _ t) = used n t

292 |   used n (NmDelay _ _ t) = used n t

293 |   used n (NmConCase _ sc alts def)

294 |       = used n sc || any (usedCon n) alts

295 |             || maybe False (used n) def

296 |   used n (NmConstCase _ sc alts def)

297 |       = used n sc || any (usedConst n) alts

298 |             || maybe False (used n) def

299 |   used n _ = False

301 |   usedCon : Name -> NamedConAlt -> Bool

302 |   usedCon n (MkNConAlt _ _ _ _ sc) = used n sc

304 |   usedConst : Name -> NamedConstAlt -> Bool

305 |   usedConst n (MkNConstAlt _ sc) = used n sc

307 | var : NamedCExp -> Bool

308 | var (NmLocal {}) = True

309 | var _ = False

311 | getScrutineeTemp : Nat -> Builder

312 | getScrutineeTemp i = fromString $ "sc" ++ show i

314 | public export

315 | record LazyExprProc where

316 |   constructor MkLazyExprProc

317 |   processDelay : Builder -> Builder

318 |   processForce : Builder -> Builder

320 | public export

321 | defaultLaziness : LazyExprProc

322 | defaultLaziness = MkLazyExprProc

323 |   (\expr => "(lambda () " ++ expr ++ ")")

324 |   (\expr => "(" ++ expr ++ ")")

326 | public export

327 | weakMemoLaziness : LazyExprProc

328 | weakMemoLaziness = MkLazyExprProc

329 |   (\expr => "(blodwen-delay-lazy (lambda () " ++ expr ++ "))")

330 |   (\expr => "(blodwen-force-lazy " ++ expr ++ ")")

332 | parameters (constants : SortedSet Name)

333 |            (schExtPrim : Nat -> ExtPrim -> List NamedCExp -> Core Builder)

334 |            (schString : String -> Builder)

335 |            (schLazy : LazyExprProc)

336 |   showTag : Name -> Maybe Int -> Builder

337 |   showTag n (Just i) = showB i

338 |   showTag n Nothing = schString (show n)

340 |   mutual

341 |     ||| Bind arguments of a data constructor represented by a vector

347 |     bindArgs : (target : Builder) -> (sc : NamedCExp) -> (i : Nat) -> (ns : List Name) -> (body : Builder) -> Builder

348 |     bindArgs target sc i [] body = body

349 |     bindArgs target sc i (n :: ns) body

350 |         = if used n sc

351 |                 then "(let ((" ++ schName n ++ " " ++ "(vector-ref " ++ target ++ " " ++ showB i ++ "))) "

352 |                 ++ bindArgs target sc (i + 1) ns body ++ ")"

353 |                 else bindArgs target sc (i + 1) ns body

355 |     schConAlt : Nat -> Builder -> NamedConAlt -> Core Builder

356 |     schConAlt i target (MkNConAlt n ci tag args sc)

357 |         = pure $ "((" ++ showTag n tag ++ ") "

358 |                       ++ bindArgs target sc 1 args !(schExp i sc) ++ ")"

360 |     schConUncheckedAlt : Nat -> Builder -> NamedConAlt -> Core Builder

361 |     schConUncheckedAlt i target (MkNConAlt n ci tag args sc)

362 |         = pure $ bindArgs target sc 1 args !(schExp i sc)

364 |     schConstAlt : Nat -> Builder -> NamedConstAlt -> Core Builder

365 |     schConstAlt i target (MkNConstAlt c exp)

366 |         = pure $ "((equal? " ++ target ++ " " ++ schConstant schString c ++ ") " ++ !(schExp i exp) ++ ")"

368 |     -- oops, no traverse for Vect in Core

369 |     schArgs : Nat -> Vect n NamedCExp -> Core (Vect n Builder)

370 |     schArgs i xs = traverseVect (schExp i) xs

371 |     -- schArgs i [] = pure []

372 |     -- schArgs i (arg :: args) = pure $ !(schExp i arg) :: !(schArgs i args)

374 |     schCaseTree : Nat -> NamedCExp -> List NamedConAlt -> Maybe NamedCExp ->

375 |                   Core Builder

376 |     schCaseTree i sc [] def

377 |         = do tcode <- schExp (i + 1) sc

378 |              defc <- maybe (pure "'erased") (schExp i) def

379 |              let n = getScrutineeTemp i

380 |              if var sc

381 |                 then pure defc

382 |                 else pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) "

383 |                              ++ defc ++ ")"

384 |     schCaseTree i sc [alt] Nothing

385 |         = do tcode <- schExp (i + 1) sc

386 |              let n = getScrutineeTemp i

387 |              if var sc

388 |                 then pure !(schConUncheckedAlt (i + 1) tcode alt)

389 |                 else pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) " ++

390 |                         !(schConUncheckedAlt (i + 1) n alt) ++ ")"

391 |     schCaseTree i sc alts Nothing

392 |         = do tcode <- schExp (i + 1) sc

393 |              let n = getScrutineeTemp i

394 |              if var sc

395 |                 then pure $ "(case (vector-ref " ++ tcode ++ " 0) "

396 |                        ++ !(showAlts tcode alts) ++

397 |                        ")"

398 |                 else pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (case (vector-ref " ++ n ++ " 0) "

399 |                        ++ !(showAlts n alts) ++

400 |                        "))"

401 |       where

402 |         showAlts : Builder -> List NamedConAlt -> Core Builder

403 |         showAlts n [] = pure ""

404 |         showAlts n [alt]

405 |            = pure $ "(else " ++ !(schConUncheckedAlt (i + 1) n alt) ++ ")"

406 |         showAlts n (alt :: alts)

407 |            = pure $ !(schConAlt (i + 1) n alt) ++ " " ++

408 |                     !(showAlts n alts)

409 |     schCaseTree i sc alts def

410 |         = do tcode <- schExp (i + 1) sc

411 |              defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i v))) def

412 |              let n = getScrutineeTemp i

413 |              if var sc

414 |                 then pure $ "(case (vector-ref " ++ tcode ++ " 0) "

415 |                                ++ sepBy " " !(traverse (schConAlt (i + 1) tcode) alts)

416 |                                ++ schCaseDef defc ++ ")"

417 |                 else pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (case (vector-ref " ++ n ++ " 0) "

418 |                        ++ sepBy " " !(traverse (schConAlt (i + 1) n) alts)

419 |                        ++ schCaseDef defc ++ "))"

421 |     schRecordCase : Nat -> NamedCExp -> List NamedConAlt -> Maybe NamedCExp ->

422 |                     Core Builder

423 |     schRecordCase i sc [] _ = pure "#f" -- suggests empty case block!

424 |     schRecordCase i sc [alt] _

425 |         = do tcode <- schExp (i + 1) sc

426 |              let n = getScrutineeTemp i

427 |              if var sc

428 |                 then getAltCode tcode alt

429 |                 else do alt' <- getAltCode n alt

430 |                         pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) " ++

431 |                                      alt' ++ ")"

432 |       where

433 |         getAltCode : Builder -> NamedConAlt -> Core Builder

434 |         getAltCode n (MkNConAlt _ _ _ args sc)

435 |             = pure $ bindArgs n sc 0 args !(schExp i sc)

436 |     schRecordCase _ _ _ _ = throw $ InternalError "Case of a record has multiple alternatives"

438 |     schListCase : Nat -> NamedCExp -> List NamedConAlt -> Maybe NamedCExp ->

439 |                   Core Builder

440 |     schListCase i sc alts def

441 |         = do tcode <- schExp (i + 1) sc

442 |              let n = getScrutineeTemp i

443 |              defc <- maybe (pure Nothing)

444 |                            (\v => pure (Just !(schExp (i + 1) v))) def

445 |              nil <- getNilCode alts

446 |              if var sc

447 |                 then do cons <- getConsCode tcode alts

448 |                         pure $ buildCase tcode nil cons defc

449 |                 else do cons <- getConsCode n alts

450 |                         pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) " ++

451 |                             buildCase n nil cons defc ++ ")"

452 |       where

453 |         buildCase : Builder ->

454 |                     Maybe Builder -> Maybe Builder -> Maybe Builder ->

455 |                     Builder

456 |         buildCase n (Just nil) (Just cons) _

457 |             = "(if (null? " ++ n ++ ") " ++ nil ++ " " ++ cons ++ ")"

458 |         buildCase n (Just nil) Nothing Nothing = nil

459 |         buildCase n Nothing (Just cons) Nothing = cons

460 |         buildCase n (Just nil) Nothing (Just def)

461 |             = "(if (null? " ++ n ++ ") " ++ nil ++ " " ++ def ++ ")"

462 |         buildCase n Nothing (Just cons) (Just def)

463 |             = "(if (null? " ++ n ++ ") " ++ def ++ " " ++ cons ++ ")"

464 |         buildCase n Nothing Nothing (Just def) = def

465 |         buildCase n Nothing Nothing Nothing = "#f"

467 |         getNilCode : List NamedConAlt -> Core (Maybe Builder)

468 |         getNilCode [] = pure Nothing

469 |         getNilCode (MkNConAlt _ NIL _ _ sc :: _)

470 |             = pure (Just !(schExp (i + 1) sc))

471 |         getNilCode (_ :: xs) = getNilCode xs

473 |         getConsCode : Builder -> List NamedConAlt -> Core (Maybe Builder)

474 |         getConsCode n [] = pure Nothing

475 |         getConsCode n (MkNConAlt _ CONS _ [x,xs] sc :: _)

476 |             = do sc' <- schExp (i + 1) sc

477 |                  pure $ Just $ bindArgs [(x, "car"), (xs, "cdr")] sc'

478 |           where

479 |             bindArgs : (ns : List (Name, Builder)) -> Builder -> Builder

480 |             bindArgs [] body = body

481 |             bindArgs ((x, get) :: ns) body

482 |                 = if used x sc

483 |                      then "(let ((" ++ schName x ++ " " ++ "(" ++ get ++ " " ++ n ++ "))) "

484 |                         ++ bindArgs ns body ++ ")"

485 |                      else bindArgs ns body

486 |         getConsCode x (_ :: xs) = getConsCode x xs

488 |     schMaybeCase : Nat -> NamedCExp -> List NamedConAlt -> Maybe NamedCExp ->

489 |                    Core Builder

490 |     schMaybeCase i sc alts def

491 |         = do tcode <- schExp (i + 1) sc

492 |              let n = getScrutineeTemp i

493 |              defc <- maybe (pure Nothing)

494 |                            (\v => pure (Just !(schExp (i + 1) v))) def

495 |              nothing <- getNothingCode alts

496 |              if var sc

497 |                 then do just <- getJustCode tcode alts

498 |                         pure $ buildCase tcode nothing just defc

499 |                 else do just <- getJustCode n alts

500 |                         pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) " ++

501 |                             buildCase n nothing just defc ++ ")"

502 |       where

503 |         buildCase : Builder ->

504 |                     Maybe Builder -> Maybe Builder -> Maybe Builder ->

505 |                     Builder

506 |         buildCase n (Just nothing) (Just just) _

507 |             = "(if (null? " ++ n ++ ") " ++ nothing ++ " " ++ just ++ ")"

508 |         buildCase n (Just nothing) Nothing Nothing = nothing

509 |         buildCase n Nothing (Just just) Nothing = just

510 |         buildCase n (Just nothing) Nothing (Just def)

511 |             = "(if (null? " ++ n ++ ") " ++ nothing ++ " " ++ def ++ ")"

512 |         buildCase n Nothing (Just just) (Just def)

513 |             = "(if (null? " ++ n ++ ") " ++ def ++ " " ++ just ++ ")"

514 |         buildCase n Nothing Nothing (Just def) = def

515 |         buildCase n Nothing Nothing Nothing = "#f"

517 |         getNothingCode : List NamedConAlt -> Core (Maybe Builder)

518 |         getNothingCode [] = pure Nothing

519 |         getNothingCode (MkNConAlt _ NOTHING _ _ sc :: _)

520 |             = pure (Just !(schExp (i + 1) sc))

521 |         getNothingCode (_ :: xs) = getNothingCode xs

523 |         getJustCode : Builder -> List NamedConAlt -> Core (Maybe Builder)

524 |         getJustCode n [] = pure Nothing

525 |         getJustCode n (MkNConAlt _ JUST _ [x] sc :: _)

526 |             = do sc' <- schExp (i + 1) sc

527 |                  pure $ Just $ bindArg x sc'

528 |           where

529 |             bindArg : Name -> Builder -> Builder

530 |             bindArg x body

531 |                 = if used x sc

532 |                      then "(let ((" ++ schName x ++ " " ++ "(unbox " ++ n ++ "))) "

533 |                         ++ body ++ ")"

534 |                      else body

535 |         getJustCode x (_ :: xs) = getJustCode x xs

537 |     export

538 |     schExp : Nat -> NamedCExp -> Core Builder

539 |     schExp i (NmLocal fc n) = pure $ schName n

540 |     schExp i (NmRef fc n) = pure $ schName n

541 |     schExp i (NmLam fc x sc)

542 |        = do sc' <- schExp i sc

543 |             pure $ "(lambda (" ++ schName x ++ ") " ++ sc' ++ ")"

544 |     schExp i (NmLet fc x val sc)

545 |        = do val' <- schExp i val

546 |             sc' <- schExp i sc

547 |             pure $ "(let ((" ++ schName x ++ " " ++ val' ++ ")) " ++ sc' ++ ")"

548 |     schExp i (NmApp fc x@(NmRef exp n) []) =

549 |       if contains n constants

550 |         then schExp i x

551 |         else pure $ "(" ++ !(schExp i x) ++ ")"

553 |     schExp i (NmApp fc x args)

554 |         = pure $ "(" ++ !(schExp i x) ++ " " ++ sepBy " " !(traverse (schExp i) args) ++ ")"

555 |     schExp i (NmCon fc _ NIL tag []) = pure $ "'()"

556 |     schExp i (NmCon fc _ NIL tag _) = throw (InternalError "Bad NIL")

557 |     schExp i (NmCon fc _ CONS tag [x, xs])

558 |         = do x' <- schExp i x

559 |              xs' <- schExp i xs

560 |              pure $ "(cons " ++ x' ++ " " ++ xs' ++ ")"

561 |     schExp i (NmCon fc _ CONS tag _) = throw (InternalError "Bad CONS")

562 |     schExp i (NmCon fc _ NOTHING tag []) = pure $ "'()"

563 |     schExp i (NmCon fc _ NOTHING tag _) = throw (InternalError "Bad NOTHING")

564 |     schExp i (NmCon fc _ JUST tag [x])

565 |         = do x' <- schExp i x

566 |              pure $ "(box " ++ x' ++ ")"

567 |     schExp i (NmCon fc _ JUST tag _) = throw (InternalError "Bad JUST")

568 |     schExp i (NmCon fc x RECORD tag args)

569 |         = pure $ schRecordCon schString x !(traverse (schExp i) args)

570 |     schExp i (NmCon fc x ci tag args)

571 |         = pure $ schConstructor schString x tag !(traverse (schExp i) args)

572 |     schExp i (NmOp fc op args)

573 |         = schOp op !(schArgs i args)

574 |     schExp i (NmExtPrim fc p args)

575 |         = schExtPrim i (toPrim p) args

576 |     schExp i (NmForce _ _ (NmApp fc x@(NmRef {}) []))

577 |        = pure $ "(force " ++ !(schExp i x) ++ ")" -- Special version for memoized toplevel lazy definitions

578 |     schExp i (NmForce fc lr t) = pure $ schLazy.processForce !(schExp i t)

579 |     schExp i (NmDelay fc lr t) = pure $ schLazy.processDelay !(schExp i t)

580 |     schExp i (NmConCase fc sc alts def)

581 |         = cond [(recordCase alts, schRecordCase i sc alts def),

582 |                 (maybeCase alts, schMaybeCase i sc alts def),

583 |                 (listCase alts, schListCase i sc alts def)]

584 |                 -- probably more to come here...

585 |                 (schCaseTree i sc alts def)

586 |       where

587 |         listCase : List NamedConAlt -> Bool

588 |         listCase (MkNConAlt _ NIL _ _ _ :: _) = True

589 |         listCase (MkNConAlt _ CONS _ _ _ :: _) = True

590 |         listCase _ = False

592 |         maybeCase : List NamedConAlt -> Bool

593 |         maybeCase (MkNConAlt _ NOTHING _ _ _ :: _) = True

594 |         maybeCase (MkNConAlt _ JUST _ _ _ :: _) = True

595 |         maybeCase _ = False

597 |         recordCase : List NamedConAlt -> Bool

598 |         recordCase (MkNConAlt _ RECORD _ _ _ :: _) = True

599 |         recordCase _ = False

601 |     schExp i (NmConstCase fc sc alts Nothing)

602 |         = do tcode <- schExp (i + 1) sc

603 |              let n = getScrutineeTemp i

604 |              if var sc

605 |                 then pure $ "(cond "

606 |                           ++ !(showConstAlts tcode alts)

607 |                           ++ ")"

608 |                 else pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (cond "

609 |                           ++ !(showConstAlts n alts)

610 |                           ++ "))"

611 |       where

612 |         showConstAlts : Builder -> List NamedConstAlt -> Core Builder

613 |         showConstAlts n [] = pure ""

614 |         showConstAlts n [MkNConstAlt c exp]

615 |            = pure $ "(else " ++ !(schExp (i + 1) exp) ++ ")"

616 |         showConstAlts n (alt :: alts)

617 |            = pure $ !(schConstAlt (i + 1) n alt) ++ " " ++

618 |                     !(showConstAlts n alts)

619 |     schExp i (NmConstCase fc sc alts def)

620 |         = do defc <- maybe (pure Nothing) (\v => pure (Just !(schExp i v))) def

621 |              tcode <- schExp (i + 1) sc

622 |              let n = getScrutineeTemp i

623 |              if var sc

624 |                 then pure $ "(cond "

625 |                           ++ sepBy " " !(traverse (schConstAlt (i + 1) tcode) alts)

626 |                           ++ schCaseDef defc ++ ")"

627 |                 else pure $ "(let ((" ++ n ++ " " ++ tcode ++ ")) (cond "

628 |                           ++ sepBy " " !(traverse (schConstAlt (i + 1) n) alts)

629 |                           ++ schCaseDef defc ++ "))"

630 |     schExp i (NmPrimVal fc c) = pure $ schConstant schString c

631 |     schExp i (NmErased fc) = pure "'erased"

632 |     schExp i (NmCrash fc msg) = pure $ "(blodwen-error-quit " ++ showB msg ++ ")"

634 |   -- External primitives which are common to the scheme codegens (they can be

635 |   -- overridden)

636 |   export

637 |   schExtCommon : Nat -> ExtPrim -> List NamedCExp -> Core Builder

638 |   schExtCommon i NewIORef [_, val, world]

639 |       = pure $ mkWorld $ "(box " ++ !(schExp i val) ++ ")"

640 |   schExtCommon i ReadIORef [_, ref, world]

641 |       = pure $ mkWorld $ "(unbox " ++ !(schExp i ref) ++ ")"

642 |   schExtCommon i WriteIORef [_, ref, val, world]

643 |       = pure $ mkWorld $ "(set-box! "

644 |                            ++ !(schExp i ref) ++ " "

645 |                            ++ !(schExp i val) ++ ")"

646 |   schExtCommon i NewArray [_, size, val, world]

647 |       = pure $ mkWorld $ "(make-vector " ++ !(schExp i size) ++ " "

648 |                                          ++ !(schExp i val) ++ ")"

649 |   schExtCommon i ArrayGet [_, arr, pos, world]

650 |       = pure $ mkWorld $ "(vector-ref " ++ !(schExp i arr) ++ " "

651 |                                         ++ !(schExp i pos) ++ ")"

652 |   schExtCommon i ArraySet [_, arr, pos, val, world]

653 |       = pure $ mkWorld $ "(vector-set! " ++ !(schExp i arr) ++ " "

654 |                                          ++ !(schExp i pos) ++ " "

655 |                                          ++ !(schExp i val) ++ ")"

656 |   schExtCommon i SysOS []

657 |       = pure $ "(blodwen-os)"

658 |   schExtCommon i (Unknown n) args

659 |       = throw (InternalError ("Can't compile unknown external primitive " ++ show n))

660 |   schExtCommon i prim args

661 |       = throw (InternalError ("Badly formed external primitive " ++ show prim

662 |                                 ++ " " ++ show args))

664 |   schDef : {auto c : Ref Ctxt Defs} ->

665 |            Name -> NamedDef -> Core Builder

667 |   schDef n (MkNmFun [] (NmDelay _ _ exp))

668 |     = pure $ "(define " ++ schName !(getFullName n) ++ "(delay "

669 |                      ++ !(schExp 0 exp) ++ "))\n" -- Special version for memoized toplevel lazy definitions

671 |   schDef n (MkNmFun [] exp)

672 |      = if contains n constants

673 |           then pure $ "(define " ++ schName !(getFullName n) ++ " " ++ !(schExp 0 exp) ++ ")\n"

674 |           else pure $ "(define " ++ schName !(getFullName n) ++ " (lambda () " ++ !(schExp 0 exp) ++ "))\n"

677 |   schDef n (MkNmFun args exp)

678 |      = pure $ "(define " ++ schName !(getFullName n) ++ " (lambda (" ++ schArglist args ++ ") "

679 |                       ++ !(schExp 0 exp) ++ "))\n"

680 |   schDef n (MkNmError exp)

681 |      = pure $ "(define (" ++ schName !(getFullName n) ++ " . any-args) " ++ !(schExp 0 exp) ++ ")\n"

682 |   schDef n (MkNmForeign {}) = pure "" -- compiled by specific back end

683 |   schDef n (MkNmCon t a _) = pure "" -- Nothing to compile here

688 | getScheme : {auto c : Ref Ctxt Defs} ->

689 |             (constants  : SortedSet Name) ->

690 |             (schExtPrim : Nat -> ExtPrim -> List NamedCExp -> Core Builder) ->

691 |             (schString : String -> Builder) ->

692 |             (schLazy : LazyExprProc) ->

693 |             (Name, FC, NamedDef) -> Core Builder

694 | getScheme constants schExtPrim schString schLazy (n, fc, d)

695 |     = schDef constants schExtPrim schString schLazy n d