diff options
Diffstat (limited to 'stdlib/source/library/lux/target/scheme.lux')
| -rw-r--r-- | stdlib/source/library/lux/target/scheme.lux | 698 |
1 files changed, 349 insertions, 349 deletions
diff --git a/stdlib/source/library/lux/target/scheme.lux b/stdlib/source/library/lux/target/scheme.lux index 390a43867..692e903bc 100644 --- a/stdlib/source/library/lux/target/scheme.lux +++ b/stdlib/source/library/lux/target/scheme.lux @@ -29,353 +29,353 @@ (abstract: .public (Code k) Text - [(implementation: .public equivalence - (All (_ brand) (Equivalence (Code brand))) - - (def: (= reference subject) - (\ text.equivalence = (:representation reference) (:representation subject)))) - - (implementation: .public hash - (All (_ brand) (Hash (Code brand))) - - (def: &equivalence ..equivalence) - (def: hash (|>> :representation (\ text.hash hash)))) - - (template [<type> <brand> <super>+] - [(abstract: .public (<brand> brand) Any []) - (`` (type: .public <type> (|> Any <brand> (~~ (template.spliced <super>+)))))] - - [Expression Expression' [Code]] - ) - - (template [<type> <brand> <super>+] - [(abstract: .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)) - (case rest - {#.Some rest} - (case 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) - (|>> (case> #0 "#f" - #1 "#t") - :abstraction)) - - (def: .public int - (-> Int Computation) - (|>> %.int :abstraction)) - - (def: .public float - (-> Frac Computation) - (|>> (cond> [(f.= f.positive_infinity)] - [(new> "+inf.0" [])] - - [(f.= f.negative_infinity)] - [(new> "-inf.0" [])] - - [f.not_a_number?] - [(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) - (`` (|>> (~~ (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 text.new_line text.tab)] - (|>> (case> #.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})) - - (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))) - - (template [<lux_name> <scheme_name>] - [(def: .public <lux_name> - (apply/0 (..var <scheme_name>)))] - - [newline/0 "newline"] - ) - - (template [<apply> <arg>+ <type>+ <function>+] - [(`` (def: .public (<apply> procedure) - (-> Expression (~~ (template.spliced <type>+)) Computation) - (function (_ (~~ (template.spliced <arg>+))) - (..apply/* (list (~~ (template.spliced <arg>+))) procedure)))) - - (`` (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))) - - (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"] - ) - - (template [<lux_name> <scheme_name>] - [(def: .public <lux_name> - (-> (List Expression) Computation) - (|>> (list& (..var <scheme_name>)) ..form))] - - [or "or"] - [and "and"] - ) - - (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 (|> (case else - #.None - (list) - - {#.Some else} - (list (..form (list (..var "else") else)))) - (list\composite (list\each (function (_ [when then]) - (..form (list when then))) - clauses)) - (list& variable))) - body)))] + (implementation: .public equivalence + (All (_ brand) (Equivalence (Code brand))) + + (def: (= reference subject) + (\ text.equivalence = (:representation reference) (:representation subject)))) + + (implementation: .public hash + (All (_ brand) (Hash (Code brand))) + + (def: &equivalence ..equivalence) + (def: hash (|>> :representation (\ text.hash hash)))) + + (template [<type> <brand> <super>+] + [(abstract: .public (<brand> brand) Any) + (`` (type: .public <type> (|> Any <brand> (~~ (template.spliced <super>+)))))] + + [Expression Expression' [Code]] + ) + + (template [<type> <brand> <super>+] + [(abstract: .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)) + (case rest + {#.Some rest} + (case 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) + (|>> (case> #0 "#f" + #1 "#t") + :abstraction)) + + (def: .public int + (-> Int Computation) + (|>> %.int :abstraction)) + + (def: .public float + (-> Frac Computation) + (|>> (cond> [(f.= f.positive_infinity)] + [(new> "+inf.0" [])] + + [(f.= f.negative_infinity)] + [(new> "-inf.0" [])] + + [f.not_a_number?] + [(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) + (`` (|>> (~~ (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 text.new_line text.tab)] + (|>> (case> #.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})) + + (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))) + + (template [<lux_name> <scheme_name>] + [(def: .public <lux_name> + (apply/0 (..var <scheme_name>)))] + + [newline/0 "newline"] + ) + + (template [<apply> <arg>+ <type>+ <function>+] + [(`` (def: .public (<apply> procedure) + (-> Expression (~~ (template.spliced <type>+)) Computation) + (function (_ (~~ (template.spliced <arg>+))) + (..apply/* (list (~~ (template.spliced <arg>+))) procedure)))) + + (`` (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))) + + (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"] + ) + + (template [<lux_name> <scheme_name>] + [(def: .public <lux_name> + (-> (List Expression) Computation) + (|>> (list& (..var <scheme_name>)) ..form))] + + [or "or"] + [and "and"] + ) + + (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 (|> (case else + #.None + (list) + + {#.Some else} + (list (..form (list (..var "else") else)))) + (list\composite (list\each (function (_ [when then]) + (..form (list when then))) + clauses)) + (list& variable))) + body))) ) |