diff options
Diffstat (limited to 'stdlib/source/library/lux/meta/compiler/target/scheme.lux')
| -rw-r--r-- | stdlib/source/library/lux/meta/compiler/target/scheme.lux | 388 |
1 files changed, 388 insertions, 0 deletions
diff --git a/stdlib/source/library/lux/meta/compiler/target/scheme.lux b/stdlib/source/library/lux/meta/compiler/target/scheme.lux new file mode 100644 index 000000000..da0e850c0 --- /dev/null +++ b/stdlib/source/library/lux/meta/compiler/target/scheme.lux @@ -0,0 +1,388 @@ +(.require + [library + [lux (.except Code int or and if cond let symbol when) + [abstract + [equivalence (.only Equivalence)] + [hash (.only Hash)]] + [control + ["[0]" pipe]] + [data + ["[0]" text (.only) + ["%" \\format (.only format)]] + [collection + ["[0]" list (.use "[1]#[0]" functor monoid)]]] + [math + [number + ["n" nat] + ["f" frac]]] + [meta + [macro + ["[0]" template]] + [type + ["[0]" nominal (.except def)]]]]]) + +... Added the carriage return for better Windows compatibility. +(def \n+ + Text + (format text.carriage_return text.new_line)) + +(def nested + (-> Text Text) + (.let [nested_new_line (format text.new_line text.tab)] + (text.replaced text.new_line nested_new_line))) + +(nominal.def .public (Code k) + Text + + (def .public equivalence + (All (_ brand) (Equivalence (Code brand))) + (implementation + (def (= reference subject) + (of text.equivalence = (representation reference) (representation subject))))) + + (def .public hash + (All (_ brand) (Hash (Code brand))) + (implementation + (def equivalence ..equivalence) + (def hash (|>> representation (of text.hash hash))))) + + (with_template [<type> <brand> <super>+] + [(nominal.def .public (<brand> brand) Any) + (`` (type .public <type> (|> Any <brand> (,, (template.spliced <super>+)))))] + + [Expression Expression' [Code]] + ) + + (with_template [<type> <brand> <super>+] + [(nominal.def .public <brand> Any) + (`` (type .public <type> (|> <brand> (,, (template.spliced <super>+)))))] + + [Var Var' [Expression' Code]] + [Computation Computation' [Expression' Code]] + ) + + (type .public Arguments + (Record + [#mandatory (List Var) + #rest (Maybe Var)])) + + (def .public manual + (-> Text Code) + (|>> abstraction)) + + (def .public code + (-> (Code Any) Text) + (|>> representation)) + + (def .public var + (-> Text Var) + (|>> abstraction)) + + (def (arguments [mandatory rest]) + (-> Arguments (Code Any)) + (.when rest + {.#Some rest} + (.when mandatory + {.#End} + rest + + _ + (|> (format " . " (representation rest)) + (format (|> mandatory + (list#each ..code) + (text.interposed " "))) + (text.enclosed ["(" ")"]) + abstraction)) + + {.#None} + (|> mandatory + (list#each ..code) + (text.interposed " ") + (text.enclosed ["(" ")"]) + abstraction))) + + (def .public nil + Computation + (abstraction "'()")) + + (def .public bool + (-> Bit Computation) + (|>> (pipe.when + #0 "#f" + #1 "#t") + abstraction)) + + (def .public int + (-> Int Computation) + (|>> %.int abstraction)) + + (def .public float + (-> Frac Computation) + (|>> (pipe.cond [(f.= f.positive_infinity)] + [(pipe.new "+inf.0" [])] + + [(f.= f.negative_infinity)] + [(pipe.new "-inf.0" [])] + + [f.not_a_number?] + [(pipe.new "+nan.0" [])] + + ... else + [%.frac]) + abstraction)) + + (def .public positive_infinity Computation (..float f.positive_infinity)) + (def .public negative_infinity Computation (..float f.negative_infinity)) + (def .public not_a_number Computation (..float f.not_a_number)) + + (def safe + (-> Text Text) + (`` (|>> (,, (with_template [<find> <replace>] + [(text.replaced <find> <replace>)] + + ["\" "\\"] + ["|" "\|"] + [text.alarm "\a"] + [text.back_space "\b"] + [text.tab "\t"] + [text.new_line "\n"] + [text.carriage_return "\r"] + [text.double_quote (format "\" text.double_quote)] + )) + ))) + + (def .public string + (-> Text Computation) + (|>> ..safe %.text abstraction)) + + (def .public symbol + (-> Text Computation) + (|>> (format "'") abstraction)) + + (def form + (-> (List (Code Any)) Code) + (.let [nested_new_line (format \n+ text.tab)] + (|>> (pipe.when + {.#End} + (abstraction "()") + + {.#Item head tail} + (|> tail + (list#each (|>> representation ..nested)) + {.#Item (representation head)} + (text.interposed nested_new_line) + (text.enclosed ["(" ")"]) + abstraction))))) + + (def .public (apply args func) + (-> (List Expression) Expression Computation) + (..form {.#Item func args})) + + (with_template [<name> <function>] + [(def .public (<name> members) + (-> (List Expression) Computation) + (..apply members (..var <function>)))] + + [vector/* "vector"] + [list/* "list"] + ) + + (def .public apply/0 + (-> Expression Computation) + (..apply (list))) + + (with_template [<lux_name> <scheme_name>] + [(def .public <lux_name> + (apply/0 (..var <scheme_name>)))] + + [newline/0 "newline"] + ) + + (with_template [<apply> <arg>+ <type>+ <function>+] + [(`` (def .public (<apply> procedure) + (-> Expression (,, (template.spliced <type>+)) Computation) + (function (_ (,, (template.spliced <arg>+))) + (..apply (list (,, (template.spliced <arg>+))) procedure)))) + + (`` (with_template [<definition> <function>] + [(def .public <definition> (<apply> (..var <function>)))] + + (,, (template.spliced <function>+))))] + + [apply/1 [_0] [Expression] + [[exact/1 "exact"] + [integer->char/1 "integer->char"] + [char->integer/1 "char->integer"] + [number->string/1 "number->string"] + [string->number/1 "string->number"] + [floor/1 "floor"] + [truncate/1 "truncate"] + [string/1 "string"] + [string?/1 "string?"] + [length/1 "length"] + [values/1 "values"] + [null?/1 "null?"] + [car/1 "car"] + [cdr/1 "cdr"] + [raise/1 "raise"] + [error_object_message/1 "error-object-message"] + [make_vector/1 "make-vector"] + [vector_length/1 "vector-length"] + [not/1 "not"] + [string_hash/1 "string-hash"] + [reverse/1 "reverse"] + [display/1 "display"] + [exit/1 "exit"] + [string_length/1 "string-length"] + [load_relative/1 "load-relative"]]] + + [apply/2 [_0 _1] [Expression Expression] + [[append/2 "append"] + [cons/2 "cons"] + [make_vector/2 "make-vector"] + ... [vector_ref/2 "vector-ref"] + [list_tail/2 "list-tail"] + [map/2 "map"] + [string_ref/2 "string-ref"] + [string_append/2 "string-append"] + [make_string/2 "make-string"]]] + + [apply/3 [_0 _1 _2] [Expression Expression Expression] + [[substring/3 "substring"] + [vector_set!/3 "vector-set!"] + [string_contains/3 "string-contains"]]] + + [apply/5 [_0 _1 _2 _3 _4] [Expression Expression Expression Expression Expression] + [[vector_copy!/5 "vector-copy!"]]] + ) + + ... TODO: define "vector_ref/2" like a normal apply/2 function. + ... "vector_ref/2" as an 'invoke' is problematic, since it only works + ... in Kawa. + ... However, the way Kawa defines "vector-ref" causes trouble, + ... because it does a runtime type-check which throws an error when + ... it checks against custom values/objects/classes made for + ... JVM<->Scheme interop. + ... There are 2 ways to deal with this: + ... 0. To fork Kawa, and get rid of the type-check so the normal + ... "vector-ref" can be used instead. + ... 1. To carry on, and then, when it's time to compile the compiler + ... itself into Scheme, switch from 'invoke' to normal 'vector-ref'. + ... Either way, the 'invoke' needs to go away. + (def .public (vector_ref/2 vector index) + (-> Expression Expression Computation) + (..form (list (..var "invoke") vector (..symbol "getRaw") index))) + + (with_template [<lux_name> <scheme_name>] + [(def .public (<lux_name> param subject) + (-> Expression Expression Computation) + (..apply/2 (..var <scheme_name>) subject param))] + + [=/2 "="] + [eq?/2 "eq?"] + [eqv?/2 "eqv?"] + [</2 "<"] + [<=/2 "<="] + [>/2 ">"] + [>=/2 ">="] + [string=?/2 "string=?"] + [string<?/2 "string<?"] + [+/2 "+"] + [-/2 "-"] + [//2 "/"] + [*/2 "*"] + [expt/2 "expt"] + [remainder/2 "remainder"] + [quotient/2 "quotient"] + [mod/2 "mod"] + [arithmetic_shift/2 "arithmetic-shift"] + [bitwise_and/2 "bitwise-and"] + [bitwise_ior/2 "bitwise-ior"] + [bitwise_xor/2 "bitwise-xor"] + ) + + (with_template [<lux_name> <scheme_name>] + [(def .public <lux_name> + (-> (List Expression) Computation) + (|>> (list.partial (..var <scheme_name>)) ..form))] + + [or "or"] + [and "and"] + ) + + (with_template [<lux_name> <scheme_name> <var> <pre>] + [(def .public (<lux_name> bindings body) + (-> (List [<var> Expression]) Expression Computation) + (..form (list (..var <scheme_name>) + (|> bindings + (list#each (function (_ [binding/name binding/value]) + (..form (list (|> binding/name <pre>) + binding/value)))) + ..form) + body)))] + + [let "let" Var (<|)] + [let* "let*" Var (<|)] + [letrec "letrec" Var (<|)] + [let_values "let-values" Arguments ..arguments] + [let*_values "let*-values" Arguments ..arguments] + [letrec_values "letrec-values" Arguments ..arguments] + ) + + (def .public (if test then else) + (-> Expression Expression Expression Computation) + (..form (list (..var "if") test then else))) + + (def .public (when test then) + (-> Expression Expression Computation) + (..form (list (..var "when") test then))) + + (def .public (lambda arguments body) + (-> Arguments Expression Computation) + (..form (list (..var "lambda") + (..arguments arguments) + body))) + + (def .public (define_function name arguments body) + (-> Var Arguments Expression Computation) + (..form (list (..var "define") + (|> arguments + (revised #mandatory (|>> {.#Item name})) + ..arguments) + body))) + + (def .public (define_constant name value) + (-> Var Expression Computation) + (..form (list (..var "define") name value))) + + (def .public begin + (-> (List Expression) Computation) + (|>> {.#Item (..var "begin")} ..form)) + + (def .public (set! name value) + (-> Var Expression Computation) + (..form (list (..var "set!") name value))) + + (def .public (with_exception_handler handler body) + (-> Expression Expression Computation) + (..form (list (..var "with-exception-handler") handler body))) + + (def .public (call_with_current_continuation body) + (-> Expression Computation) + (..form (list (..var "call-with-current-continuation") body))) + + (def .public (guard variable clauses else body) + (-> Var (List [Expression Expression]) (Maybe Expression) Expression Computation) + (..form (list (..var "guard") + (..form (|> (.when else + {.#None} + (list) + + {.#Some else} + (list (..form (list (..var "else") else)))) + (list#composite (list#each (function (_ [when then]) + (..form (list when then))) + clauses)) + (list.partial variable))) + body))) + ) |