(.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] ["_" inst])))) (/// [".T" runtime] [".T" case] [".T" function] [".T" loop])) (host.import: java/lang/Double (#static MIN_VALUE Double) (#static MAX_VALUE 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-identifier} {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-identifier 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 (|>> _.I2L (_.wrap #$.Long))) (def: jvm-intI $.Inst (|>> (_.unwrap #$.Long) _.L2I)) (def: (array-writeI arrayI idxI elemI) (-> $.Inst $.Inst $.Inst $.Inst) (|>> arrayI (_.CHECKCAST ($t.descriptor $Object-Array)) _.DUP idxI jvm-intI elemI _.AASTORE)) (def: (predicateI tester) (-> (-> $.Label $.Inst) $.Inst) (<| _.with-label (function (_ @then)) _.with-label (function (_ @end)) (|>> (tester @then) (_.GETSTATIC "java.lang.Boolean" "FALSE" ($t.class "java.lang.Boolean" (list))) (_.GOTO @end) (_.label @then) (_.GETSTATIC "java.lang.Boolean" "TRUE" ($t.class "java.lang.Boolean" (list))) (_.label @end) ))) (def: unitI $.Inst (_.string hostL.unit)) ## [Procedures] ## [[Lux]] (def: (lux//is [leftI rightI]) Binary (|>> leftI rightI (predicateI _.IF_ACMPEQ))) (def: (lux//if [testI thenI elseI]) Trinary (caseT.translate-if testI thenI elseI)) (def: (lux//try riskyI) Unary (|>> riskyI (_.CHECKCAST hostL.function-class) (_.INVOKESTATIC hostL.runtime-class "try" ($t.method (list $Function) (#.Some $Object-Array) (list)) #0))) (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 (_.unwrap #$.Long) maskI (_.unwrap #$.Long) (_.wrap #$.Long)))] [bit//and _.LAND] [bit//or _.LOR] [bit//xor _.LXOR] ) (do-template [ ] [(def: ( [inputI shiftI]) Binary (|>> inputI (_.unwrap #$.Long) shiftI jvm-intI (_.wrap #$.Long)))] [bit//left-shift _.LSHL] [bit//arithmetic-right-shift _.LSHR] [bit//logical-right-shift _.LUSHR] ) ## [[Arrays]] (def: (array//new lengthI) Unary (|>> lengthI jvm-intI (_.ANEWARRAY ($t.binary-name "java.lang.Object")))) (def: (array//get [arrayI idxI]) Binary (<| _.with-label (function (_ @is-null)) _.with-label (function (_ @end)) (|>> arrayI (_.CHECKCAST ($t.descriptor $Object-Array)) idxI jvm-intI _.AALOAD _.DUP (_.IFNULL @is-null) runtimeT.someI (_.GOTO @end) (_.label @is-null) _.POP runtimeT.noneI (_.label @end)))) (def: (array//put [arrayI idxI elemI]) Trinary (array-writeI arrayI idxI elemI)) (def: (array//remove [arrayI idxI]) Binary (array-writeI arrayI idxI _.NULL)) (def: (array//size arrayI) Unary (|>> arrayI (_.CHECKCAST ($t.descriptor $Object-Array)) _.ARRAYLENGTH lux-intI)) ## [[Numbers]] (def: nat-method $.Method ($t.method (list $t.long $t.long) (#.Some $t.long) (list))) (do-template [ ] [(def: ( _) Nullary (|>> (_.wrap )))] [frac//smallest (_.double Double::MIN_VALUE) #$.Double] [frac//min (_.double (f/* -1.0 Double::MAX_VALUE)) #$.Double] [frac//max (_.double Double::MAX_VALUE) #$.Double] ) (do-template [ ] [(def: ( [subjectI paramI]) Binary (|>> subjectI (_.unwrap ) paramI (_.unwrap ) (_.wrap )))] [int//add #$.Long _.LADD] [int//sub #$.Long _.LSUB] [int//mul #$.Long _.LMUL] [int//div #$.Long _.LDIV] [int//rem #$.Long _.LREM] [frac//add #$.Double _.DADD] [frac//sub #$.Double _.DSUB] [frac//mul #$.Double _.DMUL] [frac//div #$.Double _.DDIV] [frac//rem #$.Double _.DREM] ) (do-template [ ] [(do-template [ ] [(def: ( [subjectI paramI]) Binary (|>> subjectI paramI (_.int ) (predicateI _.IF_ICMPEQ)))] [ 0] [ -1])] [int//eq int//lt (_.unwrap #$.Long) _.LCMP] [frac//eq frac//lt (_.unwrap #$.Double) _.DCMPG] ) (do-template [ ] [(def: ( inputI) Unary (|>> inputI ))] [int//to-frac (_.unwrap #$.Long) (<| (_.wrap #$.Double) _.L2D)] [int//char (_.unwrap #$.Long) ((|>> _.L2I _.I2C (_.INVOKESTATIC "java.lang.Character" "toString" ($t.method (list $t.char) (#.Some $String) (list)) #0)))] [frac//to-int (_.unwrap #$.Double) (<| (_.wrap #$.Long) _.D2L)] [frac//encode (_.unwrap #$.Double) (_.INVOKESTATIC "java.lang.Double" "toString" ($t.method (list $t.double) (#.Some $String) (list)) #0)] [frac//decode (_.CHECKCAST "java.lang.String") (_.INVOKESTATIC hostL.runtime-class "decode_frac" ($t.method (list $String) (#.Some $Object-Array) (list)) #0)] ) ## [[Text]] (do-template [ ] [(def: ( inputI) Unary (|>> inputI (_.CHECKCAST "java.lang.String") (_.INVOKEVIRTUAL ($t.method (list) (#.Some ) (list)) #0) ))] [text//size "java.lang.String" "length" lux-intI $t.int] ) (do-template [ ] [(def: ( [subjectI paramI]) Binary (|>> subjectI paramI ))] [text//eq id id (_.INVOKEVIRTUAL "java.lang.Object" "equals" ($t.method (list $Object) (#.Some $t.boolean) (list)) #0) (_.wrap #$.Boolean)] [text//lt (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") (_.INVOKEVIRTUAL "java.lang.String" "compareTo" ($t.method (list $String) (#.Some $t.int) (list)) #0) (<| (predicateI _.IF_ICMPEQ) (_.int -1))] [text//concat (_.CHECKCAST "java.lang.String") (_.CHECKCAST "java.lang.String") (_.INVOKEVIRTUAL "java.lang.String" "concat" ($t.method (list $String) (#.Some $String) (list)) #0) id] [text//char (_.CHECKCAST "java.lang.String") jvm-intI (_.INVOKESTATIC hostL.runtime-class "text_char" ($t.method (list $String $t.int) (#.Some $Variant) (list)) #0) id] ) (do-template [ ] [(def: ( [subjectI paramI extraI]) Trinary (|>> subjectI paramI extraI ))] [text//clip (_.CHECKCAST "java.lang.String") jvm-intI jvm-intI (_.INVOKESTATIC hostL.runtime-class "text_clip" ($t.method (list $String $t.int $t.int) (#.Some $Variant) (list)) #0)] ) (def: index-method $.Method ($t.method (list $String $t.int) (#.Some $t.int) (list))) (def: (text//index [textI partI startI]) Trinary (<| _.with-label (function (_ @not-found)) _.with-label (function (_ @end)) (|>> textI (_.CHECKCAST "java.lang.String") partI (_.CHECKCAST "java.lang.String") startI jvm-intI (_.INVOKEVIRTUAL "java.lang.String" "indexOf" index-method #0) _.DUP (_.int -1) (_.IF_ICMPEQ @not-found) lux-intI runtimeT.someI (_.GOTO @end) (_.label @not-found) _.POP runtimeT.noneI (_.label @end)))) ## [[IO]] (def: string-method $.Method ($t.method (list $String) #.None (list))) (def: (io//log messageI) Unary (|>> (_.GETSTATIC "java.lang.System" "out" ($t.class "java.io.PrintStream" (list))) messageI (_.CHECKCAST "java.lang.String") (_.INVOKEVIRTUAL "java.io.PrintStream" "println" string-method #0) unitI)) (def: (io//error messageI) Unary (|>> (_.NEW "java.lang.Error") _.DUP messageI (_.CHECKCAST "java.lang.String") (_.INVOKESPECIAL "java.lang.Error" "" string-method #0) _.ATHROW)) (def: (io//exit codeI) Unary (|>> codeI jvm-intI (_.INVOKESTATIC "java.lang.System" "exit" ($t.method (list $t.int) #.None (list)) #0) _.NULL)) (def: (io//current-time []) Nullary (|>> (_.INVOKESTATIC "java.lang.System" "currentTimeMillis" ($t.method (list) (#.Some $t.long) (list)) #0) (_.wrap #$.Long))) ## [[Box]] (def: empty-boxI $.Inst (|>> (_.int 1) (_.ANEWARRAY ($t.binary-name "java.lang.Object")))) (def: check-boxI $.Inst (_.CHECKCAST ($t.descriptor $Object-Array))) (def: (box//new initI) Unary (|>> empty-boxI _.DUP (_.int 0) initI _.AASTORE)) (def: (box//read boxI) Unary (|>> boxI check-boxI (_.int 0) _.AALOAD)) (def: (box//write [valueI boxI]) Binary (|>> boxI check-boxI (_.int 0) valueI _.AASTORE unitI)) ## [[Processes]] (def: (process//parallelism-level []) Nullary (|>> (_.INVOKESTATIC "java.lang.Runtime" "getRuntime" ($t.method (list) (#.Some ($t.class "java.lang.Runtime" (list))) (list)) #0) (_.INVOKEVIRTUAL "java.lang.Runtime" "availableProcessors" ($t.method (list) (#.Some $t.int) (list)) #0) lux-intI)) (def: (process//schedule [millisecondsI procedureI]) Binary (|>> millisecondsI (_.unwrap #$.Long) procedureI (_.CHECKCAST hostL.function-class) (_.INVOKESTATIC hostL.runtime-class "schedule" ($t.method (list $t.long $Function) (#.Some $Object) (list)) #0))) ## [Bundles] (def: lux-procs Bundle (|> (dict.new text.Hash) (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 "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 "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 "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: 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: 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 io-procs) (dict.merge box-procs) (dict.merge process-procs) )))