diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/library/lux/ffi.old.lux | 422 |
1 files changed, 221 insertions, 201 deletions
diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux index 951d58f18..8aa106b28 100644 --- a/stdlib/source/library/lux/ffi.old.lux +++ b/stdlib/source/library/lux/ffi.old.lux @@ -21,7 +21,7 @@ ["[0]" array (.only Array)] ["[0]" list (.open: "[1]#[0]" monad mix monoid)]]] ["[0]" macro (.only with_symbols) - [syntax (.only syntax:)] + [syntax (.only syntax)] ["^" pattern] ["[0]" code] ["[0]" template]] @@ -1198,117 +1198,126 @@ [#super_class_name "java/lang/Object" #super_class_params (list)]) -(syntax: .public (class: [im inheritance_modifier^ - class_decl ..class_decl^ - .let [full_class_name (product.left class_decl)] - .let [class_vars (product.right class_decl)] - super (<>.else object_super_class - (..super_class_decl^ class_vars)) - interfaces (<>.else (list) - (<code>.tuple (<>.some (..super_class_decl^ class_vars)))) - annotations ..annotations^ - fields (<>.some (..field_decl^ class_vars)) - methods (<>.some (..method_def^ class_vars))]) - (do meta.monad - [current_module meta.current_module_name - .let [fully_qualified_class_name (format (safe current_module) "." full_class_name) - field_parsers (list#each (field_parser fully_qualified_class_name) fields) - method_parsers (list#each (method_parser (product.right class_decl) fully_qualified_class_name) methods) - replacer (parser_replacer (list#mix <>.either - (<>.failure "") - (list#composite field_parsers method_parsers))) - def_code (format "jvm class:" - (spaced (list (class_decl$ class_decl) - (super_class_decl$ super) - (with_brackets (spaced (list#each super_class_decl$ interfaces))) - (inheritance_modifier$ im) - (with_brackets (spaced (list#each annotation$ annotations))) - (with_brackets (spaced (list#each field_decl$ fields))) - (with_brackets (spaced (list#each (method_def$ replacer super) methods))))))]] - (in (list (` ((~ (code.text def_code)))))))) - -(syntax: .public (interface: [class_decl ..class_decl^ - .let [class_vars (product.right class_decl)] - supers (<>.else (list) - (<code>.tuple (<>.some (..super_class_decl^ class_vars)))) - annotations ..annotations^ - members (<>.some (..method_decl^ class_vars))]) - (let [def_code (format "jvm interface:" - (spaced (list (class_decl$ class_decl) - (with_brackets (spaced (list#each super_class_decl$ supers))) - (with_brackets (spaced (list#each annotation$ annotations))) - (spaced (list#each method_decl$ members)))))] - (in (list (` ((~ (code.text def_code)))))))) - -(syntax: .public (object [class_vars (<code>.tuple (<>.some ..type_param^)) - super (<>.else object_super_class - (..super_class_decl^ class_vars)) - interfaces (<>.else (list) - (<code>.tuple (<>.some (..super_class_decl^ class_vars)))) - constructor_args (..constructor_args^ class_vars) - methods (<>.some ..overriden_method_def^)]) - (let [def_code (format "jvm anon-class:" - (spaced (list (super_class_decl$ super) - (with_brackets (spaced (list#each super_class_decl$ interfaces))) - (with_brackets (spaced (list#each constructor_arg$ constructor_args))) - (with_brackets (spaced (list#each (method_def$ function.identity super) methods))))))] - (in (list (` ((~ (code.text def_code)))))))) - -(syntax: .public (null []) - (in (list (` ("jvm object null"))))) +(def: .public class: + (syntax (_ [im inheritance_modifier^ + class_decl ..class_decl^ + .let [full_class_name (product.left class_decl)] + .let [class_vars (product.right class_decl)] + super (<>.else object_super_class + (..super_class_decl^ class_vars)) + interfaces (<>.else (list) + (<code>.tuple (<>.some (..super_class_decl^ class_vars)))) + annotations ..annotations^ + fields (<>.some (..field_decl^ class_vars)) + methods (<>.some (..method_def^ class_vars))]) + (do meta.monad + [current_module meta.current_module_name + .let [fully_qualified_class_name (format (safe current_module) "." full_class_name) + field_parsers (list#each (field_parser fully_qualified_class_name) fields) + method_parsers (list#each (method_parser (product.right class_decl) fully_qualified_class_name) methods) + replacer (parser_replacer (list#mix <>.either + (<>.failure "") + (list#composite field_parsers method_parsers))) + def_code (format "jvm class:" + (spaced (list (class_decl$ class_decl) + (super_class_decl$ super) + (with_brackets (spaced (list#each super_class_decl$ interfaces))) + (inheritance_modifier$ im) + (with_brackets (spaced (list#each annotation$ annotations))) + (with_brackets (spaced (list#each field_decl$ fields))) + (with_brackets (spaced (list#each (method_def$ replacer super) methods))))))]] + (in (list (` ((~ (code.text def_code))))))))) + +(def: .public interface: + (syntax (_ [class_decl ..class_decl^ + .let [class_vars (product.right class_decl)] + supers (<>.else (list) + (<code>.tuple (<>.some (..super_class_decl^ class_vars)))) + annotations ..annotations^ + members (<>.some (..method_decl^ class_vars))]) + (let [def_code (format "jvm interface:" + (spaced (list (class_decl$ class_decl) + (with_brackets (spaced (list#each super_class_decl$ supers))) + (with_brackets (spaced (list#each annotation$ annotations))) + (spaced (list#each method_decl$ members)))))] + (in (list (` ((~ (code.text def_code))))))))) + +(def: .public object + (syntax (_ [class_vars (<code>.tuple (<>.some ..type_param^)) + super (<>.else object_super_class + (..super_class_decl^ class_vars)) + interfaces (<>.else (list) + (<code>.tuple (<>.some (..super_class_decl^ class_vars)))) + constructor_args (..constructor_args^ class_vars) + methods (<>.some ..overriden_method_def^)]) + (let [def_code (format "jvm anon-class:" + (spaced (list (super_class_decl$ super) + (with_brackets (spaced (list#each super_class_decl$ interfaces))) + (with_brackets (spaced (list#each constructor_arg$ constructor_args))) + (with_brackets (spaced (list#each (method_def$ function.identity super) methods))))))] + (in (list (` ((~ (code.text def_code))))))))) + +(def: .public null + (syntax (_ []) + (in (list (` ("jvm object null")))))) (def: .public (null? obj) (-> (Primitive "java.lang.Object") Bit) ("jvm object null?" obj)) -(syntax: .public (??? [expr <code>.any]) - (with_symbols [g!temp] - (in (list (` (let [(~ g!temp) (~ expr)] - (if ("jvm object null?" (~ g!temp)) - {.#None} - {.#Some (~ g!temp)}))))))) - -(syntax: .public (!!! [expr <code>.any]) - (with_symbols [g!value] - (in (list (` (.case (~ expr) - {.#Some (~ g!value)} - (~ g!value) - - {.#None} - ("jvm object null"))))))) - -(syntax: .public (as [class (..generic_type^ (list)) - unchecked (<>.maybe <code>.any)]) - (with_symbols [g!_ g!unchecked] - (let [class_name (simple_class$ (list) class) - class_type (` (.Primitive (~ (code.text class_name)))) - check_type (` (.Maybe (~ class_type))) - check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked)) - {.#Some (.as (~ class_type) - (~ g!unchecked))} - {.#None}))] - (case unchecked - {.#Some unchecked} - (in (list (` (.is (~ check_type) - (let [(~ g!unchecked) (~ unchecked)] - (~ check_code)))))) +(def: .public ??? + (syntax (_ [expr <code>.any]) + (with_symbols [g!temp] + (in (list (` (let [(~ g!temp) (~ expr)] + (if ("jvm object null?" (~ g!temp)) + {.#None} + {.#Some (~ g!temp)})))))))) + +(def: .public !!! + (syntax (_ [expr <code>.any]) + (with_symbols [g!value] + (in (list (` (.case (~ expr) + {.#Some (~ g!value)} + (~ g!value) - {.#None} - (in (list (` (.is (-> (Primitive "java.lang.Object") (~ check_type)) - (function ((~ g!_) (~ g!unchecked)) - (~ check_code)))))) - )))) - -(syntax: .public (synchronized [lock <code>.any - body <code>.any]) - (in (list (` ("jvm object synchronized" (~ lock) (~ body)))))) - -(syntax: .public (do_to [obj <code>.any - methods (<>.some partial_call^)]) - (with_symbols [g!obj] - (in (list (` (let [(~ g!obj) (~ obj)] - (exec (~+ (list#each (complete_call$ g!obj) methods)) - (~ g!obj)))))))) + {.#None} + ("jvm object null")))))))) + +(def: .public as + (syntax (_ [class (..generic_type^ (list)) + unchecked (<>.maybe <code>.any)]) + (with_symbols [g!_ g!unchecked] + (let [class_name (simple_class$ (list) class) + class_type (` (.Primitive (~ (code.text class_name)))) + check_type (` (.Maybe (~ class_type))) + check_code (` (if ((~ (code.text (format "jvm instanceof" ":" class_name))) (~ g!unchecked)) + {.#Some (.as (~ class_type) + (~ g!unchecked))} + {.#None}))] + (case unchecked + {.#Some unchecked} + (in (list (` (.is (~ check_type) + (let [(~ g!unchecked) (~ unchecked)] + (~ check_code)))))) + + {.#None} + (in (list (` (.is (-> (Primitive "java.lang.Object") (~ check_type)) + (function ((~ g!_) (~ g!unchecked)) + (~ check_code)))))) + ))))) + +(def: .public synchronized + (syntax (_ [lock <code>.any + body <code>.any]) + (in (list (` ("jvm object synchronized" (~ lock) (~ body))))))) + +(def: .public do_to + (syntax (_ [obj <code>.any + methods (<>.some partial_call^)]) + (with_symbols [g!obj] + (in (list (` (let [(~ g!obj) (~ obj)] + (exec (~+ (list#each (complete_call$ g!obj) methods)) + (~ g!obj))))))))) (def: (class_import$ [full_name params]) (-> Class_Declaration Code) @@ -1486,8 +1495,9 @@ (decorate_return_maybe class member) (decorate_return_try member) (decorate_return_io member))]] - (in (list (` ((~! syntax:) ((~ def_name) [(~+ (syntax_inputs (list#each product.right arg_function_inputs)))]) - ((~' in) (.list (.` (~ jvm_interop))))))))) + (in (list (` (def: (~ def_name) + ((~! syntax) ((~ def_name) [(~+ (syntax_inputs (list#each product.right arg_function_inputs)))]) + ((~' in) (.list (.` (~ jvm_interop)))))))))) {#MethodDecl [commons method]} (with_symbols [g!obj] @@ -1519,9 +1529,10 @@ (decorate_return_maybe class member) (decorate_return_try member) (decorate_return_io member))]] - (in (list (` ((~! syntax:) ((~ def_name) [(~+ (syntax_inputs (list#each product.right arg_function_inputs))) - (~+ (syntax_inputs object_ast))]) - ((~' in) (.list (.` (~ jvm_interop)))))))))) + (in (list (` (def: (~ def_name) + ((~! syntax) ((~ def_name) [(~+ (syntax_inputs (list#each product.right arg_function_inputs))) + (~+ (syntax_inputs object_ast))]) + ((~' in) (.list (.` (~ jvm_interop))))))))))) {#FieldAccessDecl fad} (do meta.monad @@ -1554,8 +1565,9 @@ getter_body (if #import_field_setter? (` ((~! io.io) (~ getter_body))) getter_body)] - (in (` ((~! syntax:) (~ getter_call) - ((~' in) (.list (.` (~ getter_body))))))))) + (in (` (def: (~ getter_name) + ((~! syntax) (~ getter_call) + ((~' in) (.list (.` (~ getter_body)))))))))) setter_interop (.is (Meta (List Code)) (if #import_field_setter? (with_symbols [g!obj g!value] @@ -1574,8 +1586,9 @@ (if #import_field_static? (list) (list (un_quote g!obj))))] - (in (list (` ((~! syntax:) (~ setter_call) - ((~' in) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value)))))))))))) + (in (list (` (def: (~ setter_name) + ((~! syntax) (~ setter_call) + ((~' in) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value))))))))))))) (in (list))))] (in (partial_list getter_interop setter_interop))) ))) @@ -1611,36 +1624,39 @@ (meta.failure (format "Cannot load class: " class_name text.new_line error))))) -(syntax: .public (import [class_decl ..class_decl^ - import_format <code>.text - members (<>.some (..import_member_decl^ (product.right class_decl)))]) - (do [! meta.monad] - [kind (class_kind class_decl) - =members (|> members - (list#each (|>> [import_format])) - (monad.each ! (member_import$ (product.right class_decl) kind class_decl)))] - (in (partial_list (class_import$ class_decl) (list#conjoint =members))))) - -(syntax: .public (array [type (..generic_type^ (list)) - size <code>.any]) - (case type - (^.template [<type> <array_op>] - [(pattern {#GenericClass <type> (list)}) - (in (list (` (<array_op> (~ size)))))]) - (["boolean" "jvm znewarray"] - ["byte" "jvm bnewarray"] - ["short" "jvm snewarray"] - ["int" "jvm inewarray"] - ["long" "jvm lnewarray"] - ["float" "jvm fnewarray"] - ["double" "jvm dnewarray"] - ["char" "jvm cnewarray"]) +(def: .public import + (syntax (_ [class_decl ..class_decl^ + import_format <code>.text + members (<>.some (..import_member_decl^ (product.right class_decl)))]) + (do [! meta.monad] + [kind (class_kind class_decl) + =members (|> members + (list#each (|>> [import_format])) + (monad.each ! (member_import$ (product.right class_decl) kind class_decl)))] + (in (partial_list (class_import$ class_decl) (list#conjoint =members)))))) + +(def: .public array + (syntax (_ [type (..generic_type^ (list)) + size <code>.any]) + (case type + (^.template [<type> <array_op>] + [(pattern {#GenericClass <type> (list)}) + (in (list (` (<array_op> (~ size)))))]) + (["boolean" "jvm znewarray"] + ["byte" "jvm bnewarray"] + ["short" "jvm snewarray"] + ["int" "jvm inewarray"] + ["long" "jvm lnewarray"] + ["float" "jvm fnewarray"] + ["double" "jvm dnewarray"] + ["char" "jvm cnewarray"]) - _ - (in (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size))))))) + _ + (in (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size)))))))) -(syntax: .public (length [array <code>.any]) - (in (list (` ("jvm arraylength" (~ array)))))) +(def: .public length + (syntax (_ [array <code>.any]) + (in (list (` ("jvm arraylength" (~ array))))))) (def: (type_class_name type) (-> Type (Meta Text)) @@ -1664,68 +1680,72 @@ _ (meta.failure (format "Cannot convert to JvmType: " (type.format type)))))) -(syntax: .public (read! [idx <code>.any - array <code>.any]) - (case array - [_ {.#Symbol array_name}] - (do meta.monad - [array_type (meta.type array_name) - array_jvm_type (type_class_name array_type)] - (case array_jvm_type - (^.template [<type> <array_op>] - [<type> - (in (list (` (<array_op> (~ array) (~ idx)))))]) - (["[Z" "jvm zaload"] - ["[B" "jvm baload"] - ["[S" "jvm saload"] - ["[I" "jvm iaload"] - ["[J" "jvm jaload"] - ["[F" "jvm faload"] - ["[D" "jvm daload"] - ["[C" "jvm caload"]) - - _ - (in (list (` ("jvm aaload" (~ array) (~ idx))))))) +(def: .public read! + (syntax (_ [idx <code>.any + array <code>.any]) + (case array + [_ {.#Symbol array_name}] + (do meta.monad + [array_type (meta.type array_name) + array_jvm_type (type_class_name array_type)] + (case array_jvm_type + (^.template [<type> <array_op>] + [<type> + (in (list (` (<array_op> (~ array) (~ idx)))))]) + (["[Z" "jvm zaload"] + ["[B" "jvm baload"] + ["[S" "jvm saload"] + ["[I" "jvm iaload"] + ["[J" "jvm jaload"] + ["[F" "jvm faload"] + ["[D" "jvm daload"] + ["[C" "jvm caload"]) + + _ + (in (list (` ("jvm aaload" (~ array) (~ idx))))))) - _ - (with_symbols [g!array] - (in (list (` (let [(~ g!array) (~ array)] - (..read! (~ idx) (~ g!array))))))))) - -(syntax: .public (write! [idx <code>.any - value <code>.any - array <code>.any]) - (case array - [_ {.#Symbol array_name}] - (do meta.monad - [array_type (meta.type array_name) - array_jvm_type (type_class_name array_type)] - (case array_jvm_type - (^.template [<type> <array_op>] - [<type> - (in (list (` (<array_op> (~ array) (~ idx) (~ value)))))]) - (["[Z" "jvm zastore"] - ["[B" "jvm bastore"] - ["[S" "jvm sastore"] - ["[I" "jvm iastore"] - ["[J" "jvm jastore"] - ["[F" "jvm fastore"] - ["[D" "jvm dastore"] - ["[C" "jvm castore"]) - - _ - (in (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) + _ + (with_symbols [g!array] + (in (list (` (let [(~ g!array) (~ array)] + (..read! (~ idx) (~ g!array)))))))))) + +(def: .public write! + (syntax (_ [idx <code>.any + value <code>.any + array <code>.any]) + (case array + [_ {.#Symbol array_name}] + (do meta.monad + [array_type (meta.type array_name) + array_jvm_type (type_class_name array_type)] + (case array_jvm_type + (^.template [<type> <array_op>] + [<type> + (in (list (` (<array_op> (~ array) (~ idx) (~ value)))))]) + (["[Z" "jvm zastore"] + ["[B" "jvm bastore"] + ["[S" "jvm sastore"] + ["[I" "jvm iastore"] + ["[J" "jvm jastore"] + ["[F" "jvm fastore"] + ["[D" "jvm dastore"] + ["[C" "jvm castore"]) + + _ + (in (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) - _ - (with_symbols [g!array] - (in (list (` (let [(~ g!array) (~ array)] - (..write! (~ idx) (~ value) (~ g!array))))))))) + _ + (with_symbols [g!array] + (in (list (` (let [(~ g!array) (~ array)] + (..write! (~ idx) (~ value) (~ g!array)))))))))) -(syntax: .public (class_for [type (..generic_type^ (list))]) - (in (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type)))))))) +(def: .public class_for + (syntax (_ [type (..generic_type^ (list))]) + (in (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type))))))))) -(syntax: .public (type [type (..generic_type^ (list))]) - (in (list (..class_type {#ManualPrM} (list) type)))) +(def: .public type + (syntax (_ [type (..generic_type^ (list))]) + (in (list (..class_type {#ManualPrM} (list) type))))) (template: .public (is type term) [(.as type term)]) |