diff options
| -rw-r--r-- | source/lux/control/enum.lux | 2 | ||||
| -rw-r--r-- | source/lux/control/monad.lux | 1 | ||||
| -rw-r--r-- | source/lux/data/id.lux | 14 | ||||
| -rw-r--r-- | source/lux/data/list.lux | 27 | ||||
| -rw-r--r-- | source/lux/data/number/int.lux | 7 | ||||
| -rw-r--r-- | source/lux/data/number/real.lux | 7 | ||||
| -rw-r--r-- | source/lux/meta/ast.lux | 14 | ||||
| -rw-r--r-- | src/lux/compiler/lambda.clj | 69 | ||||
| -rw-r--r-- | src/lux/compiler/lux.clj | 80 | ||||
| -rw-r--r-- | src/lux/type.clj | 64 |
10 files changed, 154 insertions, 131 deletions
diff --git a/source/lux/control/enum.lux b/source/lux/control/enum.lux index 34910c837..c54eab75b 100644 --- a/source/lux/control/enum.lux +++ b/source/lux/control/enum.lux @@ -10,7 +10,7 @@ (defsig #export (Enum e) (: (Ord e) _ord) (: (-> e e) succ) - (: (-> e e) pre)) + (: (-> e e) pred)) ## [Functions] (def #export (range' <= succ from to) diff --git a/source/lux/control/monad.lux b/source/lux/control/monad.lux index 883875a03..0c7827c34 100644 --- a/source/lux/control/monad.lux +++ b/source/lux/control/monad.lux @@ -60,7 +60,6 @@ _ (` (|> (~ value) ((~ g!map) (lambda [(~ var)] (~ body'))) (~ g!join))) - ## (` (;|> (~ value) (F;map (;lambda [(~ var)] (~ body'))) (;:: ;;_functor) (;;join))) )))) body (reverse (as-pairs bindings)))] diff --git a/source/lux/data/id.lux b/source/lux/data/id.lux index 6b996cf1e..e4f2a775f 100644 --- a/source/lux/data/id.lux +++ b/source/lux/data/id.lux @@ -10,20 +10,18 @@ ## [Types] (deftype #export (Id a) - (| (#Id a))) + a) ## [Structures] (defstruct #export Id/Functor (Functor Id) - (def (map f fa) - (let [(#Id a) fa] - (#Id (f a))))) + (def map id)) (defstruct #export Id/Monad (Monad Id) (def _functor Id/Functor) - (def (wrap a) (#Id a)) - (def (join mma) (let [(#Id ma) mma] ma))) + (def wrap id) + (def join id)) (defstruct #export Id/CoMonad (CoMonad Id) (def _functor Id/Functor) - (def (unwrap wa) (let [(#Id a) wa] a)) - (def (split wa) (#Id wa))) + (def unwrap id) + (def split id)) diff --git a/source/lux/data/list.lux b/source/lux/data/list.lux index a6ca4e0f7..8a7f97698 100644 --- a/source/lux/data/list.lux +++ b/source/lux/data/list.lux @@ -311,19 +311,20 @@ ## (#;Left "Wrong syntax for zip-with"))) ## [Structures] -## (defstruct #export (List/Eq eq) (All [a] (-> (Eq a) (Eq (List a)))) -## (def (= xs ys) -## (case [xs ys] -## [#;Nil #;Nil] -## true - -## [(#;Cons x xs') (#;Cons y ys')] -## (and (:: eq (E;= x y)) -## (= xs' ys')) - -## [_ _] -## false -## ))) +(defstruct #export (List/Eq eq) + (All [a] (-> (E;Eq a) (E;Eq (List a)))) + (def (= xs ys) + (case [xs ys] + [#;Nil #;Nil] + true + + [(#;Cons x xs') (#;Cons y ys')] + (and (:: eq (E;= x y)) + (= xs' ys')) + + [_ _] + false + ))) (defstruct #export List/Monoid (All [a] (Monoid (List a))) diff --git a/source/lux/data/number/int.lux b/source/lux/data/number/int.lux index 2d94ad43b..20ea5fced 100644 --- a/source/lux/data/number/int.lux +++ b/source/lux/data/number/int.lux @@ -8,6 +8,7 @@ (monoid #as m) (eq #as E) (ord #as O) + (enum #as EN) (bounded #as B) (show #as S))) @@ -56,6 +57,12 @@ [ Int/Ord Int Int/Eq _jvm_leq _jvm_llt _jvm_lgt]) +## Enum +(defstruct Int/Enum (EN;Enum Int) + (def _ord Int/Ord) + (def succ (lambda [n] (:: Int/Number (N;+ n 1)))) + (def pred (lambda [n] (:: Int/Number (N;- n 1))))) + ## Bounded (do-template [<name> <type> <top> <bottom>] [(defstruct #export <name> (B;Bounded <type>) diff --git a/source/lux/data/number/real.lux b/source/lux/data/number/real.lux index 2b7090265..7301f2932 100644 --- a/source/lux/data/number/real.lux +++ b/source/lux/data/number/real.lux @@ -8,6 +8,7 @@ (monoid #as m) (eq #as E) (ord #as O) + (enum #as EN) (bounded #as B) (show #as S))) @@ -56,6 +57,12 @@ [Real/Ord Real Real/Eq _jvm_deq _jvm_dlt _jvm_dgt]) +## Enum +(defstruct Real/Enum (EN;Enum Real) + (def _ord Real/Ord) + (def succ (lambda [n] (:: Real/Number (N;+ n 1.0)))) + (def pred (lambda [n] (:: Real/Number (N;- n 1.0))))) + ## Bounded (do-template [<name> <type> <top> <bottom>] [(defstruct #export <name> (B;Bounded <type>) diff --git a/source/lux/meta/ast.lux b/source/lux/meta/ast.lux index 78882c854..8d649cf4a 100644 --- a/source/lux/meta/ast.lux +++ b/source/lux/meta/ast.lux @@ -10,9 +10,9 @@ (number int real) char - (text #refer #all #open ("text:" Text/Monoid)) + (text #refer (#only Text/Show Text/Eq) #open ("text:" Text/Monoid)) ident - (list #refer (#only List interpose) #open ("" List/Functor List/Fold)) + (list #refer #all #open ("" List/Functor)) ))) ## [Types] @@ -80,11 +80,11 @@ ))) ## (defstruct #export AST/Eq (Eq AST) -## (def (eq x y) +## (def (= x y) ## (case [x y] ## (\template [<tag> <struct>] -## [[(<tag> x') (<tag> y')] -## (:: <struct> (E;eq x' y'))]) +## [[[_ (<tag> x')] [_ (<tag> y')]] +## (:: <struct> (E;= x' y'))]) ## [[#;BoolS Bool/Eq] ## [#;IntS Int/Eq] ## [#;RealS Real/Eq] @@ -94,7 +94,7 @@ ## [#;TagS Ident/Eq]] ## (\template [<tag>] -## [[(<tag> xs') (<tag> ys')] +## [[[_ (<tag> xs')] [_ (<tag> ys')]] ## (and (:: Int/Eq (E;= (size xs') (size ys'))) ## (foldL (lambda [old [x' y']] ## (and old (= x' y'))) @@ -102,7 +102,7 @@ ## (zip2 xs' ys')))]) ## [[#;FormS] [#;TupleS]] -## [(#;RecordS xs') (#;RecordS ys')] +## [[_ (#;RecordS xs')] [_ (#;RecordS ys')]] ## (and (:: Int/Eq (E;= (size xs') (size ys'))) ## (foldL (lambda [old [[xl' xr'] [yl' yr']]] ## (and old (= xl' yl') (= xr' yr'))) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 8fefab156..86bc08534 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -60,19 +60,20 @@ (.visitMaxs 0 0) (.visitEnd))) -(defn ^:private add-lambda-impl [class compile impl-signature impl-body] - (&/with-writer (doto (.visitMethod ^ClassWriter class Opcodes/ACC_PUBLIC "impl" impl-signature nil nil) - (.visitCode)) - (|do [^MethodVisitor *writer* &/get-writer - :let [$start (new Label) - $end (new Label)] - ret (compile impl-body) - :let [_ (doto *writer* - (.visitLabel $end) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) +(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL)] + (defn ^:private add-lambda-impl [class compile impl-signature impl-body] + (&/with-writer (doto (.visitMethod ^ClassWriter class impl-flags "impl" impl-signature nil nil) + (.visitCode)) + (|do [^MethodVisitor *writer* &/get-writer + :let [$start (new Label) + $end (new Label)] + ret (compile impl-body) + :let [_ (doto *writer* + (.visitLabel $end) + (.visitInsn Opcodes/ARETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return ret))))) (defn ^:private instance-closure [compile lambda-class closed-over init-signature] (|do [^MethodVisitor *writer* &/get-writer @@ -88,23 +89,25 @@ (return nil))) ;; [Exports] -(defn compile-lambda [compile ?scope ?env ?body] - ;; (prn 'compile-lambda (->> ?scope &/->seq)) - (|do [:let [name (&host/location (&/|tail ?scope)) - class-name (str (&host/->module-class (&/|head ?scope)) "/" name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" (into-array [&&/function-class])) - (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (add-lambda-apply class-name ?env) - (add-lambda-<init> class-name ?env) - )] - _ (add-lambda-impl =class compile lambda-impl-signature ?body) - :let [_ (.visitEnd =class)] - _ (&&/save-class! name (.toByteArray =class))] - (instance-closure compile class-name ?env (lambda-<init>-signature ?env)))) +(let [lambda-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] + (defn compile-lambda [compile ?scope ?env ?body] + ;; (prn 'compile-lambda (->> ?scope &/->seq)) + (|do [:let [name (&host/location (&/|tail ?scope)) + class-name (str (&host/->module-class (&/|head ?scope)) "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 lambda-flags + class-name nil "java/lang/Object" (into-array [&&/function-class])) + (-> (doto (.visitField datum-flags captured-name clo-field-sig nil nil) + (.visitEnd)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq ?env)]))) + (add-lambda-apply class-name ?env) + (add-lambda-<init> class-name ?env) + )] + _ (add-lambda-impl =class compile lambda-impl-signature ?body) + :let [_ (.visitEnd =class)] + _ (&&/save-class! name (.toByteArray =class))] + (instance-closure compile class-name ?env (lambda-<init>-signature ?env))))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index c17d10494..e85af8b0d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -175,45 +175,47 @@ (return nil))) ))) -(defn compile-def [compile ?name ?body] - (|do [:let [=value-type (&a/expr-type* ?body) - def-type (cond (&type/type= &type/Type =value-type) - "type" - - :else - "value")] - ^ClassWriter *writer* &/get-writer - module-name &/get-module-name - :let [datum-sig "Ljava/lang/Object;" - def-name (&/normalize-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - current-class nil "java/lang/Object" (into-array [&&/function-class])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/name-field "Ljava/lang/String;" nil ?name) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/datum-field datum-sig nil nil) - (doto (.visitEnd))) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/meta-field datum-sig nil nil) - (doto (.visitEnd))))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] - _ (compile-def-type compile current-class ?body def-type) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class)) - class-loader &/loader - :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] - _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] - (return nil))) +(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) + field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] + (defn compile-def [compile ?name ?body] + (|do [:let [=value-type (&a/expr-type* ?body) + def-type (cond (&type/type= &type/Type =value-type) + "type" + + :else + "value")] + ^ClassWriter *writer* &/get-writer + module-name &/get-module-name + :let [datum-sig "Ljava/lang/Object;" + def-name (&/normalize-name ?name) + current-class (str (&host/->module-class module-name) "/" def-name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 class-flags + current-class nil "java/lang/Object" (into-array [&&/function-class])) + (-> (.visitField field-flags &/name-field "Ljava/lang/String;" nil ?name) + (doto (.visitEnd))) + (-> (.visitField field-flags &/datum-field datum-sig nil nil) + (doto (.visitEnd))) + (-> (.visitField field-flags &/meta-field datum-sig nil nil) + (doto (.visitEnd))))] + _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "<clinit>" "()V" nil nil) + (|do [^MethodVisitor **writer** &/get-writer + :let [_ (.visitCode **writer**)] + _ (compile ?body) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/datum-field datum-sig)] + _ (compile-def-type compile current-class ?body def-type) + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] + :let [_ (doto **writer** + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))) + :let [_ (.visitEnd *writer*)] + _ (&&/save-class! def-name (.toByteArray =class)) + class-loader &/loader + :let [def-class (&&/load-class! class-loader (&host/->class-name current-class))] + _ (&a-module/define module-name ?name (-> def-class (.getField &/meta-field) (.get nil)) =value-type)] + (return nil)))) (defn compile-ann [compile *type* ?value-ex ?type-ex] (compile ?value-ex)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 889d4fc47..4672b18d4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -739,35 +739,35 @@ (check* class-loader fixpoints eA aA) (fail (check-error expected actual))) - [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] - (fn [state] - (|case ((|do [F1 (deref ?eid)] - (fn [state] - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((check* class-loader fixpoints (App$ F1 A1) actual) - state)))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (App$ F2 A2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) - [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) - state)))) + ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] + ;; (fn [state] + ;; (|case ((|do [F1 (deref ?eid)] + ;; (fn [state] + ;; (|case ((|do [F2 (deref ?aid)] + ;; (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; ((check* class-loader fixpoints (App$ F1 A1) actual) + ;; state)))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; (|case ((|do [F2 (deref ?aid)] + ;; (check* class-loader fixpoints expected (App$ F2 A2))) + ;; state) + ;; (&/$Right state* output) + ;; (return* state* output) + + ;; (&/$Left _) + ;; ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) + ;; [fixpoints** _] (check* class-loader fixpoints* A1 A2)] + ;; (return (&/T fixpoints** nil))) + ;; state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] @@ -788,6 +788,7 @@ [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) + ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) @@ -810,6 +811,7 @@ [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) + ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) @@ -817,6 +819,10 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) + ;; [(&/$AppT eF eA) (&/$AppT aF aA)] + ;; (|do [_ (check* class-loader fixpoints eF aF)] + ;; (check* class-loader fixpoints eA aA)) + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) |