diff options
author | Eduardo Julian | 2018-04-18 01:28:24 -0400 |
---|---|---|
committer | Eduardo Julian | 2018-04-18 01:28:24 -0400 |
commit | 7d539a83fd55f7ced7657302054e099955b55ae2 (patch) | |
tree | 6aa50f8d58d87da48880569ed2f748e8bc014243 /new-luxc/source/luxc/lang/host/scheme.lux | |
parent | 6eb9cf17f161522d4eddf6783284952f8a84f099 (diff) |
- Initial Scheme back-end implementation.
Diffstat (limited to '')
-rw-r--r-- | new-luxc/source/luxc/lang/host/scheme.lux | 260 |
1 files changed, 260 insertions, 0 deletions
diff --git a/new-luxc/source/luxc/lang/host/scheme.lux b/new-luxc/source/luxc/lang/host/scheme.lux new file mode 100644 index 000000000..db91b94ce --- /dev/null +++ b/new-luxc/source/luxc/lang/host/scheme.lux @@ -0,0 +1,260 @@ +(.module: + [lux #- not or and list if function cond when let] + (lux (control pipe) + (data [maybe "maybe/" Functor<Maybe>] + [text] + text/format + [number] + (coll [list "list/" Functor<List> Fold<List>])) + (type abstract))) + +(abstract: #export Single {} Unit) +(abstract: #export Poly {} Unit) + +(abstract: #export (Var kind) + {} + + Text + + (def: name (All [k] (-> (Var k) Text)) (|>> @representation)) + + (def: #export var (-> Text (Var Single)) (|>> @abstraction)) + + (def: #export (poly vars) + (-> (List (Var Single)) (Var Poly)) + (@abstraction + (format "(" (|> vars (list/map ..name) (text.join-with " ")) ")"))) + + (def: #export (poly+ vars rest) + (-> (List (Var Single)) (Var Single) (Var Poly)) + (@abstraction + (format "(" (|> vars (list/map ..name) (text.join-with " ")) + " . " (..name rest) + ")"))) + ) + +(type: #export SVar (Var Single)) +(type: #export PVar (Var Poly)) +(type: #export *Var (Ex [k] (Var k))) + +(abstract: #export Expression + {} + + Text + + (def: #export expression (-> Expression Text) (|>> @representation)) + + (def: #export code (-> Text Expression) (|>> @abstraction)) + + (def: #export nil + Expression + (@abstraction "'()")) + + (def: #export bool + (-> Bool Expression) + (|>> (case> true "#t" + false "#f") + @abstraction)) + + (def: #export int + (-> Int Expression) + (|>> %i @abstraction)) + + (def: #export float + (-> Frac Expression) + (|>> (cond> [(f/= number.positive-infinity)] + [(new> "+inf.0")] + + [(f/= number.negative-infinity)] + [(new> "-inf.0")] + + [number.not-a-number?] + [(new> "+nan.0")] + + ## else + [%f]) + @abstraction)) + + (def: #export positive-infinity Expression (..float number.positive-infinity)) + (def: #export negative-infinity Expression (..float number.negative-infinity)) + (def: #export not-a-number Expression (..float number.not-a-number)) + + (def: #export string + (-> Text Expression) + (|>> %t @abstraction)) + + (def: #export symbol + (-> Text Expression) + (|>> (format "'") @abstraction)) + + (def: #export (form elements) + (-> (List Expression) Expression) + (@abstraction + (format "(" (|> elements (list/map expression) (text.join-with " ")) ")"))) + + (def: #export @@ + (All [k] (-> (Var k) Expression)) + (|>> ..name @abstraction)) + + (def: #export global + (-> Text Expression) + (|>> var @@)) + + (def: #export (apply func args) + (-> Expression (List Expression) Expression) + (form (#.Cons func args))) + + (do-template [<name> <function>] + [(def: #export <name> + (-> (List Expression) Expression) + (apply (..global <function>)))] + + [vector "vector"] + [list "list"] + ) + + (def: #export (apply1 func) + (-> Expression (-> Expression Expression)) + (|>> (.list) (..apply func))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply1 (..global <scheme-name>)))] + + [length "length"] + [values "values"] + [null? "null?"] + [car "car"] + [cdr "cdr"] + [raise "raise"] + [error-object-message "error-object-message"] + [make-vector "make-vector"] + [not "not"] + [string-hash "string-hash"] + ) + + (def: #export (apply2 func) + (-> Expression (-> Expression Expression Expression)) + (.function (_ _0 _1) + (..apply func (.list _0 _1)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply2 (..global <scheme-name>)))] + + [append "append"] + [cons "cons"] + [vector-ref "vector-ref"] + [list-tail "list-tail"] + ) + + (def: #export (apply3 func) + (-> Expression (-> Expression Expression Expression Expression)) + (.function (_ _0 _1 _2) + (..apply func (.list _0 _1 _2)))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> (apply3 (..global <scheme-name>)))] + + [vector-set! "vector-set!"] + ) + + (def: #export (vector-copy! _0 _1 _2 _3 _4) + (-> Expression Expression Expression Expression Expression + Expression) + (..apply (..global "vector-copy!") + (.list _0 _1 _2 _3 _4))) + + (do-template [<lux-name> <scheme-name>] + [(def: #export <lux-name> + (-> (List Expression) Expression) + (|>> (.list& (..global <scheme-name>)) ..form))] + + [or "or"] + [and "and"] + ) + + (do-template [<lux-name> <scheme-name>] + [(def: #export (<lux-name> param subject) + (-> Expression Expression Expression) + (..form (.list (..global <scheme-name>) subject param)))] + + [= "="] + [eq? "eq?"] + [eqv? "eqv?"] + [< "<"] + [<= "<="] + [> ">"] + [>= ">="] + [string=? "string=?"] + [string<? "string<?"] + [+ "+"] + [- "-"] + [/ "/"] + [* "*"] + [expt "expt"] + [remainder "remainder"] + [quotient "quotient"] + [mod "mod"] + [arithmetic-shift "arithmetic-shift"] + [bit-and "bitwise-and"] + [bit-or "bitwise-ior"] + [bit-xor "bitwise-xor"] + ) + + (do-template [<lux-name> <scheme-name> <var>] + [(def: #export (<lux-name> bindings body) + (-> (List [<var> Expression]) Expression Expression) + (..form (.list (..global <scheme-name>) + (|> bindings + (list/map (.function (_ [fname fvalue]) + (..form (.list (@@ fname) fvalue)))) + ..form) + body)))] + + [let "let" SVar] + [let* "let*" SVar] + [letrec "letrec" SVar] + [let-values "let-values" PVar] + ) + + (def: #export (if test then else) + (-> Expression Expression Expression Expression) + (..form (.list (..global "if") test then else))) + + (def: #export (when test then) + (-> Expression Expression Expression) + (..form (.list (..global "when") test then))) + + (def: #export (cond clauses else) + (-> (List [Expression Expression]) Expression Expression) + (list/fold (.function (_ [test then] next) + (if test then next)) + else + (list.reverse clauses))) + + (def: #export (lambda input body) + (-> *Var Expression Expression) + (..form (.list (..global "lambda") (@@ input) body))) + + (def: #export (define name inputs body) + (-> SVar (List SVar) Expression Expression) + (..form (.list (..global "define") + (case inputs + #.Nil + (@@ name) + + _ + (@@ (..poly (#.Cons name inputs)))) + body))) + + (def: #export begin + (-> (List Expression) Expression) + (|>> (#.Cons (..global "begin")) ..form)) + + (def: #export (set! name value) + (-> SVar Expression Expression) + (..form (.list (..global "set!") (@@ name) value))) + + (def: #export (with-exception-handler handler body) + (-> Expression Expression Expression) + (..form (.list (..global "with-exception-handler") handler body))) + ) |