aboutsummaryrefslogtreecommitdiff
path: root/new-luxc/source/luxc/generator/procedure
diff options
context:
space:
mode:
authorEduardo Julian2017-11-01 00:51:45 -0400
committerEduardo Julian2017-11-01 00:51:45 -0400
commit012f6bd41e527479dddbccbdab10daa78fd9a0fd (patch)
tree621f344a09acd52736f343d94582b3f1a2f0c5f9 /new-luxc/source/luxc/generator/procedure
parent71d7a4c7206155e09f3e1e1d8699561ea6967382 (diff)
- Re-organized code-generation, and re-named it "translation".
Diffstat (limited to 'new-luxc/source/luxc/generator/procedure')
-rw-r--r--new-luxc/source/luxc/generator/procedure/common.jvm.lux708
-rw-r--r--new-luxc/source/luxc/generator/procedure/host.jvm.lux763
2 files changed, 0 insertions, 1471 deletions
diff --git a/new-luxc/source/luxc/generator/procedure/common.jvm.lux b/new-luxc/source/luxc/generator/procedure/common.jvm.lux
deleted file mode 100644
index dffbcb64e..000000000
--- a/new-luxc/source/luxc/generator/procedure/common.jvm.lux
+++ /dev/null
@@ -1,708 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do])
- (data [text]
- text/format
- (coll [list "list/" Functor<List>]
- [dict #+ Dict]))
- [meta #+ with-gensyms]
- (meta [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- ["ls" synthesis])
- (generator ["&;" common]
- ["&;" runtime])))
-
-(host;import java.lang.Long
- (#static MIN_VALUE Long)
- (#static MAX_VALUE Long))
-
-(host;import java.lang.Double
- (#static MIN_VALUE Double)
- (#static MAX_VALUE Double)
- (#static NaN Double)
- (#static POSITIVE_INFINITY Double)
- (#static NEGATIVE_INFINITY Double))
-
-## [Types]
-(type: #export Generator
- (-> ls;Synthesis (Meta $;Inst)))
-
-(type: #export Proc
- (-> Generator (List ls;Synthesis) (Meta $;Inst)))
-
-(type: #export Bundle
- (Dict Text Proc))
-
-(syntax: (Vector [size s;nat] elemT)
- (wrap (list (` [(~@ (list;repeat size elemT))]))))
-
-(type: #export Nullary (-> (Vector +0 $;Inst) $;Inst))
-(type: #export Unary (-> (Vector +1 $;Inst) $;Inst))
-(type: #export Binary (-> (Vector +2 $;Inst) $;Inst))
-(type: #export Trinary (-> (Vector +3 $;Inst) $;Inst))
-
-## [Utils]
-(def: $Object $;Type ($t;class "java.lang.Object" (list)))
-(def: $Object-Array $;Type ($t;array +1 $Object))
-(def: $String $;Type ($t;class "java.lang.String" (list)))
-(def: $CharSequence $;Type ($t;class "java.lang.CharSequence" (list)))
-(def: $Function $;Type ($t;class hostL;function-class (list)))
-
-(def: #export (install name unnamed)
- (-> Text (-> Text Proc)
- (-> Bundle Bundle))
- (dict;put name (unnamed name)))
-
-(def: #export (prefix prefix bundle)
- (-> Text Bundle Bundle)
- (|> bundle
- dict;entries
- (list/map (function [[key val]] [(format prefix " " key) val]))
- (dict;from-list text;Hash<Text>)))
-
-(def: (wrong-arity proc expected actual)
- (-> Text Nat Nat Text)
- (format "Wrong number of arguments for " (%t proc) "\n"
- "Expected: " (|> expected nat-to-int %i) "\n"
- " Actual: " (|> actual nat-to-int %i)))
-
-(syntax: (arity: [name s;local-symbol] [arity s;nat])
- (with-gensyms [g!proc g!name g!generate g!inputs]
- (do @
- [g!input+ (monad;seq @ (list;repeat arity (meta;gensym "input")))]
- (wrap (list (` (def: #export ((~ (code;local-symbol name)) (~ g!proc))
- (-> (-> (;;Vector (~ (code;nat arity)) $;Inst) $;Inst)
- (-> Text ;;Proc))
- (function [(~ g!name)]
- (function [(~ g!generate) (~ g!inputs)]
- (case (~ g!inputs)
- (^ (list (~@ g!input+)))
- (do meta;Monad<Meta>
- [(~@ (|> g!input+
- (list/map (function [g!input]
- (list g!input (` ((~ g!generate) (~ g!input))))))
- list;concat))]
- ((~' wrap) ((~ g!proc) [(~@ g!input+)])))
-
- (~' _)
- (meta;fail (wrong-arity (~ g!name) +1 (list;size (~ g!inputs))))))))))))))
-
-(arity: nullary +0)
-(arity: unary +1)
-(arity: binary +2)
-(arity: trinary +3)
-
-## [Instructions]
-(def: lux-intI $;Inst (|>. $i;I2L ($i;wrap #$;Long)))
-(def: jvm-intI $;Inst (|>. ($i;unwrap #$;Long) $i;L2I))
-
-(def: (array-writeI arrayI idxI elemI)
- (-> $;Inst $;Inst $;Inst
- $;Inst)
- (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array))
- $i;DUP
- idxI jvm-intI
- elemI
- $i;AASTORE))
-
-(def: (predicateI tester)
- (-> (-> $;Label $;Inst)
- $;Inst)
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. (tester @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end)
- )))
-
-## [Procedures]
-## [[Lux]]
-(def: (lux//is [leftI rightI])
- Binary
- (|>. leftI
- rightI
- (predicateI $i;IF_ACMPEQ)))
-
-(def: try-method
- $;Method
- ($t;method (list $Function) (#;Some $Object-Array) (list)))
-(def: (lux//try riskyI)
- Unary
- (|>. riskyI
- ($i;CHECKCAST hostL;function-class)
- ($i;INVOKESTATIC hostL;runtime-class "try" try-method false)))
-
-(def: (lux//noop valueI)
- Unary
- valueI)
-
-## [[Bits]]
-(do-template [<name> <op>]
- [(def: (<name> [inputI maskI])
- Binary
- (|>. inputI ($i;unwrap #$;Long)
- maskI ($i;unwrap #$;Long)
- <op> ($i;wrap #$;Long)))]
-
- [bit//and $i;LAND]
- [bit//or $i;LOR]
- [bit//xor $i;LXOR]
- )
-
-(def: (bit//count inputI)
- Unary
- (|>. inputI ($i;unwrap #$;Long)
- ($i;INVOKESTATIC "java.lang.Long" "bitCount" ($t;method (list $t;long) (#;Some $t;int) (list)) false)
- lux-intI))
-
-(do-template [<name> <op>]
- [(def: (<name> [inputI shiftI])
- Binary
- (|>. inputI ($i;unwrap #$;Long)
- shiftI jvm-intI
- <op>
- ($i;wrap #$;Long)))]
-
- [bit//shift-left $i;LSHL]
- [bit//shift-right $i;LSHR]
- [bit//unsigned-shift-right $i;LUSHR]
- )
-
-## [[Arrays]]
-(def: (array//new lengthI)
- Unary
- (|>. lengthI jvm-intI ($i;ANEWARRAY ($t;descriptor $Object))))
-
-(def: (array//get [arrayI idxI])
- Binary
- (<| $i;with-label (function [@is-null])
- $i;with-label (function [@end])
- (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array))
- idxI jvm-intI
- $i;AALOAD
- $i;DUP
- ($i;IFNULL @is-null)
- &runtime;someI
- ($i;GOTO @end)
- ($i;label @is-null)
- $i;POP
- &runtime;noneI
- ($i;label @end))))
-
-(def: (array//put [arrayI idxI elemI])
- Trinary
- (array-writeI arrayI idxI elemI))
-
-(def: (array//remove [arrayI idxI])
- Binary
- (array-writeI arrayI idxI $i;NULL))
-
-(def: (array//size arrayI)
- Unary
- (|>. arrayI ($i;CHECKCAST ($t;descriptor $Object-Array))
- $i;ARRAYLENGTH
- lux-intI))
-
-## [[Numbers]]
-(def: nat-method
- $;Method
- ($t;method (list $t;long $t;long) (#;Some $t;long) (list)))
-
-(def: deg-method $;Method nat-method)
-
-(def: compare-nat-method
- $;Method
- ($t;method (list $t;long $t;long) (#;Some $t;int) (list)))
-
-(do-template [<name> <const> <wrapper>]
- [(def: (<name> _)
- Nullary
- (|>. <const> <wrapper>))]
-
- [nat//min ($i;long 0) ($i;wrap #$;Long)]
- [nat//max ($i;long -1) ($i;wrap #$;Long)]
-
- [int//min ($i;long Long.MIN_VALUE) ($i;wrap #$;Long)]
- [int//max ($i;long Long.MAX_VALUE) ($i;wrap #$;Long)]
-
- [frac//smallest ($i;double Double.MIN_VALUE) ($i;wrap #$;Double)]
- [frac//min ($i;double (f.* -1.0 Double.MAX_VALUE)) ($i;wrap #$;Double)]
- [frac//max ($i;double Double.MAX_VALUE) ($i;wrap #$;Double)]
- [frac//not-a-number ($i;double Double.NaN) ($i;wrap #$;Double)]
- [frac//positive-infinity ($i;double Double.POSITIVE_INFINITY) ($i;wrap #$;Double)]
- [frac//negative-infinity ($i;double Double.NEGATIVE_INFINITY) ($i;wrap #$;Double)]
-
- [deg//min ($i;long 0) ($i;wrap #$;Long)]
- [deg//max ($i;long -1) ($i;wrap #$;Long)]
- )
-
-(do-template [<name> <unwrap> <wrap> <op>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <unwrap>
- paramI <unwrap>
- <op>
- <wrap>))]
-
- [int//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
- [int//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [int//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
- [int//div ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
- [int//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LREM]
-
- [nat//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
- [nat//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [nat//mul ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
- [nat//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "div_nat" nat-method false)]
- [nat//rem ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "rem_nat" nat-method false)]
-
- [frac//add ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DADD]
- [frac//sub ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DSUB]
- [frac//mul ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DMUL]
- [frac//div ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DDIV]
- [frac//rem ($i;unwrap #$;Double) ($i;wrap #$;Double) $i;DREM]
-
- [deg//add ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LADD]
- [deg//sub ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [deg//mul ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "mul_deg" deg-method false)]
- [deg//div ($i;unwrap #$;Long) ($i;wrap #$;Long)
- ($i;INVOKESTATIC hostL;runtime-class "div_deg" deg-method false)]
- [deg//rem ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LSUB]
- [deg//scale ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LMUL]
- [deg//reciprocal ($i;unwrap #$;Long) ($i;wrap #$;Long) $i;LDIV]
- )
-
-(do-template [<eq> <lt> <unwrap> <cmp>]
- [(do-template [<name> <reference>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <unwrap>
- paramI <unwrap>
- <cmp>
- ($i;int <reference>)
- (predicateI $i;IF_ICMPEQ)))]
- [<eq> 0]
- [<lt> -1])]
-
- [nat//eq nat//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)]
- [int//eq int//lt ($i;unwrap #$;Long) $i;LCMP]
- [frac//eq frac//lt ($i;unwrap #$;Double) $i;DCMPG]
- [deg//eq deg//lt ($i;unwrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "compare_nat" compare-nat-method false)]
- )
-
-(do-template [<name> <prepare> <transform>]
- [(def: (<name> inputI)
- Unary
- (|>. inputI <prepare> <transform>))]
-
- [nat//to-int id id]
- [nat//to-char ($i;unwrap #$;Long)
- (<| ($i;INVOKESTATIC "java.lang.Character" "toString" ($t;method (list $t;char) (#;Some $String) (list)) false)
- $i;I2C $i;L2I)]
-
- [int//to-nat id id]
- [int//to-frac ($i;unwrap #$;Long) (<| ($i;wrap #$;Double) $i;L2D)]
-
- [frac//to-int ($i;unwrap #$;Double) (<| ($i;wrap #$;Long) $i;D2L)]
- [frac//to-deg ($i;unwrap #$;Double)
- (<| ($i;wrap #$;Long) ($i;INVOKESTATIC hostL;runtime-class "frac_to_deg"
- ($t;method (list $t;double) (#;Some $t;long) (list)) false))]
- [frac//encode ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Double" "toString" ($t;method (list $t;double) (#;Some $String) (list)) false)]
- [frac//decode ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESTATIC hostL;runtime-class "decode_frac" ($t;method (list $String) (#;Some $Object-Array) (list)) false)]
-
- [deg//to-frac ($i;unwrap #$;Long)
- (<| ($i;wrap #$;Double) ($i;INVOKESTATIC hostL;runtime-class "deg_to_frac"
- ($t;method (list $t;long) (#;Some $t;double) (list)) false))]
- )
-
-## [[Text]]
-(do-template [<name> <class> <method> <post> <outputT>]
- [(def: (<name> inputI)
- Unary
- (|>. inputI
- ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL <class> <method> ($t;method (list) (#;Some <outputT>) (list)) false)
- <post>))]
-
- [text//size "java.lang.String" "length" lux-intI $t;int]
- [text//hash "java.lang.Object" "hashCode" lux-intI $t;int]
- [text//trim "java.lang.String" "trim" id $String]
- [text//upper-case "java.lang.String" "toUpperCase" id $String]
- [text//lower-case "java.lang.String" "toLowerCase" id $String]
- )
-
-(do-template [<name> <pre-subject> <pre-param> <op> <post>]
- [(def: (<name> [subjectI paramI])
- Binary
- (|>. subjectI <pre-subject>
- paramI <pre-param>
- <op> <post>))]
-
- [text//eq id id
- ($i;INVOKEVIRTUAL "java.lang.Object" "equals" ($t;method (list $Object) (#;Some $t;boolean) (list)) false)
- ($i;wrap #$;Boolean)]
- [text//lt ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.lang.String" "compareTo" ($t;method (list $String) (#;Some $t;int) (list)) false)
- (predicateI $i;IF_ICMPEQ)]
- [text//append ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.lang.String" "concat" ($t;method (list $String) (#;Some $String) (list)) false)
- id]
- [text//contains? ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.lang.String" "contains" ($t;method (list $CharSequence) (#;Some $t;boolean) (list)) false)
- ($i;wrap #$;Boolean)]
- [text//char ($i;CHECKCAST "java.lang.String") jvm-intI
- ($i;INVOKESTATIC hostL;runtime-class "text_char" ($t;method (list $String $t;int) (#;Some $t;int) (list)) false)
- lux-intI]
- )
-
-(do-template [<name> <pre-subject> <pre-param> <pre-extra> <op>]
- [(def: (<name> [subjectI paramI extraI])
- Trinary
- (|>. subjectI <pre-subject>
- paramI <pre-param>
- extraI <pre-extra>
- <op>))]
-
- [text//clip ($i;CHECKCAST "java.lang.String") jvm-intI jvm-intI
- ($i;INVOKESTATIC hostL;runtime-class "text_clip"
- ($t;method (list $String $t;int $t;int) (#;Some $Object-Array) (list)) false)]
- [text//replace ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String") ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.lang.String" "replace" ($t;method (list $CharSequence $CharSequence) (#;Some $String) (list)) false)]
- )
-
-(def: index-method $;Method ($t;method (list $String $t;int) (#;Some $t;int) (list)))
-(do-template [<name> <method>]
- [(def: (<name> [textI partI startI])
- Trinary
- (<| $i;with-label (function [@not-found])
- $i;with-label (function [@end])
- (|>. textI ($i;CHECKCAST "java.lang.String")
- partI ($i;CHECKCAST "java.lang.String")
- startI jvm-intI
- ($i;INVOKEVIRTUAL "java.lang.String" <method> index-method false)
- $i;DUP
- ($i;int -1)
- ($i;IF_ICMPEQ @not-found)
- lux-intI
- &runtime;someI
- ($i;GOTO @end)
- ($i;label @not-found)
- $i;POP
- &runtime;noneI
- ($i;label @end))))]
-
- [text//index "indexOf"]
- [text//last-index "lastIndexOf"]
- )
-
-## [[Math]]
-(def: math-unary-method ($t;method (list $t;double) (#;Some $t;double) (list)))
-(def: math-binary-method ($t;method (list $t;double $t;double) (#;Some $t;double) (list)))
-
-(do-template [<name> <method>]
- [(def: (<name> inputI)
- Unary
- (|>. inputI
- ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Math" <method> math-unary-method false)
- ($i;wrap #$;Double)))]
-
- [math//cos "cos"]
- [math//sin "sin"]
- [math//tan "tan"]
- [math//acos "acos"]
- [math//asin "asin"]
- [math//atan "atan"]
- [math//cosh "cosh"]
- [math//sinh "sinh"]
- [math//tanh "tanh"]
- [math//exp "exp"]
- [math//log "log"]
- [math//root2 "sqrt"]
- [math//root3 "cbrt"]
- [math//ceil "ceil"]
- [math//floor "floor"]
- )
-
-(do-template [<name> <method>]
- [(def: (<name> [inputI paramI])
- Binary
- (|>. inputI ($i;unwrap #$;Double)
- paramI ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Math" <method> math-binary-method false)
- ($i;wrap #$;Double)))]
-
- [math//atan2 "atan2"]
- [math//pow "pow"]
- )
-
-(def: (math//round inputI)
- Unary
- (|>. inputI
- ($i;unwrap #$;Double)
- ($i;INVOKESTATIC "java.lang.Math" "round" ($t;method (list $t;double) (#;Some $t;long) (list)) false)
- $i;L2D
- ($i;wrap #$;Double)))
-
-## [[IO]]
-(def: string-method $;Method ($t;method (list $String) #;None (list)))
-(def: (io//log messageI)
- Unary
- (|>. ($i;GETSTATIC "java.lang.System" "out" ($t;class "java.io.PrintStream" (list)))
- messageI
- ($i;CHECKCAST "java.lang.String")
- ($i;INVOKEVIRTUAL "java.io.PrintStream" "println" string-method false)
- ($i;string hostL;unit)))
-
-(def: (io//error messageI)
- Unary
- (|>. ($i;NEW "java.lang.Error")
- $i;DUP
- messageI
- ($i;CHECKCAST "java.lang.String")
- ($i;INVOKESPECIAL "java.lang.Error" "<init>" string-method false)
- $i;ATHROW))
-
-(def: (io//exit codeI)
- Unary
- (|>. codeI jvm-intI
- ($i;INVOKESTATIC "java.lang.System" "exit" ($t;method (list $t;int) #;None (list)) false)
- $i;NULL))
-
-(def: (io//current-time [])
- Nullary
- (|>. ($i;INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t;method (list) (#;Some $t;long) (list)) false)
- ($i;wrap #$;Long)))
-
-## [[Atoms]]
-(def: atom-class Text "java.util.concurrent.atomic.AtomicReference")
-(def: (atom//new initI)
- Unary
- (|>. ($i;NEW atom-class)
- $i;DUP
- initI
- ($i;INVOKESPECIAL atom-class "<init>" ($t;method (list $Object) #;None (list)) false)))
-
-(def: (atom//read atomI)
- Unary
- (|>. atomI
- ($i;CHECKCAST atom-class)
- ($i;INVOKEVIRTUAL atom-class "get" ($t;method (list) (#;Some $Object) (list)) false)))
-
-(def: (atom//compare-and-swap [atomI oldI newI])
- Trinary
- (|>. atomI
- ($i;CHECKCAST atom-class)
- oldI
- newI
- ($i;INVOKEVIRTUAL atom-class "compareAndSet" ($t;method (list $Object $Object) (#;Some $t;boolean) (list)) false)
- ($i;wrap #$;Boolean)))
-
-## [[Processes]]
-(def: (process//concurrency-level [])
- Nullary
- (|>. ($i;GETSTATIC hostL;runtime-class "concurrency_level" $t;int)
- lux-intI))
-
-(def: (process//future procedureI)
- Unary
- (|>. procedureI ($i;CHECKCAST hostL;function-class)
- ($i;INVOKESTATIC hostL;runtime-class "future"
- ($t;method (list $Function) (#;Some $Object) (list)) false)))
-
-(def: (process//schedule [millisecondsI procedureI])
- Binary
- (|>. millisecondsI ($i;unwrap #$;Long)
- procedureI ($i;CHECKCAST hostL;function-class)
- ($i;INVOKESTATIC hostL;runtime-class "schedule"
- ($t;method (list $t;long $Function) (#;Some $Object) (list)) false)))
-
-## [Bundles]
-(def: lux-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "lux noop" (unary lux//noop))
- (install "lux is" (binary lux//is))
- (install "lux try" (unary lux//try))))
-
-(def: bit-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "bit count" (unary bit//count))
- (install "bit and" (binary bit//and))
- (install "bit or" (binary bit//or))
- (install "bit xor" (binary bit//xor))
- (install "bit shift-left" (binary bit//shift-left))
- (install "bit unsigned-shift-right" (binary bit//unsigned-shift-right))
- (install "bit shift-right" (binary bit//shift-right))
- ))
-
-(def: nat-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "nat +" (binary nat//add))
- (install "nat -" (binary nat//sub))
- (install "nat *" (binary nat//mul))
- (install "nat /" (binary nat//div))
- (install "nat %" (binary nat//rem))
- (install "nat =" (binary nat//eq))
- (install "nat <" (binary nat//lt))
- (install "nat min" (nullary nat//min))
- (install "nat max" (nullary nat//max))
- (install "nat to-int" (unary nat//to-int))
- (install "nat to-char" (unary nat//to-char))))
-
-(def: int-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "int +" (binary int//add))
- (install "int -" (binary int//sub))
- (install "int *" (binary int//mul))
- (install "int /" (binary int//div))
- (install "int %" (binary int//rem))
- (install "int =" (binary int//eq))
- (install "int <" (binary int//lt))
- (install "int min" (nullary int//min))
- (install "int max" (nullary int//max))
- (install "int to-nat" (unary int//to-nat))
- (install "int to-frac" (unary int//to-frac))))
-
-(def: deg-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "deg +" (binary deg//add))
- (install "deg -" (binary deg//sub))
- (install "deg *" (binary deg//mul))
- (install "deg /" (binary deg//div))
- (install "deg %" (binary deg//rem))
- (install "deg =" (binary deg//eq))
- (install "deg <" (binary deg//lt))
- (install "deg scale" (binary deg//scale))
- (install "deg reciprocal" (binary deg//reciprocal))
- (install "deg min" (nullary deg//min))
- (install "deg max" (nullary deg//max))
- (install "deg to-frac" (unary deg//to-frac))))
-
-(def: frac-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "frac +" (binary frac//add))
- (install "frac -" (binary frac//sub))
- (install "frac *" (binary frac//mul))
- (install "frac /" (binary frac//div))
- (install "frac %" (binary frac//rem))
- (install "frac =" (binary frac//eq))
- (install "frac <" (binary frac//lt))
- (install "frac smallest" (nullary frac//smallest))
- (install "frac min" (nullary frac//min))
- (install "frac max" (nullary frac//max))
- (install "frac not-a-number" (nullary frac//not-a-number))
- (install "frac positive-infinity" (nullary frac//positive-infinity))
- (install "frac negative-infinity" (nullary frac//negative-infinity))
- (install "frac to-deg" (unary frac//to-deg))
- (install "frac to-int" (unary frac//to-int))
- (install "frac encode" (unary frac//encode))
- (install "frac decode" (unary frac//decode))))
-
-(def: text-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "text =" (binary text//eq))
- (install "text <" (binary text//lt))
- (install "text append" (binary text//append))
- (install "text index" (trinary text//index))
- (install "text size" (unary text//size))
- (install "text hash" (unary text//hash))
- (install "text replace" (trinary text//replace))
- (install "text char" (binary text//char))
- (install "text clip" (trinary text//clip))
- ))
-
-(def: array-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "array new" (unary array//new))
- (install "array get" (binary array//get))
- (install "array put" (trinary array//put))
- (install "array remove" (binary array//remove))
- (install "array size" (unary array//size))
- ))
-
-(def: math-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "math cos" (unary math//cos))
- (install "math sin" (unary math//sin))
- (install "math tan" (unary math//tan))
- (install "math acos" (unary math//acos))
- (install "math asin" (unary math//asin))
- (install "math atan" (unary math//atan))
- (install "math cosh" (unary math//cosh))
- (install "math sinh" (unary math//sinh))
- (install "math tanh" (unary math//tanh))
- (install "math exp" (unary math//exp))
- (install "math log" (unary math//log))
- (install "math root2" (unary math//root2))
- (install "math root3" (unary math//root3))
- (install "math ceil" (unary math//ceil))
- (install "math floor" (unary math//floor))
- (install "math round" (unary math//round))
- (install "math atan2" (binary math//atan2))
- (install "math pow" (binary math//pow))
- ))
-
-(def: io-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "io log" (unary io//log))
- (install "io error" (unary io//error))
- (install "io exit" (unary io//exit))
- (install "io current-time" (nullary io//current-time))))
-
-(def: atom-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "atom new" (unary atom//new))
- (install "atom read" (unary atom//read))
- (install "atom compare-and-swap" (trinary atom//compare-and-swap))))
-
-(def: process-procs
- Bundle
- (|> (dict;new text;Hash<Text>)
- (install "process concurrency-level" (nullary process//concurrency-level))
- (install "process future" (unary process//future))
- (install "process schedule" (binary process//schedule))
- ))
-
-(def: #export procedures
- Bundle
- (|> (dict;new text;Hash<Text>)
- (dict;merge lux-procs)
- (dict;merge bit-procs)
- (dict;merge nat-procs)
- (dict;merge int-procs)
- (dict;merge deg-procs)
- (dict;merge frac-procs)
- (dict;merge text-procs)
- (dict;merge array-procs)
- (dict;merge math-procs)
- (dict;merge io-procs)
- (dict;merge atom-procs)
- (dict;merge process-procs)
- ))
diff --git a/new-luxc/source/luxc/generator/procedure/host.jvm.lux b/new-luxc/source/luxc/generator/procedure/host.jvm.lux
deleted file mode 100644
index 9222b2e4a..000000000
--- a/new-luxc/source/luxc/generator/procedure/host.jvm.lux
+++ /dev/null
@@ -1,763 +0,0 @@
-(;module:
- lux
- (lux (control [monad #+ do]
- ["p" parser "parser/" Monad<Parser>]
- ["ex" exception #+ exception:])
- (data [product]
- ["e" error]
- [text "text/" Eq<Text>]
- (text format
- ["l" lexer])
- (coll [list "list/" Functor<List>]
- [dict #+ Dict]))
- [meta #+ with-gensyms "meta/" Monad<Meta>]
- (meta [code]
- ["s" syntax #+ syntax:])
- [host])
- (luxc ["&" base]
- [";L" host]
- (host ["$" jvm]
- (jvm ["$t" type]
- ["$d" def]
- ["$i" inst]))
- (lang ["la" analysis]
- (analysis (procedure ["&;" host]))
- ["ls" synthesis])
- (generator ["&;" common]
- ["&;" runtime]))
- ["@" ../common])
-
-(do-template [<name> <inst>]
- [(def: <name>
- $;Inst
- <inst>)]
-
- [L2S (|>. $i;L2I $i;I2S)]
- [L2B (|>. $i;L2I $i;I2B)]
- [L2C (|>. $i;L2I $i;I2C)]
- )
-
-(do-template [<name> <unwrap> <conversion> <wrap>]
- [(def: (<name> inputI)
- @;Unary
- (if (is $i;NOP <conversion>)
- (|>. inputI
- ($i;unwrap <unwrap>)
- ($i;wrap <wrap>))
- (|>. inputI
- ($i;unwrap <unwrap>)
- <conversion>
- ($i;wrap <wrap>))))]
-
- [convert//double-to-float #$;Double $i;D2F #$;Float]
- [convert//double-to-int #$;Double $i;D2I #$;Int]
- [convert//double-to-long #$;Double $i;D2L #$;Long]
- [convert//float-to-double #$;Float $i;F2D #$;Double]
- [convert//float-to-int #$;Float $i;F2I #$;Int]
- [convert//float-to-long #$;Float $i;F2L #$;Long]
- [convert//int-to-byte #$;Int $i;I2B #$;Byte]
- [convert//int-to-char #$;Int $i;I2C #$;Char]
- [convert//int-to-double #$;Int $i;I2D #$;Double]
- [convert//int-to-float #$;Int $i;I2F #$;Float]
- [convert//int-to-long #$;Int $i;I2L #$;Long]
- [convert//int-to-short #$;Int $i;I2S #$;Short]
- [convert//long-to-double #$;Long $i;L2D #$;Double]
- [convert//long-to-float #$;Long $i;L2F #$;Float]
- [convert//long-to-int #$;Long $i;L2I #$;Int]
- [convert//long-to-short #$;Long L2S #$;Short]
- [convert//long-to-byte #$;Long L2B #$;Byte]
- [convert//long-to-char #$;Long L2C #$;Char]
- [convert//char-to-byte #$;Char $i;I2B #$;Byte]
- [convert//char-to-short #$;Char $i;I2S #$;Short]
- [convert//char-to-int #$;Char $i;NOP #$;Int]
- [convert//char-to-long #$;Char $i;I2L #$;Long]
- [convert//byte-to-long #$;Byte $i;I2L #$;Long]
- [convert//short-to-long #$;Short $i;I2L #$;Long]
- )
-
-(def: conversion-procs
- @;Bundle
- (<| (@;prefix "convert")
- (|> (dict;new text;Hash<Text>)
- (@;install "double-to-float" (@;unary convert//double-to-float))
- (@;install "double-to-int" (@;unary convert//double-to-int))
- (@;install "double-to-long" (@;unary convert//double-to-long))
- (@;install "float-to-double" (@;unary convert//float-to-double))
- (@;install "float-to-int" (@;unary convert//float-to-int))
- (@;install "float-to-long" (@;unary convert//float-to-long))
- (@;install "int-to-byte" (@;unary convert//int-to-byte))
- (@;install "int-to-char" (@;unary convert//int-to-char))
- (@;install "int-to-double" (@;unary convert//int-to-double))
- (@;install "int-to-float" (@;unary convert//int-to-float))
- (@;install "int-to-long" (@;unary convert//int-to-long))
- (@;install "int-to-short" (@;unary convert//int-to-short))
- (@;install "long-to-double" (@;unary convert//long-to-double))
- (@;install "long-to-float" (@;unary convert//long-to-float))
- (@;install "long-to-int" (@;unary convert//long-to-int))
- (@;install "long-to-short" (@;unary convert//long-to-short))
- (@;install "long-to-byte" (@;unary convert//long-to-byte))
- (@;install "long-to-char" (@;unary convert//long-to-char))
- (@;install "char-to-byte" (@;unary convert//char-to-byte))
- (@;install "char-to-short" (@;unary convert//char-to-short))
- (@;install "char-to-int" (@;unary convert//char-to-int))
- (@;install "char-to-long" (@;unary convert//char-to-long))
- (@;install "byte-to-long" (@;unary convert//byte-to-long))
- (@;install "short-to-long" (@;unary convert//short-to-long))
- )))
-
-(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @;Binary
- (|>. xI ($i;unwrap <unwrapX>)
- yI ($i;unwrap <unwrapY>)
- <op> ($i;wrap <wrap>)))]
-
- [int//+ $i;IADD #$;Int #$;Int #$;Int]
- [int//- $i;ISUB #$;Int #$;Int #$;Int]
- [int//* $i;IMUL #$;Int #$;Int #$;Int]
- [int/// $i;IDIV #$;Int #$;Int #$;Int]
- [int//% $i;IREM #$;Int #$;Int #$;Int]
- [int//and $i;IAND #$;Int #$;Int #$;Int]
- [int//or $i;IOR #$;Int #$;Int #$;Int]
- [int//xor $i;IXOR #$;Int #$;Int #$;Int]
- [int//shl $i;ISHL #$;Int #$;Int #$;Int]
- [int//shr $i;ISHR #$;Int #$;Int #$;Int]
- [int//ushr $i;IUSHR #$;Int #$;Int #$;Int]
-
- [long//+ $i;LADD #$;Long #$;Long #$;Long]
- [long//- $i;LSUB #$;Long #$;Long #$;Long]
- [long//* $i;LMUL #$;Long #$;Long #$;Long]
- [long/// $i;LDIV #$;Long #$;Long #$;Long]
- [long//% $i;LREM #$;Long #$;Long #$;Long]
- [long//and $i;LAND #$;Long #$;Long #$;Long]
- [long//or $i;LOR #$;Long #$;Long #$;Long]
- [long//xor $i;LXOR #$;Long #$;Long #$;Long]
- [long//shl $i;LSHL #$;Long #$;Int #$;Long]
- [long//shr $i;LSHR #$;Long #$;Int #$;Long]
- [long//ushr $i;LUSHR #$;Long #$;Int #$;Long]
-
- [float//+ $i;FADD #$;Float #$;Float #$;Float]
- [float//- $i;FSUB #$;Float #$;Float #$;Float]
- [float//* $i;FMUL #$;Float #$;Float #$;Float]
- [float/// $i;FDIV #$;Float #$;Float #$;Float]
- [float//% $i;FREM #$;Float #$;Float #$;Float]
-
- [double//+ $i;DADD #$;Double #$;Double #$;Double]
- [double//- $i;DSUB #$;Double #$;Double #$;Double]
- [double//* $i;DMUL #$;Double #$;Double #$;Double]
- [double/// $i;DDIV #$;Double #$;Double #$;Double]
- [double//% $i;DREM #$;Double #$;Double #$;Double]
- )
-
-(do-template [<name> <op> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @;Binary
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. xI ($i;unwrap <unwrapX>)
- yI ($i;unwrap <unwrapY>)
- (<op> @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end))))]
-
- [int//= $i;IF_ICMPEQ #$;Int #$;Int #$;Boolean]
- [int//< $i;IF_ICMPLT #$;Int #$;Int #$;Boolean]
-
- [char//= $i;IF_ICMPEQ #$;Char #$;Char #$;Boolean]
- [char//< $i;IF_ICMPLT #$;Char #$;Char #$;Boolean]
- )
-
-(do-template [<name> <op> <reference> <unwrapX> <unwrapY> <wrap>]
- [(def: (<name> [xI yI])
- @;Binary
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. xI ($i;unwrap <unwrapX>)
- yI ($i;unwrap <unwrapY>)
- <op>
- ($i;int <reference>)
- ($i;IF_ICMPEQ @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end))))]
-
- [long//= $i;LCMP 0 #$;Long #$;Long #$;Boolean]
- [long//< $i;LCMP -1 #$;Long #$;Long #$;Boolean]
-
- [float//= $i;FCMPG 0 #$;Float #$;Float #$;Boolean]
- [float//< $i;FCMPG -1 #$;Float #$;Float #$;Boolean]
-
- [double//= $i;DCMPG 0 #$;Double #$;Double #$;Boolean]
- [double//< $i;DCMPG -1 #$;Double #$;Double #$;Boolean]
- )
-
-(def: int-procs
- @;Bundle
- (<| (@;prefix "int")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary int//+))
- (@;install "-" (@;binary int//-))
- (@;install "*" (@;binary int//*))
- (@;install "/" (@;binary int///))
- (@;install "%" (@;binary int//%))
- (@;install "=" (@;binary int//=))
- (@;install "<" (@;binary int//<))
- (@;install "and" (@;binary int//and))
- (@;install "or" (@;binary int//or))
- (@;install "xor" (@;binary int//xor))
- (@;install "shl" (@;binary int//shl))
- (@;install "shr" (@;binary int//shr))
- (@;install "ushr" (@;binary int//ushr))
- )))
-
-(def: long-procs
- @;Bundle
- (<| (@;prefix "long")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary long//+))
- (@;install "-" (@;binary long//-))
- (@;install "*" (@;binary long//*))
- (@;install "/" (@;binary long///))
- (@;install "%" (@;binary long//%))
- (@;install "=" (@;binary long//=))
- (@;install "<" (@;binary long//<))
- (@;install "and" (@;binary long//and))
- (@;install "or" (@;binary long//or))
- (@;install "xor" (@;binary long//xor))
- (@;install "shl" (@;binary long//shl))
- (@;install "shr" (@;binary long//shr))
- (@;install "ushr" (@;binary long//ushr))
- )))
-
-(def: float-procs
- @;Bundle
- (<| (@;prefix "float")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary float//+))
- (@;install "-" (@;binary float//-))
- (@;install "*" (@;binary float//*))
- (@;install "/" (@;binary float///))
- (@;install "%" (@;binary float//%))
- (@;install "=" (@;binary float//=))
- (@;install "<" (@;binary float//<))
- )))
-
-(def: double-procs
- @;Bundle
- (<| (@;prefix "double")
- (|> (dict;new text;Hash<Text>)
- (@;install "+" (@;binary double//+))
- (@;install "-" (@;binary double//-))
- (@;install "*" (@;binary double//*))
- (@;install "/" (@;binary double///))
- (@;install "%" (@;binary double//%))
- (@;install "=" (@;binary double//=))
- (@;install "<" (@;binary double//<))
- )))
-
-(def: char-procs
- @;Bundle
- (<| (@;prefix "char")
- (|> (dict;new text;Hash<Text>)
- (@;install "=" (@;binary char//=))
- (@;install "<" (@;binary char//<))
- )))
-
-(def: (array//length arrayI)
- @;Unary
- (|>. arrayI
- $i;ARRAYLENGTH
- $i;I2L
- ($i;wrap #$;Long)))
-
-(def: (array//new proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS))
- (do meta;Monad<Meta>
- [lengthI (generate lengthS)
- #let [arrayJT ($t;array level (case class
- "boolean" $t;boolean
- "byte" $t;byte
- "short" $t;short
- "int" $t;int
- "long" $t;long
- "float" $t;float
- "double" $t;double
- "char" $t;char
- _ ($t;class class (list))))]]
- (wrap (|>. lengthI
- ($i;unwrap #$;Long)
- $i;L2I
- ($i;array arrayJT))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (array//read proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] idxS arrayS))
- (do meta;Monad<Meta>
- [arrayI (generate arrayS)
- idxI (generate idxS)
- #let [loadI (case class
- "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean))
- "byte" (|>. $i;BALOAD ($i;wrap #$;Byte))
- "short" (|>. $i;SALOAD ($i;wrap #$;Short))
- "int" (|>. $i;IALOAD ($i;wrap #$;Int))
- "long" (|>. $i;LALOAD ($i;wrap #$;Long))
- "float" (|>. $i;FALOAD ($i;wrap #$;Float))
- "double" (|>. $i;DALOAD ($i;wrap #$;Double))
- "char" (|>. $i;CALOAD ($i;wrap #$;Char))
- _ $i;AALOAD)]]
- (wrap (|>. arrayI
- idxI
- ($i;unwrap #$;Long)
- $i;L2I
- loadI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (array//write proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] idxS valueS arrayS))
- (do meta;Monad<Meta>
- [arrayI (generate arrayS)
- idxI (generate idxS)
- valueI (generate valueS)
- #let [storeI (case class
- "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE)
- "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE)
- "short" (|>. ($i;unwrap #$;Short) $i;SASTORE)
- "int" (|>. ($i;unwrap #$;Int) $i;IASTORE)
- "long" (|>. ($i;unwrap #$;Long) $i;LASTORE)
- "float" (|>. ($i;unwrap #$;Float) $i;FASTORE)
- "double" (|>. ($i;unwrap #$;Double) $i;DASTORE)
- "char" (|>. ($i;unwrap #$;Char) $i;CASTORE)
- _ $i;AASTORE)]]
- (wrap (|>. arrayI
- $i;DUP
- idxI
- ($i;unwrap #$;Long)
- $i;L2I
- valueI
- storeI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: array-procs
- @;Bundle
- (<| (@;prefix "array")
- (|> (dict;new text;Hash<Text>)
- (@;install "length" (@;unary array//length))
- (@;install "new" array//new)
- (@;install "read" array//read)
- (@;install "write" array//write)
- )))
-
-(def: (object//null _)
- @;Nullary
- $i;NULL)
-
-(def: (object//null? objectI)
- @;Unary
- (<| $i;with-label (function [@then])
- $i;with-label (function [@end])
- (|>. objectI
- ($i;IFNULL @then)
- ($i;GETSTATIC "java.lang.Boolean" "FALSE" ($t;class "java.lang.Boolean" (list)))
- ($i;GOTO @end)
- ($i;label @then)
- ($i;GETSTATIC "java.lang.Boolean" "TRUE" ($t;class "java.lang.Boolean" (list)))
- ($i;label @end))))
-
-(def: (object//synchronized [monitorI exprI])
- @;Binary
- (|>. monitorI
- $i;DUP
- $i;MONITORENTER
- exprI
- $i;SWAP
- $i;MONITOREXIT))
-
-(def: (object//throw exceptionI)
- @;Unary
- (|>. exceptionI
- $i;ATHROW))
-
-(def: (object//class proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)]))
- (do meta;Monad<Meta>
- []
- (wrap (|>. ($i;string class)
- ($i;INVOKESTATIC "java.lang.Class" "forName"
- ($t;method (list ($t;class "java.lang.String" (list)))
- (#;Some ($t;class "java.lang.Class" (list)))
- (list))
- false))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (object//instance? proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] objectS))
- (do meta;Monad<Meta>
- [objectI (generate objectS)]
- (wrap (|>. objectI
- ($i;INSTANCEOF class)
- ($i;wrap #$;Boolean))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: object-procs
- @;Bundle
- (<| (@;prefix "object")
- (|> (dict;new text;Hash<Text>)
- (@;install "null" (@;nullary object//null))
- (@;install "null?" (@;unary object//null?))
- (@;install "synchronized" (@;binary object//synchronized))
- (@;install "throw" (@;unary object//throw))
- (@;install "class" object//class)
- (@;install "instance?" object//instance?)
- )))
-
-(def: primitives
- (Dict Text $;Primitive)
- (|> (list ["boolean" #$;Boolean]
- ["byte" #$;Byte]
- ["short" #$;Short]
- ["int" #$;Int]
- ["long" #$;Long]
- ["float" #$;Float]
- ["double" #$;Double]
- ["char" #$;Char])
- (dict;from-list text;Hash<Text>)))
-
-(def: (static//get proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)]))
- (do meta;Monad<Meta>
- []
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. ($i;GETSTATIC class field (#$;Primitive primitive))
- ($i;wrap primitive))))
-
- #;None
- (wrap ($i;GETSTATIC class field ($t;class unboxed (list))))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (static//put proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS))
- (do meta;Monad<Meta>
- [valueI (generate valueS)]
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. valueI
- ($i;unwrap primitive)
- ($i;PUTSTATIC class field (#$;Primitive primitive))
- ($i;string hostL;unit))))
-
- #;None
- (wrap (|>. valueI
- ($i;CHECKCAST class)
- ($i;PUTSTATIC class field ($t;class class (list)))
- ($i;string hostL;unit)))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (virtual//get proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS))
- (do meta;Monad<Meta>
- [objectI (generate objectS)]
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- ($i;GETFIELD class field (#$;Primitive primitive))
- ($i;wrap primitive))))
-
- #;None
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- ($i;GETFIELD class field ($t;class unboxed (list)))))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: (virtual//put proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS))
- (do meta;Monad<Meta>
- [valueI (generate valueS)
- objectI (generate objectS)]
- (case (dict;get unboxed primitives)
- (#;Some primitive)
- (let [primitive (case unboxed
- "boolean" #$;Boolean
- "byte" #$;Byte
- "short" #$;Short
- "int" #$;Int
- "long" #$;Long
- "float" #$;Float
- "double" #$;Double
- "char" #$;Char
- _ (undefined))]
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- $i;DUP
- valueI
- ($i;unwrap primitive)
- ($i;PUTFIELD class field (#$;Primitive primitive)))))
-
- #;None
- (wrap (|>. objectI
- ($i;CHECKCAST class)
- $i;DUP
- valueI
- ($i;CHECKCAST unboxed)
- ($i;PUTFIELD class field ($t;class unboxed (list)))))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(exception: #export Invalid-Syntax-For-Argument-Generation)
-
-(def: base-type
- (l;Lexer $;Type)
- ($_ p;either
- (p;after (l;this "boolean") (parser/wrap $t;boolean))
- (p;after (l;this "byte") (parser/wrap $t;byte))
- (p;after (l;this "short") (parser/wrap $t;short))
- (p;after (l;this "int") (parser/wrap $t;int))
- (p;after (l;this "long") (parser/wrap $t;long))
- (p;after (l;this "float") (parser/wrap $t;float))
- (p;after (l;this "double") (parser/wrap $t;double))
- (p;after (l;this "char") (parser/wrap $t;char))
- (parser/map (function [name]
- ($t;class name (list)))
- (l;many (l;none-of "[")))
- ))
-
-(def: java-type
- (l;Lexer $;Type)
- (do p;Monad<Parser>
- [raw base-type
- nesting (p;some (l;this "[]"))]
- (wrap ($t;array (list;size nesting) raw))))
-
-(def: (generate-type argD)
- (-> Text (Meta $;Type))
- (case (l;run argD java-type)
- (#e;Error error)
- (&;fail error)
-
- (#e;Success type)
- (meta/wrap type)))
-
-(def: (prepare-input inputT inputI)
- (-> $;Type $;Inst $;Inst)
- (case inputT
- (#$;Primitive primitive)
- (|>. inputI ($i;unwrap primitive))
-
- (#$;Generic generic)
- (case generic
- (^or (#$;Var _) (#$;Wildcard _))
- (|>. inputI ($i;CHECKCAST "java.lang.Object"))
-
- (#$;Class class-name _)
- (|>. inputI ($i;CHECKCAST class-name)))
-
- _
- (|>. inputI ($i;CHECKCAST ($t;descriptor inputT)))))
-
-(def: (generate-args generate argsS)
- (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis)
- (Meta (List [$;Type $;Inst])))
- (case argsS
- #;Nil
- (meta/wrap #;Nil)
-
- (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail))
- (do meta;Monad<Meta>
- [argT (generate-type argD)
- argI (:: @ map (prepare-input argT) (generate argS))
- =tail (generate-args generate tail)]
- (wrap (list& [argT argI] =tail)))
-
- _
- (&;throw Invalid-Syntax-For-Argument-Generation "")))
-
-(def: (method-return-type description)
- (-> Text (Meta (Maybe $;Type)))
- (case description
- "void"
- (meta/wrap #;None)
-
- _
- (:: meta;Monad<Meta> map (|>. #;Some) (generate-type description))))
-
-(def: (prepare-return returnT returnI)
- (-> (Maybe $;Type) $;Inst $;Inst)
- (case returnT
- #;None
- (|>. returnI
- ($i;string hostL;unit))
-
- (#;Some type)
- (case type
- (#$;Primitive primitive)
- (|>. returnI ($i;wrap primitive))
-
- _
- returnI)))
-
-(def: (invoke//static proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list& [_ (#;Text class)] [_ (#;Text method)]
- [_ (#;Text unboxed)] argsS))
- (do meta;Monad<Meta>
- [argsTI (generate-args generate argsS)
- returnT (method-return-type unboxed)
- #let [callI (|>. ($i;fuse (list/map product;right argsTI))
- ($i;INVOKESTATIC class method
- ($t;method (list/map product;left argsTI) returnT (list))
- false))]]
- (wrap (prepare-return returnT callI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(do-template [<name> <invoke> <interface?>]
- [(def: (<name> proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list& [_ (#;Text class)] [_ (#;Text method)]
- [_ (#;Text unboxed)] objectS argsS))
- (do meta;Monad<Meta>
- [objectI (generate objectS)
- argsTI (generate-args generate argsS)
- returnT (method-return-type unboxed)
- #let [callI (|>. objectI
- ($i;CHECKCAST class)
- ($i;fuse (list/map product;right argsTI))
- (<invoke> class method
- ($t;method (list/map product;left argsTI) returnT (list))
- <interface?>))]]
- (wrap (prepare-return returnT callI)))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))]
-
- [invoke//virtual $i;INVOKEVIRTUAL false]
- [invoke//special $i;INVOKESPECIAL false]
- [invoke//interface $i;INVOKEINTERFACE true]
- )
-
-(def: (invoke//constructor proc generate inputs)
- (-> Text @;Proc)
- (case inputs
- (^ (list& [_ (#;Text class)] argsS))
- (do meta;Monad<Meta>
- [argsTI (generate-args generate argsS)]
- (wrap (|>. ($i;NEW class)
- $i;DUP
- ($i;fuse (list/map product;right argsTI))
- ($i;INVOKESPECIAL class "<init>"
- ($t;method (list/map product;left argsTI) #;None (list))
- false))))
-
- _
- (&;fail (format "Wrong syntax for '" proc "'."))))
-
-(def: member-procs
- @;Bundle
- (<| (@;prefix "member")
- (|> (dict;new text;Hash<Text>)
- (dict;merge (<| (@;prefix "static")
- (|> (dict;new text;Hash<Text>)
- (@;install "get" static//get)
- (@;install "put" static//put))))
- (dict;merge (<| (@;prefix "virtual")
- (|> (dict;new text;Hash<Text>)
- (@;install "get" virtual//get)
- (@;install "put" virtual//put))))
- (dict;merge (<| (@;prefix "invoke")
- (|> (dict;new text;Hash<Text>)
- (@;install "static" invoke//static)
- (@;install "virtual" invoke//virtual)
- (@;install "special" invoke//special)
- (@;install "interface" invoke//interface)
- (@;install "constructor" invoke//constructor)
- )))
- )))
-
-(def: #export procedures
- @;Bundle
- (<| (@;prefix "jvm")
- (|> (dict;new text;Hash<Text>)
- (dict;merge conversion-procs)
- (dict;merge int-procs)
- (dict;merge long-procs)
- (dict;merge float-procs)
- (dict;merge double-procs)
- (dict;merge char-procs)
- (dict;merge array-procs)
- (dict;merge object-procs)
- (dict;merge member-procs)
- )))