diff options
Diffstat (limited to 'new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux')
-rw-r--r-- | new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux | 461 |
1 files changed, 0 insertions, 461 deletions
diff --git a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux deleted file mode 100644 index a7e9f0814..000000000 --- a/new-luxc/source/luxc/lang/translation/scheme/procedure/common.jvm.lux +++ /dev/null @@ -1,461 +0,0 @@ -(.module: - lux - (lux (control [monad #+ do] - ["ex" exception #+ exception:] - ["p" parser]) - (data ["e" error] - [text] - text/format - [number #+ hex] - (coll [list "list/" Functor<List>] - (dictionary ["dict" unordered #+ Dict]))) - [macro #+ with-gensyms] - (macro [code] - ["s" syntax #+ syntax:]) - [host]) - (luxc ["&" lang] - (lang ["la" analysis] - ["ls" synthesis] - (host ["_" scheme #+ Expression]))) - [///] - (/// [".T" runtime] - [".T" case] - [".T" function] - [".T" loop])) - -## [Types] -(type: #export Translator - (-> ls.Synthesis (Meta Expression))) - -(type: #export Proc - (-> Translator (List ls.Synthesis) (Meta Expression))) - -(type: #export Bundle - (Dict Text Proc)) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector +0 Expression) Expression)) -(type: #export Unary (-> (Vector +1 Expression) Expression)) -(type: #export Binary (-> (Vector +2 Expression) Expression)) -(type: #export Trinary (-> (Vector +3 Expression) Expression)) -(type: #export Variadic (-> (List Expression) Expression)) - -## [Utils] -(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 .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)) Expression) Expression) - (-> Text ..Proc)) - (function ((~ g!_) (~ g!name)) - (function ((~ g!_) (~ g!translate) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do macro.Monad<Meta> - [(~+ (|> 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<Meta> - [inputsI (monad.map @ translate inputsS)] - (wrap (proc inputsI)))))) - -## [Procedures] -## [[Lux]] -(def: (lux//is [leftO rightO]) - Binary - (_.eq? leftO rightO)) - -(def: (lux//if [testO thenO elseO]) - Trinary - (caseT.translate-if testO thenO elseO)) - -(def: (lux//try riskyO) - Unary - (runtimeT.lux//try riskyO)) - -(def: (lux//noop valueO) - Unary - valueO) - -(exception: #export (Wrong-Syntax {message Text}) - message) - -(def: #export (wrong-syntax procedure args) - (-> Text (List ls.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)))) - -(def: lux-procs - Bundle - (|> (dict.new text.Hash<Text>) - (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) - )) - -## [[Bits]] -(do-template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [bit//and _.bit-and] - [bit//or _.bit-or] - [bit//xor _.bit-xor] - ) - -(def: (bit//left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift (_.remainder (_.int 64) paramO) subjectO)) - -(def: (bit//arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift (|> paramO (_.remainder (_.int 64)) (_.* (_.int -1))) - subjectO)) - -(def: (bit//logical-right-shift [subjectO paramO]) - Binary - (runtimeT.bit//logical-right-shift (_.remainder (_.int 64) paramO) subjectO)) - -(def: bit-procs - Bundle - (<| (prefix "bit") - (|> (dict.new text.Hash<Text>) - (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)) - ))) - -## [[Arrays]] -(def: (array//new size0) - Unary - ((_.apply2 (_.global "make-vector")) size0 _.nil)) - -(def: (array//get [arrayO idxO]) - Binary - (runtimeT.array//get arrayO idxO)) - -(def: (array//put [arrayO idxO elemO]) - Trinary - (runtimeT.array//put arrayO idxO elemO)) - -(def: (array//remove [arrayO idxO]) - Binary - (runtimeT.array//put arrayO idxO _.nil)) - -(def: array-procs - Bundle - (<| (prefix "array") - (|> (dict.new text.Hash<Text>) - (install "new" (unary array//new)) - (install "get" (binary array//get)) - (install "put" (trinary array//put)) - (install "remove" (binary array//remove)) - (install "size" (unary (_.apply1 (_.global "vector-length")))) - ))) - -## [[Numbers]] -(host.import java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [<name> <const> <encode>] - [(def: (<name> _) - Nullary - (<encode> <const>))] - - [frac//smallest Double::MIN_VALUE _.float] - [frac//min (f/* -1.0 Double::MAX_VALUE) _.float] - [frac//max Double::MAX_VALUE _.float] - ) - -(do-template [<name> <expression>] - [(def: (<name> _) - Nullary - (_.int <expression>))] - - [int//min ("lux int min")] - [int//max ("lux int max")] - ) - -(do-template [<name> <frac>] - [(def: (<name> _) - Nullary - (_.float <frac>))] - - [frac//not-a-number number.not-a-number] - [frac//positive-infinity number.positive-infinity] - [frac//negative-infinity number.negative-infinity] - ) - -(do-template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (|> subjectO (<op> paramO)))] - - [int//add _.+] - [int//sub _.-] - [int//mul _.*] - [int//div _.quotient] - [int//rem _.remainder] - ) - -(do-template [<name> <op>] - [(def: (<name> [subjectO paramO]) - Binary - (<op> paramO subjectO))] - - [frac//add _.+] - [frac//sub _.-] - [frac//mul _.*] - [frac//div _./] - [frac//rem _.mod] - [frac//= _.=] - [frac//< _.<] - - [text//= _.string=?] - [text//< _.string<?] - ) - -(do-template [<name> <cmp>] - [(def: (<name> [subjectO paramO]) - Binary - (<cmp> paramO subjectO))] - - [int//= _.=] - [int//< _.<] - ) - -(def: int//char (|>> (_.apply1 (_.global "integer->char")) - (_.apply1 (_.global "string")))) - -(def: int-procs - Bundle - (<| (prefix "int") - (|> (dict.new text.Hash<Text>) - (install "+" (binary int//add)) - (install "-" (binary int//sub)) - (install "*" (binary int//mul)) - (install "/" (binary int//div)) - (install "%" (binary int//rem)) - (install "=" (binary int//=)) - (install "<" (binary int//<)) - (install "min" (nullary int//min)) - (install "max" (nullary int//max)) - (install "to-frac" (unary (|>> (_./ (_.float 1.0))))) - (install "char" (unary int//char))))) - -(def: frac-procs - Bundle - (<| (prefix "frac") - (|> (dict.new text.Hash<Text>) - (install "+" (binary frac//add)) - (install "-" (binary frac//sub)) - (install "*" (binary frac//mul)) - (install "/" (binary frac//div)) - (install "%" (binary frac//rem)) - (install "=" (binary frac//=)) - (install "<" (binary frac//<)) - (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 (_.apply1 (_.global "exact")))) - (install "encode" (unary (_.apply1 (_.global "number->string")))) - (install "decode" (unary runtimeT.frac//decode))))) - -## [[Text]] -(def: (text//concat [subjectO paramO]) - Binary - (_.apply (_.global "string-append") (list subjectO paramO))) - -(def: text-procs - Bundle - (<| (prefix "text") - (|> (dict.new text.Hash<Text>) - (install "=" (binary text//=)) - (install "<" (binary text//<)) - (install "concat" (binary text//concat)) - ## (install "index" (trinary text//index)) - (install "size" (unary (_.apply1 (_.global "string-length")))) - (install "hash" (unary (_.apply1 (_.global "string-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)) - ))) - -## [[Math]] -(def: (math//pow [subject param]) - Binary - ((_.apply2 (_.global "expt")) subject param)) - -(def: math-func - (-> Text (-> Expression Expression)) - (|>> _.global _.apply1)) - -(def: math-procs - Bundle - (<| (prefix "math") - (|> (dict.new text.Hash<Text>) - (install "cos" (unary (math-func "cos"))) - (install "sin" (unary (math-func "sin"))) - (install "tan" (unary (math-func "tan"))) - (install "acos" (unary (math-func "acos"))) - (install "asin" (unary (math-func "asin"))) - (install "atan" (unary (math-func "atan"))) - (install "exp" (unary (math-func "exp"))) - (install "log" (unary (math-func "log"))) - (install "ceil" (unary (math-func "ceiling"))) - (install "floor" (unary (math-func "floor"))) - (install "pow" (binary math//pow)) - ))) - -## [[IO]] -(def: (io//log input) - Unary - (_.begin (list (_.apply (_.global "display") (list input)) - (_.apply (_.global "newline") (list))))) - -(def: (void code) - (-> Expression Expression) - (_.begin (list code runtimeT.unit))) - -(def: io-procs - Bundle - (<| (prefix "io") - (|> (dict.new text.Hash<Text>) - (install "log" (unary (|>> io//log ..void))) - (install "error" (unary _.raise)) - (install "exit" (unary (_.apply1 (_.global "exit")))) - (install "current-time" (nullary (function (_ _) (runtimeT.io//current-time runtimeT.unit))))))) - -## [[Atoms]] -(def: atom//new - Unary - (|>> (list) _.vector)) - -(def: (atom//read atom) - Unary - (_.vector-ref atom (_.int 0))) - -(def: (atom//compare-and-swap [atomO oldO newO]) - Trinary - (runtimeT.atom//compare-and-swap atomO oldO newO)) - -(def: atom-procs - Bundle - (<| (prefix "atom") - (|> (dict.new text.Hash<Text>) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "compare-and-swap" (trinary atom//compare-and-swap))))) - -## [[Box]] -(def: (box//write [valueO boxO]) - Binary - (runtimeT.box//write valueO boxO)) - -(def: box-procs - Bundle - (<| (prefix "box") - (|> (dict.new text.Hash<Text>) - (install "new" (unary atom//new)) - (install "read" (unary atom//read)) - (install "write" (binary box//write))))) - -## [[Processes]] -(def: (process//parallelism-level []) - Nullary - (_.int 1)) - -(def: (process//schedule [milli-secondsO procedureO]) - Binary - (runtimeT.process//schedule milli-secondsO procedureO)) - -(def: process-procs - Bundle - (<| (prefix "process") - (|> (dict.new text.Hash<Text>) - (install "parallelism-level" (nullary process//parallelism-level)) - (install "schedule" (binary process//schedule)) - ))) - -## [Bundles] -(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) - ))) |