(.module: lux (lux (control [monad #+ do] ["p" parser] ["ex" exception #+ exception:]) (data ["e" error] [text] text/format (coll [list "list/" Functor] (dictionary ["dict" unordered #+ Dict]))) [macro #+ with-gensyms] (macro [code] ["s" syntax #+ syntax:]) [host] ["//" lang] (lang ["//." reference #+ Register] ["//." synthesis #+ Synthesis] ["//." extension])) (luxc (lang [".L" host] (host ["$" jvm] (jvm ["$t" type] ["$d" def] ["$i" inst])))) (/// [".T" runtime] [".T" case] [".T" function] [".T" loop])) (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 Translator (-> Synthesis (Meta $.Inst))) (type: #export Proc (-> Translator (List 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)) (type: #export Variadic (-> (List $.Inst) $.Inst)) ## [Utils] (def: $Object $.Type ($t.class "java.lang.Object" (list))) (def: $Object-Array $.Type ($t.array +1 $Object)) (def: $Variant $.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))) (def: (wrong-arity proc expected actual) (-> Text Nat Nat Text) (format "Wrong number of arguments for " (%t proc) "\n" "Expected: " (|> expected .int %i) "\n" " Actual: " (|> actual .int %i))) (syntax: (arity: {name s.local-symbol} {arity s.nat}) (with-gensyms [g!_ g!proc g!name g!translate g!inputs] (do @ [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] (wrap (list (` (def: #export ((~ (code.local-symbol name)) (~ g!proc)) (-> (-> (..Vector (~ (code.nat arity)) $.Inst) $.Inst) (-> Text ..Proc)) (function ((~ g!_) (~ g!name)) (function ((~ g!_) (~ g!translate) (~ g!inputs)) (case (~ g!inputs) (^ (list (~+ g!input+))) (do macro.Monad [(~+ (|> g!input+ (list/map (function (_ g!input) (list g!input (` ((~ g!translate) (~ g!input)))))) list.concat))] ((~' wrap) ((~ g!proc) [(~+ g!input+)]))) (~' _) (macro.fail (wrong-arity (~ g!name) +1 (list.size (~ g!inputs)))))))))))))) (arity: nullary +0) (arity: unary +1) (arity: binary +2) (arity: trinary +3) (def: #export (variadic proc) (-> Variadic (-> Text Proc)) (function (_ proc-name) (function (_ translate inputsS) (do macro.Monad [inputsI (monad.map @ translate inputsS)] (wrap (proc inputsI)))))) ## [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) ))) (def: unitI $.Inst ($i.string hostL.unit)) ## [Procedures] ## [[Lux]] (def: (lux//is [leftI rightI]) Binary (|>> leftI rightI (predicateI $i.IF_ACMPEQ))) (def: (lux//if [testI thenI elseI]) Trinary (caseT.translate-if testI thenI elseI)) (def: (lux//try riskyI) Unary (|>> riskyI ($i.CHECKCAST hostL.function-class) ($i.INVOKESTATIC hostL.runtime-class "try" ($t.method (list $Function) (#.Some $Object-Array) (list)) false))) (def: (lux//noop valueI) Unary valueI) (exception: #export (Wrong-Syntax {message Text}) message) (def: #export (wrong-syntax procedure args) (-> Text (List Synthesis) Text) (format "Procedure: " procedure "\n" "Arguments: " (%code (code.tuple args)))) (def: lux//loop (-> Text Proc) (function (_ proc-name) (function (_ translate inputsS) (case (s.run inputsS ($_ p.seq s.nat (s.tuple (p.many s.any)) s.any)) (#e.Success [offset initsS+ bodyS]) (loopT.translate-loop translate offset initsS+ bodyS) (#e.Error error) (//.throw Wrong-Syntax (wrong-syntax proc-name inputsS))) ))) (def: lux//recur (-> Text Proc) (function (_ proc-name) (function (_ translate inputsS) (loopT.translate-recur translate inputsS)))) ## [[Bits]] (do-template [ ] [(def: ( [inputI maskI]) Binary (|>> inputI ($i.unwrap #$.Long) maskI ($i.unwrap #$.Long) ($i.wrap #$.Long)))] [bit//and $i.LAND] [bit//or $i.LOR] [bit//xor $i.LXOR] ) (do-template [ ] [(def: ( [inputI shiftI]) Binary (|>> inputI ($i.unwrap #$.Long) shiftI jvm-intI ($i.wrap #$.Long)))] [bit//left-shift $i.LSHL] [bit//arithmetic-right-shift $i.LSHR] [bit//logical-right-shift $i.LUSHR] ) ## [[Arrays]] (def: (array//new lengthI) Unary (|>> lengthI jvm-intI ($i.ANEWARRAY ($t.binary-name "java.lang.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) runtimeT.someI ($i.GOTO @end) ($i.label @is-null) $i.POP runtimeT.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))) (do-template [ ] [(def: ( _) Nullary (|>> ($i.wrap )))] [int//min ($i.long Long::MIN_VALUE) #$.Long] [int//max ($i.long Long::MAX_VALUE) #$.Long] [frac//smallest ($i.double Double::MIN_VALUE) #$.Double] [frac//min ($i.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] [frac//max ($i.double Double::MAX_VALUE) #$.Double] [frac//not-a-number ($i.double Double::NaN) #$.Double] [frac//positive-infinity ($i.double Double::POSITIVE_INFINITY) #$.Double] [frac//negative-infinity ($i.double Double::NEGATIVE_INFINITY) #$.Double] ) (do-template [ ] [(def: ( [subjectI paramI]) Binary (|>> subjectI ($i.unwrap ) paramI ($i.unwrap ) ($i.wrap )))] [int//add #$.Long $i.LADD] [int//sub #$.Long $i.LSUB] [int//mul #$.Long $i.LMUL] [int//div #$.Long $i.LDIV] [int//rem #$.Long $i.LREM] [frac//add #$.Double $i.DADD] [frac//sub #$.Double $i.DSUB] [frac//mul #$.Double $i.DMUL] [frac//div #$.Double $i.DDIV] [frac//rem #$.Double $i.DREM] ) (do-template [ ] [(do-template [ ] [(def: ( [subjectI paramI]) Binary (|>> subjectI paramI ($i.int ) (predicateI $i.IF_ICMPEQ)))] [ 0] [ -1])] [int//eq int//lt ($i.unwrap #$.Long) $i.LCMP] [frac//eq frac//lt ($i.unwrap #$.Double) $i.DCMPG] ) (do-template [ ] [(def: ( inputI) Unary (|>> inputI ))] [int//to-frac ($i.unwrap #$.Long) (<| ($i.wrap #$.Double) $i.L2D)] [int//char ($i.unwrap #$.Long) ((|>> $i.L2I $i.I2C ($i.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) false)))] [frac//to-int ($i.unwrap #$.Double) (<| ($i.wrap #$.Long) $i.D2L)] [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)] ) ## [[Text]] (do-template [ ] [(def: ( inputI) Unary (|>> inputI ($i.CHECKCAST "java.lang.String") ($i.INVOKEVIRTUAL ($t.method (list) (#.Some ) (list)) false) ))] [text//size "java.lang.String" "length" lux-intI $t.int] [text//hash "java.lang.Object" "hashCode" lux-intI $t.int] ) (do-template [ ] [(def: ( [subjectI paramI]) Binary (|>> subjectI paramI ))] [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) ($i.int -1))] [text//concat ($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 $Variant) (list)) false) id] ) (do-template [ ] [(def: ( [subjectI paramI extraI]) Trinary (|>> subjectI paramI extraI ))] [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 $Variant) (list)) false)] [text//replace-once ($i.CHECKCAST "java.lang.String") (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) ($i.CHECKCAST "java.lang.String")) ($i.CHECKCAST "java.lang.String") ($i.INVOKEVIRTUAL "java.lang.String" "replaceFirst" ($t.method (list $String $String) (#.Some $String) (list)) false)] [text//replace-all ($i.CHECKCAST "java.lang.String") (<| ($i.INVOKESTATIC "java.util.regex.Pattern" "quote" ($t.method (list $String) (#.Some $String) (list)) false) ($i.CHECKCAST "java.lang.String")) ($i.CHECKCAST "java.lang.String") ($i.INVOKEVIRTUAL "java.lang.String" "replaceAll" ($t.method (list $String $String) (#.Some $String) (list)) false)] ) (def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) (def: (text//index [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" "indexOf" index-method false) $i.DUP ($i.int -1) ($i.IF_ICMPEQ @not-found) lux-intI runtimeT.someI ($i.GOTO @end) ($i.label @not-found) $i.POP runtimeT.noneI ($i.label @end)))) ## [[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 [ ] [(def: ( inputI) Unary (|>> inputI ($i.unwrap #$.Double) ($i.INVOKESTATIC "java.lang.Math" 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//ceil "ceil"] [math//floor "floor"] ) (do-template [ ] [(def: ( [inputI paramI]) Binary (|>> inputI ($i.unwrap #$.Double) paramI ($i.unwrap #$.Double) ($i.INVOKESTATIC "java.lang.Math" 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) unitI)) (def: (io//error messageI) Unary (|>> ($i.NEW "java.lang.Error") $i.DUP messageI ($i.CHECKCAST "java.lang.String") ($i.INVOKESPECIAL "java.lang.Error" "" 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 "" ($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))) ## [[Box]] (def: empty-boxI $.Inst (|>> ($i.int 1) ($i.ANEWARRAY ($t.binary-name "java.lang.Object")))) (def: check-boxI $.Inst ($i.CHECKCAST ($t.descriptor $Object-Array))) (def: (box//new initI) Unary (|>> empty-boxI $i.DUP ($i.int 0) initI $i.AASTORE)) (def: (box//read boxI) Unary (|>> boxI check-boxI ($i.int 0) $i.AALOAD)) (def: (box//write [valueI boxI]) Binary (|>> boxI check-boxI ($i.int 0) valueI $i.AASTORE unitI)) ## [[Processes]] (def: (process//parallelism-level []) Nullary (|>> ($i.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) false) ($i.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) false) lux-intI)) (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) (install "noop" (unary lux//noop)) (install "is" (binary lux//is)) (install "try" (unary lux//try)) (install "if" (trinary lux//if)) (install "loop" lux//loop) (install "recur" lux//recur) )) (def: bit-procs Bundle (<| (prefix "bit") (|> (dict.new text.Hash) (install "and" (binary bit//and)) (install "or" (binary bit//or)) (install "xor" (binary bit//xor)) (install "left-shift" (binary bit//left-shift)) (install "logical-right-shift" (binary bit//logical-right-shift)) (install "arithmetic-right-shift" (binary bit//arithmetic-right-shift)) ))) (def: int-procs Bundle (<| (prefix "int") (|> (dict.new text.Hash) (install "+" (binary int//add)) (install "-" (binary int//sub)) (install "*" (binary int//mul)) (install "/" (binary int//div)) (install "%" (binary int//rem)) (install "=" (binary int//eq)) (install "<" (binary int//lt)) (install "min" (nullary int//min)) (install "max" (nullary int//max)) (install "to-frac" (unary int//to-frac)) (install "char" (unary int//char))))) (def: frac-procs Bundle (<| (prefix "frac") (|> (dict.new text.Hash) (install "+" (binary frac//add)) (install "-" (binary frac//sub)) (install "*" (binary frac//mul)) (install "/" (binary frac//div)) (install "%" (binary frac//rem)) (install "=" (binary frac//eq)) (install "<" (binary frac//lt)) (install "smallest" (nullary frac//smallest)) (install "min" (nullary frac//min)) (install "max" (nullary frac//max)) (install "not-a-number" (nullary frac//not-a-number)) (install "positive-infinity" (nullary frac//positive-infinity)) (install "negative-infinity" (nullary frac//negative-infinity)) (install "to-int" (unary frac//to-int)) (install "encode" (unary frac//encode)) (install "decode" (unary frac//decode))))) (def: text-procs Bundle (<| (prefix "text") (|> (dict.new text.Hash) (install "=" (binary text//eq)) (install "<" (binary text//lt)) (install "concat" (binary text//concat)) (install "index" (trinary text//index)) (install "size" (unary text//size)) (install "hash" (unary text//hash)) (install "replace-once" (trinary text//replace-once)) (install "replace-all" (trinary text//replace-all)) (install "char" (binary text//char)) (install "clip" (trinary text//clip)) ))) (def: array-procs Bundle (<| (prefix "array") (|> (dict.new text.Hash) (install "new" (unary array//new)) (install "get" (binary array//get)) (install "put" (trinary array//put)) (install "remove" (binary array//remove)) (install "size" (unary array//size)) ))) (def: math-procs Bundle (<| (prefix "math") (|> (dict.new text.Hash) (install "cos" (unary math//cos)) (install "sin" (unary math//sin)) (install "tan" (unary math//tan)) (install "acos" (unary math//acos)) (install "asin" (unary math//asin)) (install "atan" (unary math//atan)) (install "cosh" (unary math//cosh)) (install "sinh" (unary math//sinh)) (install "tanh" (unary math//tanh)) (install "exp" (unary math//exp)) (install "log" (unary math//log)) (install "ceil" (unary math//ceil)) (install "floor" (unary math//floor)) (install "round" (unary math//round)) (install "atan2" (binary math//atan2)) (install "pow" (binary math//pow)) ))) (def: io-procs Bundle (<| (prefix "io") (|> (dict.new text.Hash) (install "log" (unary io//log)) (install "error" (unary io//error)) (install "exit" (unary io//exit)) (install "current-time" (nullary io//current-time))))) (def: atom-procs Bundle (<| (prefix "atom") (|> (dict.new text.Hash) (install "new" (unary atom//new)) (install "read" (unary atom//read)) (install "compare-and-swap" (trinary atom//compare-and-swap))))) (def: box-procs Bundle (<| (prefix "box") (|> (dict.new text.Hash) (install "new" (unary box//new)) (install "read" (unary box//read)) (install "write" (binary box//write))))) (def: process-procs Bundle (<| (prefix "process") (|> (dict.new text.Hash) (install "parallelism-level" (nullary process//parallelism-level)) (install "schedule" (binary process//schedule)) ))) (def: #export procedures Bundle (<| (prefix "lux") (|> lux-procs (dict.merge bit-procs) (dict.merge int-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 box-procs) (dict.merge process-procs) )))