From 88006e957373bbd72ec68897474303964885fc68 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 1 Nov 2017 13:36:15 -0400 Subject: - Minor refactorings. - Fixed some bugs. - Enabled macro-expansion for statements. --- new-luxc/source/luxc/eval.lux | 2 +- new-luxc/source/luxc/host/macro.lux | 37 ++++++++++++ new-luxc/source/luxc/lang/analysis/case.lux | 2 +- new-luxc/source/luxc/lang/analysis/expression.lux | 32 +---------- new-luxc/source/luxc/lang/synthesis/case.lux | 17 ++++-- new-luxc/source/luxc/lang/synthesis/expression.lux | 58 +++++++++---------- new-luxc/source/luxc/lang/translation.lux | 60 ++++++++++++-------- new-luxc/source/luxc/lang/translation/case.jvm.lux | 32 +++++------ .../luxc/lang/translation/expression.jvm.lux | 38 ++++++------- .../source/luxc/lang/translation/function.jvm.lux | 14 ++--- .../source/luxc/lang/translation/primitive.jvm.lux | 14 ++--- .../source/luxc/lang/translation/procedure.jvm.lux | 4 +- .../luxc/lang/translation/procedure/common.jvm.lux | 6 +- .../luxc/lang/translation/procedure/host.jvm.lux | 66 +++++++++++----------- .../source/luxc/lang/translation/reference.jvm.lux | 6 +- .../source/luxc/lang/translation/runtime.jvm.lux | 16 +++--- .../source/luxc/lang/translation/statement.jvm.lux | 4 +- .../source/luxc/lang/translation/structure.jvm.lux | 10 ++-- 18 files changed, 222 insertions(+), 196 deletions(-) create mode 100644 new-luxc/source/luxc/host/macro.lux (limited to 'new-luxc/source') diff --git a/new-luxc/source/luxc/eval.lux b/new-luxc/source/luxc/eval.lux index 82c355151..6431b59d6 100644 --- a/new-luxc/source/luxc/eval.lux +++ b/new-luxc/source/luxc/eval.lux @@ -14,5 +14,5 @@ [exprA (../base;with-expected-type type (expressionA;analyser eval exprC)) #let [exprS (expressionS;synthesize exprA)] - exprI (expressionT;generate exprS)] + exprI (expressionT;translate exprS)] (evalT;eval exprI))) diff --git a/new-luxc/source/luxc/host/macro.lux b/new-luxc/source/luxc/host/macro.lux new file mode 100644 index 000000000..1a3152222 --- /dev/null +++ b/new-luxc/source/luxc/host/macro.lux @@ -0,0 +1,37 @@ +(;module: + lux + (lux (control [monad #+ do]) + (data ["e" error]) + [meta] + [host]) + (luxc [";L" host] + (lang (translation [";T" common])))) + +(for {"JVM" (as-is (host;import java.lang.reflect.Method + (invoke [Object (Array Object)] #try Object)) + (host;import (java.lang.Class c) + (getMethod [String (Array (Class Object))] #try Method)) + (host;import java.lang.Object + (getClass [] (Class Object)) + (toString [] String)) + (def: _object-class (Class Object) (host;class-for Object)) + (def: _apply-args + (Array (Class Object)) + (|> (host;array (Class Object) +2) + (host;array-write +0 _object-class) + (host;array-write +1 _object-class))) + (def: #export (expand macro inputs) + (-> Macro (List Code) (Meta (List Code))) + (do meta;Monad + [class (commonT;load-class hostL;function-class)] + (function [compiler] + (do e;Monad + [apply-method (Class.getMethod ["apply" _apply-args] class) + output (Method.invoke [(:! Object macro) + (|> (host;array Object +2) + (host;array-write +0 (:! Object inputs)) + (host;array-write +1 (:! Object compiler)))] + apply-method)] + (:! (e;Error [Compiler (List Code)]) + output)))))) + }) diff --git a/new-luxc/source/luxc/lang/analysis/case.lux b/new-luxc/source/luxc/lang/analysis/case.lux index 1e40e38f1..f68733d7f 100644 --- a/new-luxc/source/luxc/lang/analysis/case.lux +++ b/new-luxc/source/luxc/lang/analysis/case.lux @@ -165,7 +165,7 @@ (do @ [nextA next] (wrap [(list) nextA])) - matches)] + (list;reverse matches))] (wrap [(` ("lux case tuple" [(~@ memberP+)])) thenA]))) diff --git a/new-luxc/source/luxc/lang/analysis/expression.lux b/new-luxc/source/luxc/lang/analysis/expression.lux index de0e49dbc..12256a4bf 100644 --- a/new-luxc/source/luxc/lang/analysis/expression.lux +++ b/new-luxc/source/luxc/lang/analysis/expression.lux @@ -11,6 +11,7 @@ [host]) (luxc ["&" base] [";L" host] + (host [";H" macro]) (lang ["la" analysis] (translation [";T" common])) ["&;" module]) @@ -21,35 +22,6 @@ [";A" structure] [";A" procedure])) -(for {"JVM" (as-is (host;import java.lang.reflect.Method - (invoke [Object (Array Object)] #try Object)) - (host;import (java.lang.Class c) - (getMethod [String (Array (Class Object))] #try Method)) - (host;import java.lang.Object - (getClass [] (Class Object)) - (toString [] String)) - (def: _object-class (Class Object) (host;class-for Object)) - (def: _apply-args - (Array (Class Object)) - (|> (host;array (Class Object) +2) - (host;array-write +0 _object-class) - (host;array-write +1 _object-class))) - (def: (call-macro macro inputs) - (-> Macro (List Code) (Meta (List Code))) - (do meta;Monad - [class (commonT;load-class hostL;function-class)] - (function [compiler] - (do e;Monad - [apply-method (Class.getMethod ["apply" _apply-args] class) - output (Method.invoke [(:! Object macro) - (|> (host;array Object +2) - (host;array-write +0 (:! Object inputs)) - (host;array-write +1 (:! Object compiler)))] - apply-method)] - (:! (e;Error [Compiler (List Code)]) - output)))))) - }) - (exception: #export Macro-Expression-Must-Have-Single-Expansion) (exception: #export Unrecognized-Syntax) @@ -119,7 +91,7 @@ (if (meta;macro? def-anns) (do @ [expansion (function [compiler] - (case (call-macro (:! Macro def-value) args compiler) + (case (macroH;expand (:! Macro def-value) args compiler) (#e;Success [compiler' output]) (#e;Success [compiler' output]) diff --git a/new-luxc/source/luxc/lang/synthesis/case.lux b/new-luxc/source/luxc/lang/synthesis/case.lux index 15cb6eca3..e66bbf3a8 100644 --- a/new-luxc/source/luxc/lang/synthesis/case.lux +++ b/new-luxc/source/luxc/lang/synthesis/case.lux @@ -2,6 +2,7 @@ lux (lux (data [bool "bool/" Eq] [text "text/" Eq] + text/format [number] (coll [list "list/" Fold])) (meta [code "code/" Eq])) @@ -11,7 +12,7 @@ (def: #export (path pattern) (-> la;Pattern ls;Path) (case pattern - (^code [(~@ membersP)]) + (^code ("lux case tuple" [(~@ membersP)])) (case (list;reverse membersP) #;Nil (' ("lux case pop")) @@ -30,12 +31,16 @@ [(n.dec last-idx) (` ("lux case tuple right" (~ (code;nat last-idx)) (~ (path lastP))))] prevsP)] - tuple-path)) + (` ("lux case seq" + (~ tuple-path) + ("lux case pop"))))) - (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) - (if (n.= (n.dec num-tags) tag) - (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP)))) - (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP))))) + (^code ("lux case variant" (~ [_ (#;Nat tag)]) (~ [_ (#;Nat num-tags)]) (~ memberP))) + (` ("lux case seq" + (~ (if (n.= (n.dec num-tags) tag) + (` ("lux case variant right" (~ (code;nat tag)) (~ (path memberP)))) + (` ("lux case variant left" (~ (code;nat tag)) (~ (path memberP)))))) + ("lux case pop"))) _ pattern)) diff --git a/new-luxc/source/luxc/lang/synthesis/expression.lux b/new-luxc/source/luxc/lang/synthesis/expression.lux index 05b99923b..531606ba7 100644 --- a/new-luxc/source/luxc/lang/synthesis/expression.lux +++ b/new-luxc/source/luxc/lang/synthesis/expression.lux @@ -85,11 +85,11 @@ (|> (synthesize expr) (~) ("lux case exec") ("lux case seq" (~ (caseS;path pattern))) - (`))))] - (` ("lux case" (~ inputS) - (~ (list/fold caseS;weave - (transform-branch lastP lastA) - (list/map (product;uncurry transform-branch) prevsPA)))))) + (`)))) + pathS (list/fold caseS;weave + (transform-branch lastP lastA) + (list/map (product;uncurry transform-branch) prevsPA))] + (` ("lux case" (~ inputS) (~ pathS)))) _ (undefined) @@ -117,46 +117,42 @@ _ (call$ funcS argsS)))) -(def: #export (synthesize analysis) +(def: #export (synthesize expressionA) (-> la;Analysis ls;Synthesis) (loop [outer-arity +0 resolver init-resolver num-locals +0 - exprA analysis] - (case exprA + expressionA expressionA] + (case expressionA (^code [(~ _left) (~ _right)]) - (` [(~@ (list/map (recur +0 resolver num-locals) (la;unfold-tuple exprA)))]) + (` [(~@ (list/map (recur outer-arity resolver num-locals) (la;unfold-tuple expressionA)))]) (^or (^code ("lux sum left" (~ _))) (^code ("lux sum right" (~ _)))) - (let [[tag last? value] (maybe;assume (la;unfold-variant exprA))] - (variant$ tag last? (recur +0 resolver num-locals value))) + (let [[tag last? value] (maybe;assume (la;unfold-variant expressionA))] + (variant$ tag last? (recur outer-arity resolver num-locals value))) (^code ((~ [_ (#;Int var)]))) (if (variableL;local? var) - (let [register (variableL;local-register var)] - (if (functionS;nested? outer-arity) - (if (n.= +0 register) - (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) - (list/map (|>. variableL;local code;int (~) () (`))))) - (var$ (functionS;adjust-var outer-arity (variableL;local register)))) - (var$ (variableL;local register)))) - (let [register (variableL;captured-register var)] - (var$ (let [var (variableL;captured register)] - (maybe;default var (dict;get var resolver)))))) + (if (functionS;nested? outer-arity) + (if (variableL;self? var) + (call$ (var$ 0) (|> (list;n.range +1 (n.dec outer-arity)) + (list/map (|>. variableL;local code;int (~) () (`))))) + (var$ (functionS;adjust-var outer-arity var))) + (var$ var)) + (var$ (maybe;default var (dict;get var resolver)))) (^code ("lux case" (~ inputA) (~ [_ (#;Record branchesA)]))) - (synthesize-case (recur +0 resolver num-locals) inputA branchesA) + (synthesize-case (recur outer-arity resolver num-locals) inputA branchesA) (^multi (^code ("lux function" [(~@ scope)] (~ bodyA))) [(s;run scope (p;some s;int)) (#e;Success raw-env)]) (let [inner-arity (n.inc outer-arity) env (list/map (function [var] (maybe;default var (dict;get var resolver))) raw-env) - env-vars (let [env-size (list;size raw-env)] - (: (List Variable) - (case env-size - +0 (list) - _ (list/map variableL;captured (list;n.range +0 (n.dec env-size)))))) + env-vars (: (List Variable) + (case raw-env + #;Nil (list) + _ (|> (list;size raw-env) n.dec (list;n.range +0) (list/map variableL;captured)))) resolver' (if (functionS;nested? inner-arity) (list/fold (function [[from to] resolver'] (dict;put from to resolver')) @@ -166,7 +162,7 @@ (dict;put var var resolver')) init-resolver env-vars))] - (case (recur inner-arity resolver' +0 bodyA) + (case (recur inner-arity resolver' num-locals bodyA) (^ [_ (#;Form (list [_ (#;Text "lux function")] [_ (#;Nat arity')] env' bodyS'))]) (let [arity (n.inc arity')] (function$ arity env (prepare-body inner-arity arity bodyS'))) @@ -175,10 +171,10 @@ (function$ +1 env (prepare-body inner-arity +1 bodyS)))) (^code ("lux apply" (~@ _))) - (synthesize-apply synthesize outer-arity num-locals exprA) + (synthesize-apply (recur outer-arity resolver num-locals) outer-arity num-locals expressionA) (^code ((~ [_ (#;Text name)]) (~@ args))) - (procedure$ name (list/map (recur +0 resolver num-locals) args)) + (procedure$ name (list/map (recur outer-arity resolver num-locals) args)) _ - exprA))) + expressionA))) diff --git a/new-luxc/source/luxc/lang/translation.lux b/new-luxc/source/luxc/lang/translation.lux index 4fcc3ccb2..60fbde6c8 100644 --- a/new-luxc/source/luxc/lang/translation.lux +++ b/new-luxc/source/luxc/lang/translation.lux @@ -1,6 +1,7 @@ (;module: lux - (lux (control [monad #+ do]) + (lux (control [monad #+ do] + ["ex" exception #+ exception:]) (concurrency ["T" task]) (data ["e" error] [text "text/" Hash] @@ -12,6 +13,7 @@ (world [file #+ File])) (luxc ["&" base] [";L" host] + (host [";H" macro]) ["&;" io] ["&;" module] ["&;" eval] @@ -30,18 +32,17 @@ (&;Analyser) (expressionA;analyser &eval;eval)) -(def: (generate code) +(exception: #export Unrecognized-Statement) + +(def: (translate code) (-> Code (Meta Unit)) (case code - (^ [_ (#;Form (list [_ (#;Text "lux def")] - [_ (#;Symbol ["" def-name])] - valueC - metaC))]) + (^code ("lux def" (~ [_ (#;Symbol ["" def-name])]) (~ valueC) (~ metaC))) (do meta;Monad [[_ metaA] (&;with-scope (&;with-expected-type Code (analyse metaC))) - metaI (expressionT;generate (expressionS;synthesize metaA)) + metaI (expressionT;translate (expressionS;synthesize metaA)) metaV (evalT;eval metaI) [_ valueT valueA] (&;with-scope (if (meta;type? (:! Code metaV)) @@ -51,23 +52,38 @@ (wrap [Type valueA]))) (commonA;with-unknown-type (analyse valueC)))) - valueI (expressionT;generate (expressionS;synthesize valueA)) + valueI (expressionT;translate (expressionS;synthesize valueA)) _ (&;with-scope - (statementT;generate-def def-name valueT valueI metaI (:! Code metaV)))] + (statementT;translate-def def-name valueT valueI metaI (:! Code metaV)))] (wrap [])) - (^ [_ (#;Form (list [_ (#;Text "lux program")] - [_ (#;Symbol ["" program-args])] - programC))]) + (^code ("lux program" (~ [_ (#;Symbol ["" program-args])]) (~ programC))) (do meta;Monad [[_ programA] (&;with-scope (&;with-expected-type (type (io;IO Unit)) (analyse programC))) - programI (expressionT;generate (expressionS;synthesize programA))] - (statementT;generate-program program-args programI)) + programI (expressionT;translate (expressionS;synthesize programA))] + (statementT;translate-program program-args programI)) + + (^code ((~ [_ (#;Symbol macro-name)]) (~@ args))) + (do meta;Monad + [macro-name (meta;normalize macro-name) + [def-type def-anns def-value] (meta;find-def macro-name)] + (if (meta;macro? def-anns) + (do @ + [expansion (function [compiler] + (case (macroH;expand (:! Macro def-value) args compiler) + (#e;Success [compiler' output]) + (#e;Success [compiler' output]) + + (#e;Error error) + ((&;fail error) compiler))) + _ (monad;map @ translate expansion)] + (wrap [])) + (&;throw Unrecognized-Statement (%code code)))) _ - (&;fail (format "Unrecognized statement: " (%code code))))) + (&;throw Unrecognized-Statement (%code code)))) (def: (exhaust action) (All [a] (-> (Meta a) (Meta Unit))) @@ -97,7 +113,7 @@ (#e;Success [(set@ #;source source' compiler) output])))) -(def: (generate-module source-dirs module-name target-dir compiler) +(def: (translate-module source-dirs module-name target-dir compiler) (-> (List File) Text File Compiler (T;Task Compiler)) (do T;Monad [_ (&io;prepare-module target-dir module-name) @@ -115,9 +131,9 @@ [code parse #let [[cursor _] code]] (&;with-cursor cursor - (generate code)))))))] + (translate code)))))))] (wrap artifacts) - ## (&module;generate-descriptor module-name) + ## (&module;translate-descriptor module-name) )) (#e;Success [compiler artifacts ## module-descriptor ]) @@ -159,10 +175,10 @@ #;scope-type-vars (list) #;host (:! Void host)}) -(def: #export (generate-program program target sources) +(def: #export (translate-program program target sources) (-> Text File (List File) (T;Task Unit)) (do T;Monad - [compiler (|> (case (runtimeT;generate (init-compiler (io;run hostL;init-host))) + [compiler (|> (case (runtimeT;translate (init-compiler (io;run hostL;init-host))) (#e;Error error) (T;fail error) @@ -173,7 +189,7 @@ _ (&io;write-file target hostL;function-class function-bc)] (wrap compiler))) (: (T;Task Compiler)) - (:: @ map (generate-module sources prelude target)) (:: @ join) - (:: @ map (generate-module sources program target)) (:: @ join)) + (:: @ map (translate-module sources prelude target)) (:: @ join) + (:: @ map (translate-module sources program target)) (:: @ join)) #let [_ (log! "Compilation complete!")]] (wrap []))) diff --git a/new-luxc/source/luxc/lang/translation/case.jvm.lux b/new-luxc/source/luxc/lang/translation/case.jvm.lux index a9ea4482a..3858627ff 100644 --- a/new-luxc/source/luxc/lang/translation/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/case.jvm.lux @@ -54,13 +54,13 @@ (exception: #export Unrecognized-Path) -(def: (generate-path' generate stack-depth @else @end path) +(def: (translate-path' translate stack-depth @else @end path) (-> (-> ls;Synthesis (Meta $;Inst)) Nat $;Label $;Label ls;Path (Meta $;Inst)) (case path (^ [_ (#;Form (list [_ (#;Text "lux case exec")] bodyS))]) (do meta;Monad - [bodyI (generate bodyS)] + [bodyI (translate bodyS)] (wrap (|>. (pop-altI stack-depth) bodyI ($i;GOTO @end)))) @@ -111,7 +111,7 @@ (^template [ ] (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))]) (do meta;Monad - [subI (generate-path' generate stack-depth @else @end subP)] + [subI (translate-path' translate stack-depth @else @end subP)] (wrap (case idx +0 (|>. peekI @@ -139,7 +139,7 @@ (^template [ ] (^ [_ (#;Form (list [_ (#;Text )] [_ (#;Nat idx)] subP))]) (do meta;Monad - [subI (generate-path' generate stack-depth @else @end subP)] + [subI (translate-path' translate stack-depth @else @end subP)] (wrap (<| $i;with-label (function [@success]) $i;with-label (function [@fail]) (|>. peekI @@ -165,16 +165,16 @@ (^ [_ (#;Form (list [_ (#;Text "lux case seq")] leftP rightP))]) (do meta;Monad - [leftI (generate-path' generate stack-depth @else @end leftP) - rightI (generate-path' generate stack-depth @else @end rightP)] + [leftI (translate-path' translate stack-depth @else @end leftP) + rightI (translate-path' translate stack-depth @else @end rightP)] (wrap (|>. leftI rightI))) (^ [_ (#;Form (list [_ (#;Text "lux case alt")] leftP rightP))]) (do meta;Monad [@alt-else $i;make-label - leftI (generate-path' generate (n.inc stack-depth) @alt-else @end leftP) - rightI (generate-path' generate stack-depth @else @end rightP)] + leftI (translate-path' translate (n.inc stack-depth) @alt-else @end leftP) + rightI (translate-path' translate stack-depth @else @end rightP)] (wrap (|>. $i;DUP leftI ($i;label @alt-else) @@ -184,12 +184,12 @@ _ (_;throw Unrecognized-Path (%code path)))) -(def: (generate-path generate path @end) +(def: (translate-path translate path @end) (-> (-> ls;Synthesis (Meta $;Inst)) ls;Path $;Label (Meta $;Inst)) (do meta;Monad [@else $i;make-label - pathI (generate-path' generate +1 @else @end path)] + pathI (translate-path' translate +1 @else @end path)] (wrap (|>. pathI ($i;label @else) $i;POP @@ -200,13 +200,13 @@ $i;NULL ($i;GOTO @end))))) -(def: #export (generate-case generate valueS path) +(def: #export (translate-case translate valueS path) (-> (-> ls;Synthesis (Meta $;Inst)) ls;Synthesis ls;Path (Meta $;Inst)) (do meta;Monad [@end $i;make-label - valueI (generate valueS) - pathI (generate-path generate path @end)] + valueI (translate valueS) + pathI (translate-path translate path @end)] (wrap (|>. valueI $i;NULL $i;SWAP @@ -214,12 +214,12 @@ pathI ($i;label @end))))) -(def: #export (generate-let generate register inputS exprS) +(def: #export (translate-let translate register inputS exprS) (-> (-> ls;Synthesis (Meta $;Inst)) Nat ls;Synthesis ls;Synthesis (Meta $;Inst)) (do meta;Monad - [inputI (generate inputS) - exprI (generate exprS)] + [inputI (translate inputS) + exprI (translate exprS)] (wrap (|>. inputI ($i;ASTORE register) exprI)))) diff --git a/new-luxc/source/luxc/lang/translation/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/expression.jvm.lux index af66d4994..81cdc1261 100644 --- a/new-luxc/source/luxc/lang/translation/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/expression.jvm.lux @@ -22,54 +22,54 @@ (exception: #export Unrecognized-Synthesis) -(def: #export (generate synthesis) +(def: #export (translate synthesis) (-> ls;Synthesis (Meta $;Inst)) (case synthesis (^code []) - primitiveT;generate-unit + primitiveT;translate-unit (^code [(~ singleton)]) - (generate singleton) + (translate singleton) (^template [ ] [_ ( value)] ( value)) - ([#;Bool primitiveT;generate-bool] - [#;Nat primitiveT;generate-nat] - [#;Int primitiveT;generate-int] - [#;Deg primitiveT;generate-deg] - [#;Frac primitiveT;generate-frac] - [#;Text primitiveT;generate-text]) + ([#;Bool primitiveT;translate-bool] + [#;Nat primitiveT;translate-nat] + [#;Int primitiveT;translate-int] + [#;Deg primitiveT;translate-deg] + [#;Frac primitiveT;translate-frac] + [#;Text primitiveT;translate-text]) (^code ((~ [_ (#;Nat tag)]) (~ [_ (#;Bool last?)]) (~ valueS))) - (structureT;generate-variant generate tag last? valueS) + (structureT;translate-variant translate tag last? valueS) (^code [(~@ members)]) - (structureT;generate-tuple generate members) + (structureT;translate-tuple translate members) (^ [_ (#;Form (list [_ (#;Int var)]))]) (if (variableL;captured? var) - (referenceT;generate-captured var) - (referenceT;generate-variable var)) + (referenceT;translate-captured var) + (referenceT;translate-variable var)) [_ (#;Symbol definition)] - (referenceT;generate-definition definition) + (referenceT;translate-definition definition) (^code ("lux let" (~ [_ (#;Nat register)]) (~ inputS) (~ exprS))) - (caseT;generate-let generate register inputS exprS) + (caseT;translate-let translate register inputS exprS) (^code ("lux case" (~ inputS) (~ pathPS))) - (caseT;generate-case generate inputS pathPS) + (caseT;translate-case translate inputS pathPS) (^multi (^code ("lux function" (~ [_ (#;Nat arity)]) [(~@ environment)] (~ bodyS))) [(s;run environment (p;some s;int)) (#e;Success environment)]) - (functionT;generate-function generate environment arity bodyS) + (functionT;translate-function translate environment arity bodyS) (^code ("lux call" (~ functionS) (~@ argsS))) - (functionT;generate-call generate functionS argsS) + (functionT;translate-call translate functionS argsS) (^code ((~ [_ (#;Text procedure)]) (~@ argsS))) - (procedureT;generate-procedure generate procedure argsS) + (procedureT;translate-procedure translate procedure argsS) _ (&;throw Unrecognized-Synthesis (%code synthesis)) diff --git a/new-luxc/source/luxc/lang/translation/function.jvm.lux b/new-luxc/source/luxc/lang/translation/function.jvm.lux index 35c88e4ed..ebdb28853 100644 --- a/new-luxc/source/luxc/lang/translation/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/function.jvm.lux @@ -266,13 +266,13 @@ $i;ARETURN )))) -(def: #export (with-function generate class env arity body) +(def: #export (with-function translate class env arity body) (-> (-> ls;Synthesis (Meta $;Inst)) Text (List Variable) ls;Arity ls;Synthesis (Meta [$;Def $;Inst])) (do meta;Monad [@begin $i;make-label - bodyI (commonT;with-function class (generate body)) + bodyI (commonT;with-function class (translate body)) #let [env-size (list;size env) applyD (: $;Def (if (poly-arg? arity) @@ -295,13 +295,13 @@ instanceI (instance class arity env)]] (wrap [functionD instanceI]))) -(def: #export (generate-function generate env arity body) +(def: #export (translate-function translate env arity body) (-> (-> ls;Synthesis (Meta $;Inst)) (List Variable) ls;Arity ls;Synthesis (Meta $;Inst)) (do meta;Monad [function-class (:: @ map %code (meta;gensym "function")) - [functionD instanceI] (with-function generate function-class env arity body) + [functionD instanceI] (with-function translate function-class env arity body) _ (commonT;store-class function-class ($d;class #$;V1.6 #$;Public $;finalC function-class (list) @@ -316,13 +316,13 @@ (list pre) (list& pre (segment size post))))) -(def: #export (generate-call generate functionS argsS) +(def: #export (translate-call translate functionS argsS) (-> (-> ls;Synthesis (Meta $;Inst)) ls;Synthesis (List ls;Synthesis) (Meta $;Inst)) (do meta;Monad - [functionI (generate functionS) - argsI (monad;map @ generate argsS) + [functionI (translate functionS) + argsI (monad;map @ translate argsS) #let [applyI (|> (segment runtimeT;num-apply-variants argsI) (list/map (function [chunkI+] (|>. ($i;CHECKCAST hostL;function-class) diff --git a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux index 72b5f4e9d..f795a2980 100644 --- a/new-luxc/source/luxc/lang/translation/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/primitive.jvm.lux @@ -13,11 +13,11 @@ (translation [";T" common]))) [../runtime]) -(def: #export generate-unit +(def: #export translate-unit (Meta $;Inst) (meta/wrap ($i;string hostL;unit))) -(def: #export (generate-bool value) +(def: #export (translate-bool value) (-> Bool (Meta $;Inst)) (meta/wrap ($i;GETSTATIC "java.lang.Boolean" (if value "TRUE" "FALSE") @@ -28,9 +28,9 @@ (-> (Meta $;Inst)) (meta/wrap (|>. ( value) )))] - [generate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [generate-int Int $i;long ($i;wrap #$;Long)] - [generate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)] - [generate-frac Frac $i;double ($i;wrap #$;Double)] - [generate-text Text $i;string id] + [translate-nat Nat (|>. (:! Int) $i;long) ($i;wrap #$;Long)] + [translate-int Int $i;long ($i;wrap #$;Long)] + [translate-deg Deg (|>. (:! Int) $i;long) ($i;wrap #$;Long)] + [translate-frac Frac $i;double ($i;wrap #$;Double)] + [translate-text Text $i;string id] ) diff --git a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux index 973f0e968..d74b559cf 100644 --- a/new-luxc/source/luxc/lang/translation/procedure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure.jvm.lux @@ -15,10 +15,10 @@ (|> ./common;procedures (dict;merge ./host;procedures))) -(def: #export (generate-procedure generate name args) +(def: #export (translate-procedure translate name args) (-> (-> ls;Synthesis (Meta $;Inst)) Text (List ls;Synthesis) (Meta $;Inst)) (<| (maybe;default (&;fail (format "Unknown procedure: " (%t name)))) (do maybe;Monad [proc (dict;get name procedures)] - (wrap (proc generate args))))) + (wrap (proc translate args))))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux index 80becb058..8c7668383 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/common.jvm.lux @@ -74,20 +74,20 @@ " 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] + (with-gensyms [g!proc g!name g!translate 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)] + (function [(~ g!translate) (~ g!inputs)] (case (~ g!inputs) (^ (list (~@ g!input+))) (do meta;Monad [(~@ (|> g!input+ (list/map (function [g!input] - (list g!input (` ((~ g!generate) (~ g!input)))))) + (list g!input (` ((~ g!translate) (~ g!input)))))) list;concat))] ((~' wrap) ((~ g!proc) [(~@ g!input+)]))) diff --git a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux index c222e42cf..7168514c1 100644 --- a/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/procedure/host.jvm.lux @@ -273,12 +273,12 @@ $i;I2L ($i;wrap #$;Long))) -(def: (array//new proc generate inputs) +(def: (array//new proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Nat level)] [_ (#;Text class)] lengthS)) (do meta;Monad - [lengthI (generate lengthS) + [lengthI (translate lengthS) #let [arrayJT ($t;array level (case class "boolean" $t;boolean "byte" $t;byte @@ -297,13 +297,13 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) -(def: (array//read proc generate inputs) +(def: (array//read proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] idxS arrayS)) (do meta;Monad - [arrayI (generate arrayS) - idxI (generate idxS) + [arrayI (translate arrayS) + idxI (translate idxS) #let [loadI (case class "boolean" (|>. $i;BALOAD ($i;wrap #$;Boolean)) "byte" (|>. $i;BALOAD ($i;wrap #$;Byte)) @@ -323,14 +323,14 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) -(def: (array//write proc generate inputs) +(def: (array//write proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] idxS valueS arrayS)) (do meta;Monad - [arrayI (generate arrayS) - idxI (generate idxS) - valueI (generate valueS) + [arrayI (translate arrayS) + idxI (translate idxS) + valueI (translate valueS) #let [storeI (case class "boolean" (|>. ($i;unwrap #$;Boolean) $i;BASTORE) "byte" (|>. ($i;unwrap #$;Byte) $i;BASTORE) @@ -392,7 +392,7 @@ (|>. exceptionI $i;ATHROW)) -(def: (object//class proc generate inputs) +(def: (object//class proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)])) @@ -408,12 +408,12 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) -(def: (object//instance? proc generate inputs) +(def: (object//instance? proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] objectS)) (do meta;Monad - [objectI (generate objectS)] + [objectI (translate objectS)] (wrap (|>. objectI ($i;INSTANCEOF class) ($i;wrap #$;Boolean)))) @@ -445,7 +445,7 @@ ["char" #$;Char]) (dict;from-list text;Hash))) -(def: (static//get proc generate inputs) +(def: (static//get proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)])) @@ -472,12 +472,12 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) -(def: (static//put proc generate inputs) +(def: (static//put proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS)) (do meta;Monad - [valueI (generate valueS)] + [valueI (translate valueS)] (case (dict;get unboxed primitives) (#;Some primitive) (let [primitive (case unboxed @@ -504,12 +504,12 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) -(def: (virtual//get proc generate inputs) +(def: (virtual//get proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] objectS)) (do meta;Monad - [objectI (generate objectS)] + [objectI (translate objectS)] (case (dict;get unboxed primitives) (#;Some primitive) (let [primitive (case unboxed @@ -535,13 +535,13 @@ _ (&;fail (format "Wrong syntax for '" proc "'.")))) -(def: (virtual//put proc generate inputs) +(def: (virtual//put proc translate inputs) (-> Text @;Proc) (case inputs (^ (list [_ (#;Text class)] [_ (#;Text field)] [_ (#;Text unboxed)] valueS objectS)) (do meta;Monad - [valueI (generate valueS) - objectI (generate objectS)] + [valueI (translate valueS) + objectI (translate objectS)] (case (dict;get unboxed primitives) (#;Some primitive) (let [primitive (case unboxed @@ -597,7 +597,7 @@ nesting (p;some (l;this "[]"))] (wrap ($t;array (list;size nesting) raw)))) -(def: (generate-type argD) +(def: (translate-type argD) (-> Text (Meta $;Type)) (case (l;run argD java-type) (#e;Error error) @@ -623,7 +623,7 @@ _ (|>. inputI ($i;CHECKCAST ($t;descriptor inputT))))) -(def: (generate-args generate argsS) +(def: (translate-args translate argsS) (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta (List [$;Type $;Inst]))) (case argsS @@ -632,9 +632,9 @@ (^ (list& [_ (#;Tuple (list [_ (#;Text argD)] argS))] tail)) (do meta;Monad - [argT (generate-type argD) - argI (:: @ map (prepare-input argT) (generate argS)) - =tail (generate-args generate tail)] + [argT (translate-type argD) + argI (:: @ map (prepare-input argT) (translate argS)) + =tail (translate-args translate tail)] (wrap (list& [argT argI] =tail))) _ @@ -647,7 +647,7 @@ (meta/wrap #;None) _ - (:: meta;Monad map (|>. #;Some) (generate-type description)))) + (:: meta;Monad map (|>. #;Some) (translate-type description)))) (def: (prepare-return returnT returnI) (-> (Maybe $;Type) $;Inst $;Inst) @@ -664,13 +664,13 @@ _ returnI))) -(def: (invoke//static proc generate inputs) +(def: (invoke//static proc translate inputs) (-> Text @;Proc) (case inputs (^ (list& [_ (#;Text class)] [_ (#;Text method)] [_ (#;Text unboxed)] argsS)) (do meta;Monad - [argsTI (generate-args generate argsS) + [argsTI (translate-args translate argsS) returnT (method-return-type unboxed) #let [callI (|>. ($i;fuse (list/map product;right argsTI)) ($i;INVOKESTATIC class method @@ -682,14 +682,14 @@ (&;fail (format "Wrong syntax for '" proc "'.")))) (do-template [ ] - [(def: ( proc generate inputs) + [(def: ( proc translate inputs) (-> Text @;Proc) (case inputs (^ (list& [_ (#;Text class)] [_ (#;Text method)] [_ (#;Text unboxed)] objectS argsS)) (do meta;Monad - [objectI (generate objectS) - argsTI (generate-args generate argsS) + [objectI (translate objectS) + argsTI (translate-args translate argsS) returnT (method-return-type unboxed) #let [callI (|>. objectI ($i;CHECKCAST class) @@ -707,12 +707,12 @@ [invoke//interface $i;INVOKEINTERFACE true] ) -(def: (invoke//constructor proc generate inputs) +(def: (invoke//constructor proc translate inputs) (-> Text @;Proc) (case inputs (^ (list& [_ (#;Text class)] argsS)) (do meta;Monad - [argsTI (generate-args generate argsS)] + [argsTI (translate-args translate argsS)] (wrap (|>. ($i;NEW class) $i;DUP ($i;fuse (list/map product;right argsTI)) diff --git a/new-luxc/source/luxc/lang/translation/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/reference.jvm.lux index 7c42f9f08..da86dd5b9 100644 --- a/new-luxc/source/luxc/lang/translation/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/reference.jvm.lux @@ -12,7 +12,7 @@ (translation [";T" common] [";T" function])))) -(def: #export (generate-captured variable) +(def: #export (translate-captured variable) (-> Variable (Meta $;Inst)) (do meta;Monad [function-class commonT;function] @@ -21,11 +21,11 @@ (|> variable i.inc (i.* -1) int-to-nat functionT;captured) commonT;$Object))))) -(def: #export (generate-variable variable) +(def: #export (translate-variable variable) (-> Variable (Meta $;Inst)) (meta/wrap ($i;ALOAD (int-to-nat variable)))) -(def: #export (generate-definition [def-module def-name]) +(def: #export (translate-definition [def-module def-name]) (-> Ident (Meta $;Inst)) (let [bytecode-name (format def-module "/" (&;normalize-name def-name))] (meta/wrap ($i;GETSTATIC bytecode-name commonT;value-field commonT;$Object)))) diff --git a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux index e5d237fc7..0a330ab73 100644 --- a/new-luxc/source/luxc/lang/translation/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/runtime.jvm.lux @@ -449,7 +449,7 @@ $i;ARETURN) update-tagI (|>. $i;ISUB ($i;ISTORE +1)) update-variantI (|>. ($i;ALOAD +0) datumI ($i;CHECKCAST ($t;descriptor $Variant)) ($i;ASTORE +0)) - wrongI (|>. $i;NULL $i;ARETURN) + failureI (|>. $i;NULL $i;ARETURN) return-datumI (|>. ($i;ALOAD +0) datumI $i;ARETURN)]) (|>. ($i;label @begin) ($i;ILOAD +1) ## tag @@ -458,7 +458,7 @@ $i;DUP2 ($i;IF_ICMPGT @further) $i;DUP2 ($i;IF_ICMPLT @shorten) ## $i;POP2 - wrongI + failureI ($i;label @then) ## tag, sumT ($i;ALOAD +2) ## tag, sumT, wants-last? ($i;ALOAD +0) flagI ## tag, sumT, wants-last?, is-last? @@ -478,7 +478,7 @@ shortenI ($i;label @wrong) ## tag, sumT ## $i;POP2 - wrongI))) + failureI))) ($d;method #$;Public $;staticM "pm_left" ($t;method (list $Tuple $t;int) (#;Some $Object) (list)) (<| $i;with-label (function [@begin]) $i;with-label (function [@not-recursive]) @@ -555,7 +555,7 @@ $i;ARETURN))) ))) -(def: generate-runtime +(def: translate-runtime (Meta commonT;Bytecode) (do meta;Monad [_ (wrap []) @@ -569,7 +569,7 @@ _ (commonT;store-class hostL;runtime-class bytecode)] (wrap bytecode))) -(def: generate-function +(def: translate-function (Meta commonT;Bytecode) (do meta;Monad [_ (wrap []) @@ -600,9 +600,9 @@ _ (commonT;store-class hostL;function-class bytecode)] (wrap bytecode))) -(def: #export generate +(def: #export translate (Meta [commonT;Bytecode commonT;Bytecode]) (do meta;Monad - [runtime-bc generate-runtime - function-bc generate-function] + [runtime-bc translate-runtime + function-bc translate-function] (wrap [runtime-bc function-bc]))) diff --git a/new-luxc/source/luxc/lang/translation/statement.jvm.lux b/new-luxc/source/luxc/lang/translation/statement.jvm.lux index 0234d738c..feb64c293 100644 --- a/new-luxc/source/luxc/lang/translation/statement.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/statement.jvm.lux @@ -31,7 +31,7 @@ (host;import (java.lang.Class c) (getField [String] #try Field)) -(def: #export (generate-def def-name valueT valueI metaI metaV) +(def: #export (translate-def def-name valueT valueI metaI metaV) (-> Text Type $;Inst $;Inst Code (Meta Unit)) (do meta;Monad [current-module meta;current-module-name @@ -75,7 +75,7 @@ #let [_ (log! (format "DEF " current-module ";" def-name))]] (commonT;record-artifact bytecode-name bytecode))) -(def: #export (generate-program program-args programI) +(def: #export (translate-program program-args programI) (-> Text $;Inst (Meta Unit)) (do meta;Monad [] diff --git a/new-luxc/source/luxc/lang/translation/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/structure.jvm.lux index c3e07fd55..3ef03ac2c 100644 --- a/new-luxc/source/luxc/lang/translation/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/structure.jvm.lux @@ -18,17 +18,17 @@ (def: $Object $;Type ($t;class "java.lang.Object" (list))) -(def: #export (generate-tuple generate members) +(def: #export (translate-tuple translate members) (-> (-> ls;Synthesis (Meta $;Inst)) (List ls;Synthesis) (Meta $;Inst)) (do meta;Monad [#let [size (list;size members)] - _ (&;assert "Cannot generate tuples with less than 2 elements." + _ (&;assert "Cannot translate tuples with less than 2 elements." (n.>= +2 size)) membersI (|> members list;enumerate (monad;map @ (function [[idx member]] (do @ - [memberI (generate member)] + [memberI (translate member)] (wrap (|>. $i;DUP ($i;int (nat-to-int idx)) memberI @@ -44,10 +44,10 @@ ($i;string "") $i;NULL)) -(def: #export (generate-variant generate tag tail? member) +(def: #export (translate-variant translate tag tail? member) (-> (-> ls;Synthesis (Meta $;Inst)) Nat Bool ls;Synthesis (Meta $;Inst)) (do meta;Monad - [memberI (generate member)] + [memberI (translate member)] (wrap (|>. ($i;int (nat-to-int tag)) (flagI tail?) memberI -- cgit v1.2.3