From c9e0b6c3a0c23b34cd6ffac1b93a266ae6243c4a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 31 Jul 2015 20:33:29 -0400 Subject: - Did some refactoring of the standard library. - Introduced 2 new modules: lux/data/tuple & lux/codata/function - Now doing safe reading of files. - Took the "let", "lambda" & "def" macros to their ultimate form. - Added some macros for doing better JVM interop. - Fixed a bug when compiling comparisons for doubles. - Changed the order in which arguments are compiled for all arithmetic operations, as the order is reversed (from the conventional order) in the JVM bytecode. --- src/lux/compiler.clj | 100 +++++++++++++++++------------------ src/lux/compiler/cache.clj | 126 +++++++++++++++++++++++---------------------- src/lux/compiler/host.clj | 10 ++-- src/lux/compiler/io.clj | 18 +++++++ 4 files changed, 138 insertions(+), 116 deletions(-) create mode 100644 src/lux/compiler/io.clj (limited to 'src') diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 3449900e0..b88bb9c0a 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -29,7 +29,8 @@ [host :as &&host] [case :as &&case] [lambda :as &&lambda] - [package :as &&package])) + [package :as &&package] + [io :as &&io])) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -372,54 +373,55 @@ (defn ^:private compile-module [name] ;; (prn 'compile-module name (&&cache/cached? name)) - (let [file-name (str &&/input-dir "/" name ".lux") - file-content (slurp file-name) - file-hash (hash file-content)] - (if (&&cache/cached? name) - (&&cache/load name file-hash compile-module) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) - :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) - .visitEnd)) - ;; _ (prn 'compile-module name =class) - ]] - (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] - (&/run-state (|do [defs &a-module/defs - imports &a-module/imports - :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil - (->> defs - (&/|map (fn [_def] - (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") - (&/fold str ""))) - .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) - .visitEnd) - (.visitEnd)) - ;; _ (prn 'CLOSED name =class) - ]] - (&&/save-class! "_" (.toByteArray =class))) - ?state) - - [["lux;Left" ?message]] - (fail* ?message))))))) - ))) + (let [file-name (str &&/input-dir "/" name ".lux")] + (|do [file-content (&&io/read-file file-name) + :let [file-hash (hash file-content)]] + (if (&&cache/cached? name) + (&&cache/load name file-hash compile-module) + (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] + (&/map% compile-statement analysis+))] + (|do [module-exists? (&a-module/exists? name)] + (if module-exists? + (fail "[Compiler Error] Can't redefine a module!") + (|do [_ (&a-module/enter-module name) + :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + .visitEnd)) + ;; _ (prn 'compile-module name =class) + ]] + (fn [state] + (matchv ::M/objects [((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] + [["lux;Right" [?state _]]] + (&/run-state (|do [defs &a-module/defs + imports &a-module/imports + :let [_ (doto =class + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (->> defs + (&/|map (fn [_def] + (|let [[?exported ?name ?ann] _def] + (str (if ?exported "1" "0") " " ?name " " ?ann)))) + (&/|interpose "\t") + (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil + (->> imports (&/|interpose "\t") (&/fold str ""))) + .visitEnd) + (.visitEnd)) + ;; _ (prn 'CLOSED name =class) + ]] + (&&/save-class! "_" (.toByteArray =class))) + ?state) + + [["lux;Left" ?message]] + (fail* ?message))))))) + )) + )) (defn ^:private init! [] (.mkdirs (java.io.File. &&/output-dir))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index c0d978146..45513d0a5 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -17,7 +17,8 @@ [host :as &host]) (lux.analyser [base :as &a] [module :as &a-module]) - (lux.compiler [base :as &&])) + (lux.compiler [base :as &&] + [io :as &&io])) (:import (java.io File BufferedOutputStream FileOutputStream) @@ -74,65 +75,66 @@ (return false))]] (do ;; (prn 'load module 'sources already-loaded? ;; (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str &&/output-dir "/" module*) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") - ;; _ (prn 'load/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (load _import (-> (str &&/input-dir "/" _import ".lux") slurp hash) compile-module)) - (if (= [""] imports) - (&/|list) - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] - ;; (prn 'load module defs) - (|do [_ (&a-module/enter-module module) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) - "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) + (if already-loaded? + (return true) + (if (cached? module) + (do ;; (prn 'load/HASH module module-hash) + (let [module* (&host/->module-class module) + module-path (str &&/output-dir "/" module*) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field "_hash" module-meta)) + (= &&/version (get-field "_compiler" module-meta))) + (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + ;; _ (prn 'load/IMPORTS module imports) + ] + (|do [loads (&/map% (fn [_import] + (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] + (load _import (hash content) compile-module))) + (if (= [""] imports) (&/|list) - (&/->list defs)))] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file) + ;; _ (prn 'load module real-name) + ] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + ;; (prn 'load module defs) + (|do [_ (&a-module/enter-module module) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ") + ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) + ] + (|do [_ (case _ann + "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) + "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] + (&a-module/declare-macro module _name)) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) + def-type (get-field "_meta" def-class)] + (matchv ::M/objects [def-type] + [["lux;ValueD" _def-type]] + (&a-module/define module _name def-type _def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (do ;; (prn '__type [__module __name] (&type/show-type __type)) + (&a-module/def-alias module _name __module __name __type)))))] + (if (= "1" _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + (&/|list) + (&/->list defs)))] + (return true)))) + redo-cache))) + redo-cache) + )) + redo-cache))))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 346b66fd2..542bd9a40 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,11 +88,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) @@ -191,9 +191,9 @@ compile-jvm-flt Opcodes/FCMPG 1 "java.lang.Float" "floatValue" "()F" compile-jvm-fgt Opcodes/FCMPG -1 "java.lang.Float" "floatValue" "()F" - compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()I" - compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()I" - compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()I" + compile-jvm-deq Opcodes/DCMPG 0 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dlt Opcodes/DCMPG 1 "java.lang.Double" "doubleValue" "()D" + compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D" ) (defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj new file mode 100644 index 000000000..176b4340d --- /dev/null +++ b/src/lux/compiler/io.clj @@ -0,0 +1,18 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.io + (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) + )) + +;; [Resources] +(defn read-file [path] + (let [file (new java.io.File path)] + (if (.exists file) + (return (slurp file)) + (fail (str "[I/O] File doesn't exist: " path))))) -- cgit v1.2.3 From bcf0cb737e348dc9e183b1608abbebc5a40ba847 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 2 Aug 2015 22:38:43 -0400 Subject: - Added a module for hashing. - Refactored the standard library a bit. - Implemented the "loop" macro. - Added the expected type of expressions as a field in the compiler state. - Added syntactic sugar for using tuples with variants, in order to minimize the usage of brackets to delimit the contents of data-structures. - Fixed a bug wherein "macro-expand" was behaving like "macro-expand-all", and added a separate implementation for "macro-expand-all". - Fixed a few bugs. --- src/lux/analyser.clj | 103 +++++++++++++++++++++++----------------------- src/lux/analyser/case.clj | 17 ++++---- src/lux/analyser/lux.clj | 39 ++++++++++++++---- src/lux/base.clj | 30 +++++++++++--- src/lux/compiler/io.clj | 2 +- src/lux/type.clj | 4 +- 6 files changed, 121 insertions(+), 74 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index de7fc8497..f10f6b913 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -446,45 +446,44 @@ [_] (aba3 analyse eval! compile-module exo-type token))) -(let [unit (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))] - (defn ^:private aba1 [analyse eval! compile-module exo-type token] - (matchv ::M/objects [token] - ;; Standard special forms - [["lux;BoolS" ?value]] - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) +(defn ^:private aba1 [analyse eval! compile-module exo-type token] + (matchv ::M/objects [token] + ;; Standard special forms + [["lux;BoolS" ?value]] + (|do [_ (&type/check exo-type &type/Bool)] + (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;IntS" ?value]] - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + [["lux;IntS" ?value]] + (|do [_ (&type/check exo-type &type/Int)] + (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;RealS" ?value]] - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + [["lux;RealS" ?value]] + (|do [_ (&type/check exo-type &type/Real)] + (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;CharS" ?value]] - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + [["lux;CharS" ?value]] + (|do [_ (&type/check exo-type &type/Char)] + (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;TextS" ?value]] - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + [["lux;TextS" ?value]] + (|do [_ (&type/check exo-type &type/Text)] + (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;TupleS" ?elems]] - (&&lux/analyse-tuple analyse exo-type ?elems) + [["lux;TupleS" ?elems]] + (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;RecordS" ?elems]] - (&&lux/analyse-record analyse exo-type ?elems) + [["lux;RecordS" ?elems]] + (&&lux/analyse-record analyse exo-type ?elems) - [["lux;TagS" ?ident]] - (&&lux/analyse-variant analyse exo-type ?ident unit) - - [["lux;SymbolS" [_ "_jvm_null"]]] - (&&host/analyse-jvm-null analyse exo-type) + [["lux;TagS" ?ident]] + (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) + + [["lux;SymbolS" [_ "_jvm_null"]]] + (&&host/analyse-jvm-null analyse exo-type) - [_] - (aba2 analyse eval! compile-module exo-type token) - ))) + [_] + (aba2 analyse eval! compile-module exo-type token) + )) (defn ^:private add-loc [meta ^String msg] (if (.startsWith msg "@") @@ -512,10 +511,10 @@ ;; (assert false (aget token 0)) )) -(defn ^:private just-analyse [analyse-ast eval! compile-module syntax] +(defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] - (|do [[?output-term ?output-type] (&&/analyse-1 (partial analyse-ast eval! compile-module) ?var syntax)] + (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] (matchv ::M/objects [?var ?output-type] [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] (if (= ?e-id ?a-id) @@ -528,25 +527,25 @@ )))) (defn ^:private analyse-ast [eval! compile-module exo-type token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (do (assert (.equals ^Object (&/|length ?values) 1) "[Analyser Error] Can only tag 1 value.") - (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident (&/|head ?values))) - - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] - (fn [state] - (matchv ::M/objects [((just-analyse analyse-ast eval! compile-module ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) - - [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) - - [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token))) + (&/with-expected-type exo-type + (matchv ::M/objects [token] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident ?values) + + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + (fn [state] + (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module) ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] + [["lux;Right" [state* =fn]]] + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) + + [_] + ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) + + [_] + (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))) ;; [Resources] (defn analyse [eval! compile-module] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index ebbb6911a..77f8c418c 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -16,6 +16,9 @@ [env :as &env]))) ;; [Utils] +(def ^:private unit + (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) + (defn ^:private resolve-type [type] (matchv ::M/objects [type] [["lux;VarT" ?id]] @@ -198,19 +201,19 @@ (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) - (&/V "lux;TupleS" (&/|list)))) - kont)] + [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]] + ?values]]]] (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type ?value - kont)] + [=test =kont] (case (&/|length ?values) + 0 (analyse-pattern case-type unit kont) + 1 (analyse-pattern case-type (&/|head ?values) kont) + ;; 1+ + (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" ?values))) kont))] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) ))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 065e150d9..4fb9d1533 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -55,7 +55,25 @@ [_] (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) -(defn analyse-variant [analyse exo-type ident ?value] +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (matchv ::M/objects [?values] + [["lux;Nil" _]] + (analyse-tuple analyse exo-type (&/|list)) + + [["lux;Cons" [?value ["lux;Nil" _]]]] + (analyse exo-type ?value) + + [_] + (analyse-tuple analyse exo-type ?values) + )] + (matchv ::M/objects [output] + [["lux;Cons" [x ["lux;Nil" _]]]] + (return x) + + [_] + (fail "[Analyser Error] Can't expand to other than 1 element.")))) + +(defn analyse-variant [analyse exo-type ident ?values] (|do [exo-type* (matchv ::M/objects [exo-type] [["lux;VarT" ?id]] (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -69,7 +87,7 @@ [["lux;VariantT" ?cases]] (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] - (|do [=value (&&/analyse-1 analyse vtype ?value)] + (|do [=value (analyse-variant-body analyse vtype ?values)] (return (&/|list (&/T (&/V "variant" (&/T ?tag =value)) exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) @@ -78,7 +96,7 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** ident ?value)))) + (analyse-variant analyse exo-type** ident ?values)))) [_] (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) @@ -108,6 +126,8 @@ (fail (str "[Analyser Error] The type of a record must be a record type:\n" (&type/show-type exo-type*) "\n"))) + _ (&/assert! (= (&/|length types) (&/|length ?elems)) + (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] (matchv ::M/objects [kv] [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] @@ -258,14 +278,17 @@ (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (matchv ::M/objects [$def] [["lux;MacroD" macro]] - (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) + (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] + macro-expansion #(-> macro (.apply ?args) (.apply %)) + ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (and ;; (= "lux/control/monad" ?module) - ;; (= "case" ?name)) + ;; :let [_ (when (or (= "loop" r-name) + ;; ;; (= "struct" r-name) + ;; ) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn ?module "case")))] + ;; (prn (str r-module ";" r-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) @@ -356,6 +379,8 @@ (defn analyse-def [analyse ?name ?value] ;; (prn 'analyse-def/BEGIN ?name) + ;; (when (= "PList/Dict" ?name) + ;; (prn 'DEF ?name (&/show-ast ?value))) (|do [module-name &/get-module-name ? (&&module/defined? module-name ?name)] (if ? diff --git a/src/lux/base.clj b/src/lux/base.clj index eb94c2c90..ef3c81041 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,6 +11,9 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) +;; [Tags] +(def $Cons "lux;Cons") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -27,14 +30,15 @@ (def $LOADER 1) (def $WRITER 2) -;; CompilerState +;; Compiler (def $ENVS 0) (def $EVAL? 1) -(def $HOST 2) -(def $MODULES 3) -(def $SEED 4) -(def $SOURCE 5) -(def $TYPES 6) +(def $EXPECTED 2) +(def $HOST 3) +(def $MODULES 4) +(def $SEED 5) +(def $SOURCE 6) +(def $TYPES 7) ;; [Exports] (def +name-separator+ ";") @@ -487,6 +491,8 @@ (|list) ;; "lux;eval?" false + ;; "lux;expected" + (V "lux;VariantT" (|list)) ;; "lux;host" (host nil) ;; "lux;modules" @@ -610,6 +616,18 @@ [_] output)))) +(defn with-expected-type [type body] + "(All [a] (-> Type (Lux a)))" + (fn [state] + (let [output (body (set$ $EXPECTED type state))] + (matchv ::M/objects [output] + [["lux;Right" [?state ?value]]] + (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) + ?value) + + [_] + output)))) + (defn show-ast [ast] (matchv ::M/objects [ast] [["lux;Meta" [_ ["lux;BoolS" ?value]]]] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 176b4340d..0e7982a7f 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -11,7 +11,7 @@ )) ;; [Resources] -(defn read-file [path] +(defn read-file [^String path] (let [file (new java.io.File path)] (if (.exists file) (return (slurp file)) diff --git a/src/lux/type.clj b/src/lux/type.clj index f5b8d3f25..e3255ac5c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -177,7 +177,9 @@ (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) - (&/T "lux;eval?" Bool)))) + (&/T "lux;eval?" Bool) + (&/T "lux;expected" Type) + ))) $Void))) (def Macro -- cgit v1.2.3 From ddc471806fba8fe179d52b4781f0a66d871b5e99 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 3 Aug 2015 19:54:53 -0400 Subject: - Type definitions inside the compiler data now hold the type itself. - Value definitions inside the compiler data now hold the value itself. - Fixed a few bugs. --- src/lux/analyser.clj | 62 +++++++++++++++++------------------ src/lux/analyser/env.clj | 1 + src/lux/analyser/host.clj | 21 ++++++------ src/lux/analyser/lux.clj | 33 ++++++++----------- src/lux/analyser/module.clj | 6 ++-- src/lux/compiler.clj | 27 +++++++++++++--- src/lux/compiler/base.clj | 2 +- src/lux/compiler/cache.clj | 22 +++++++++---- src/lux/compiler/case.clj | 4 +-- src/lux/compiler/lux.clj | 78 ++++++++++++++++++++++++++++++--------------- src/lux/compiler/type.clj | 2 +- src/lux/host.clj | 3 ++ src/lux/optimizer.clj | 4 +-- src/lux/type.clj | 4 +-- 14 files changed, 161 insertions(+), 108 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f10f6b913..774188d82 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -34,7 +34,7 @@ ["lux;Nil" _]]]]]]]]] (&/T catch+ (&/V "lux;Some" ?finally-body)))) -(defn ^:private aba7 [analyse eval! compile-module exo-type token] +(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Arrays [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] @@ -64,25 +64,25 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] ["lux;Nil" _]]]]]]]]]]]]]]] - (&&host/analyse-jvm-class analyse ?name ?super-class ?interfaces ?fields ?methods) + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] ?methods]]]]]]]] - (&&host/analyse-jvm-interface analyse ?name ?supers ?methods) + (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] - (&&host/analyse-jvm-program analyse ?args ?body) + (&&host/analyse-jvm-program analyse compile-token ?args ?body) [_] (fail ""))) -(defn ^:private aba6 [analyse eval! compile-module exo-type token] +(defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Primitive conversions [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] @@ -156,9 +156,9 @@ (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) [_] - (aba7 analyse eval! compile-module exo-type token))) + (aba7 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba5 [analyse eval! compile-module exo-type token] +(defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Objects [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] @@ -265,9 +265,9 @@ (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) [_] - (aba6 analyse eval! compile-module exo-type token))) + (aba6 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba4 [analyse eval! compile-module exo-type token] +(defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Float arithmetic [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] @@ -320,9 +320,9 @@ (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) [_] - (aba5 analyse eval! compile-module exo-type token))) + (aba5 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba3 [analyse eval! compile-module exo-type token] +(defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Host special forms ;; Characters @@ -386,9 +386,9 @@ (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) [_] - (aba4 analyse eval! compile-module exo-type token))) + (aba4 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba2 [analyse eval! compile-module exo-type token] +(defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] [["lux;SymbolS" ?ident]] (&&lux/analyse-symbol analyse exo-type ?ident) @@ -408,17 +408,17 @@ ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-def analyse ?name ?value) + (&&lux/analyse-def analyse compile-token ?name ?value) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-declare-macro analyse ?name) + (&&lux/analyse-declare-macro analyse compile-token ?name) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-import analyse compile-module ?path) + (&&lux/analyse-import analyse compile-module compile-token ?path) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] ["lux;Cons" [?type @@ -435,18 +435,18 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] ["lux;Nil" _]]]]]]] - (&&lux/analyse-export analyse ?ident) + (&&lux/analyse-export analyse compile-token ?ident) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] ["lux;Nil" _]]]]]]]]] - (&&lux/analyse-alias analyse ?alias ?module) + (&&lux/analyse-alias analyse compile-token ?alias ?module) [_] - (aba3 analyse eval! compile-module exo-type token))) + (aba3 analyse eval! compile-module compile-token exo-type token))) -(defn ^:private aba1 [analyse eval! compile-module exo-type token] +(defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] ;; Standard special forms [["lux;BoolS" ?value]] @@ -482,7 +482,7 @@ (&&host/analyse-jvm-null analyse exo-type) [_] - (aba2 analyse eval! compile-module exo-type token) + (aba2 analyse eval! compile-module compile-token exo-type token) )) (defn ^:private add-loc [meta ^String msg] @@ -491,12 +491,12 @@ (|let [[file line col] meta] (str "@ " file "," line "," col "\n" msg)))) -(defn ^:private analyse-basic-ast [analyse eval! compile-module exo-type token] +(defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (matchv ::M/objects [token] [["lux;Meta" [meta ?token]]] (fn [state] - (matchv ::M/objects [((aba1 analyse eval! compile-module exo-type ?token) state)] + (matchv ::M/objects [((aba1 analyse eval! compile-module compile-token exo-type ?token) state)] [["lux;Right" [state* output]]] (return* state* output) @@ -526,28 +526,28 @@ (return (&/T ?output-term ?output-type))) )))) -(defn ^:private analyse-ast [eval! compile-module exo-type token] +(defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] (&/with-expected-type exo-type (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module) exo-type ?ident ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module) ?fn) state) + (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) ] [["lux;Right" [state* =fn]]] (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module) exo-type meta =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token) state))) + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module) eval! compile-module exo-type token)))) + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))) ;; [Resources] -(defn analyse [eval! compile-module] +(defn analyse [eval! compile-module compile-token] (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast eval! compile-module &type/$Void) asts))) + (&/flat-map% (partial analyse-ast eval! compile-module compile-token &type/$Void) asts))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index cac0f8cd4..391d78411 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -20,6 +20,7 @@ (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] + ;; (prn 'with-local name) (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5033f4f2c..663c650e7 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -273,7 +273,7 @@ tname )) -(defn analyse-jvm-class [analyse ?name ?super-class ?interfaces ?fields ?methods] +(defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (matchv ::M/objects [?field] @@ -328,10 +328,11 @@ [_] (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods))] - (return (&/|list (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))))) + (&/enumerate ?methods)) + _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] + (return (&/|list)))) -(defn analyse-jvm-interface [analyse ?name ?supers ?methods] +(defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (matchv ::M/objects [method] @@ -349,8 +350,9 @@ [_] (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - ?methods)] - (return (&/|list (&/V "jvm-interface" (&/T ?name =supers =methods)))))) + ?methods) + _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] + (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] @@ -431,9 +433,10 @@ analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" ) -(defn analyse-jvm-program [analyse ?args ?body] +(defn analyse-jvm-program [analyse compile-token ?args ?body] (|let [[_module _name] ?args] (|do [=body (&/with-scope "" (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body)))] - (return (&/|list (&/V "jvm-program" =body)))))) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V "jvm-program" =body))] + (return (&/|list))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 4fb9d1533..c86df3027 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -163,7 +163,7 @@ ?name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] + [["lux;ValueD" [?type _]]] (return ?type) [["lux;MacroD" _]] @@ -188,7 +188,7 @@ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] endo-type (matchv ::M/objects [$def] - [["lux;ValueD" ?type]] + [["lux;ValueD" [?type _]]] (return ?type) [["lux;MacroD" _]] @@ -282,7 +282,7 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "loop" r-name) + ;; :let [_ (when (or (= "<>" r-name) ;; ;; (= "struct" r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion*) @@ -377,7 +377,7 @@ (|do [output (analyse-lambda** analyse exo-type ?self ?arg ?body)] (return (&/|list output)))) -(defn analyse-def [analyse ?name ?value] +(defn analyse-def [analyse compile-token ?name ?value] ;; (prn 'analyse-def/BEGIN ?name) ;; (when (= "PList/Dict" ?name) ;; (prn 'DEF ?name (&/show-ast ?value))) @@ -397,24 +397,17 @@ (return (&/|list))) [_] - (|do [=value-type (&&/expr-type =value) - :let [;; _ (prn 'analyse-def/END ?name) - _ (println 'DEF (str module-name ";" ?name)) - ;; _ (println) - def-data (cond (&type/type= &type/Type =value-type) - (&/V "lux;TypeD" nil) - - :else - (&/V "lux;ValueD" =value-type))] - _ (&&module/define module-name ?name def-data =value-type)] - (return (&/|list (&/V "def" (&/T ?name =value def-data)))))) + (do (println 'DEF (str module-name ";" ?name)) + (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] + (return (&/|list))))) )))) -(defn analyse-declare-macro [analyse ?name] +(defn analyse-declare-macro [analyse compile-token ?name] (|do [module-name &/get-module-name] - (return (&/|list (&/V "declare-macro" (&/T module-name ?name)))))) + (|do [_ (compile-token (&/V "declare-macro" (&/T module-name ?name)))] + (return (&/|list))))) -(defn analyse-import [analyse compile-module ?path] +(defn analyse-import [analyse compile-module compile-token ?path] (|do [module-name &/get-module-name _ (if (= module-name ?path) (fail (str "[Analyser Error] Module can't import itself: " ?path)) @@ -426,12 +419,12 @@ _ (&/when% (not already-compiled?) (compile-module ?path))] (return (&/|list)))))) -(defn analyse-export [analyse name] +(defn analyse-export [analyse compile-token name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] (return (&/|list)))) -(defn analyse-alias [analyse ex-alias ex-module] +(defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] (return (&/|list)))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 68cdc4747..327dad27f 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -72,7 +72,7 @@ [[_ ["lux;MacroD" _]]] (return* state &type/Macro) - [[_ ["lux;ValueD" _type]]] + [[_ ["lux;ValueD" [_type _]]]] (return* state _type) [[_ ["lux;AliasD" [?r-module ?r-name]]]] @@ -159,7 +159,7 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (matchv ::M/objects [$def] - [[exported? ["lux;ValueD" ?type]]] + [[exported? ["lux;ValueD" [?type _]]]] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -181,7 +181,7 @@ [[_ ["lux;MacroD" _]]] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - [[_ ["lux;TypeD" _]]] + [[_ _]] (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module does not exist: " module))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index b88bb9c0a..4c12f9519 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -326,8 +326,8 @@ (defn ^:private compile-statement [syntax] (matchv ::M/objects [syntax] - [["def" [?name ?body ?def-data]]] - (&&lux/compile-def compile-expression ?name ?body ?def-data) + [["def" [?name ?body]]] + (&&lux/compile-def compile-expression ?name ?body) [["declare-macro" [?module ?name]]] (&&lux/compile-declare-macro compile-expression ?module ?name) @@ -341,6 +341,26 @@ [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) +(defn ^:private compile-token [syntax] + (matchv ::M/objects [syntax] + [["def" [?name ?body]]] + (&&lux/compile-def compile-expression ?name ?body) + + [["declare-macro" [?module ?name]]] + (&&lux/compile-declare-macro compile-expression ?module ?name) + + [["jvm-program" ?body]] + (&&host/compile-jvm-program compile-expression ?body) + + [["jvm-interface" [?name ?supers ?methods]]] + (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) + + [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) + + [_] + (compile-expression syntax))) + (defn ^:private eval! [expr] (&/with-eval (|do [module &/get-module-name @@ -378,8 +398,7 @@ :let [file-hash (hash file-content)]] (if (&&cache/cached? name) (&&cache/load name file-hash compile-module) - (let [compiler-step (|do [analysis+ (&optimizer/optimize eval! compile-module)] - (&/map% compile-statement analysis+))] + (let [compiler-step (&optimizer/optimize eval! compile-module compile-token)] (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 28339c162..74e5625b3 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -27,7 +27,7 @@ (java.lang.reflect Field))) ;; [Constants] -(def ^String version "0.2") +(def ^String version "0.3") (def ^String input-dir "source") (def ^String output-dir "target/jvm") (def ^String output-package (str output-dir "/program.jar")) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 45513d0a5..565eae898 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -26,6 +26,7 @@ ;; [Utils] (defn ^:private read-file [^File file] + "(-> File (Array Byte))" (with-open [reader (io/input-stream file)] (let [length (.length file) buffer (byte-array length)] @@ -33,6 +34,7 @@ buffer))) (defn ^:private clean-file [^File file] + "(-> File (,))" (if (.isDirectory file) (do (doseq [f (seq (.listFiles file))] (clean-file f)) @@ -40,6 +42,7 @@ (.delete file))) (defn ^:private get-field [^String field-name ^Class class] + "(-> Text Class Object)" (-> class ^Field (.getField field-name) (.get nil))) ;; [Resources] @@ -66,6 +69,7 @@ nil)) (defn load [module module-hash compile-module] + "(-> Text Int (-> Text (Lux (,))) (Lux Bool))" (|do [loader &/loader !classes &/classes already-loaded? (&a-module/exists? module) @@ -112,15 +116,19 @@ ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) ] (|do [_ (case _ann - "T" (&a-module/define module _name (&/V "lux;TypeD" nil) &type/Type) - "M" (|do [_ (&a-module/define module _name (&/V "lux;ValueD" &type/Macro) &type/Macro)] - (&a-module/declare-macro module _name)) + "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field "_datum" def-class)] + (&a-module/define module _name (&/V "lux;TypeD" def-value) &type/Type)) + "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field "_datum" def-class)] + (|do [_ (&a-module/define module _name (&/V "lux;ValueD" (&/T &type/Macro def-value)) &type/Macro)] + (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-type (get-field "_meta" def-class)] - (matchv ::M/objects [def-type] - [["lux;ValueD" _def-type]] - (&a-module/define module _name def-type _def-type))) + def-meta (get-field "_meta" def-class)] + (matchv ::M/objects [def-meta] + [["lux;ValueD" [def-type _]]] + (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] (|do [__type (&a-module/def-type __module __name)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index fc0cce31f..906cc1ca8 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -47,7 +47,7 @@ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Long" "longValue" "()J") - (.visitLdcInsn ?value) + (.visitLdcInsn (long ?value)) (.visitInsn Opcodes/LCMP) (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) @@ -58,7 +58,7 @@ (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Double" "doubleValue" "()D") - (.visitLdcInsn ?value) + (.visitLdcInsn (double ?value)) (.visitInsn Opcodes/DCMPL) (.visitJumpInsn Opcodes/IFNE $else) (.visitInsn Opcodes/POP) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index b1023689e..def5220f7 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -136,33 +136,38 @@ ?args)] (return nil))) -(defn ^:private compile-def-type [compile ?body ?def-data] +(defn ^:private compile-def-type [compile current-class ?body def-type] (|do [^MethodVisitor **writer** &/get-writer] - (matchv ::M/objects [?def-data] - [["lux;TypeD" _]] - (let [_ (doto **writer** - ;; Tail: Begin - (.visitLdcInsn (int 2)) ;; S - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;TypeD") ;; VVIT - (.visitInsn Opcodes/AASTORE) ;; V - (.visitInsn Opcodes/DUP) ;; VV - (.visitLdcInsn (int 1)) ;; VVI - (.visitInsn Opcodes/ACONST_NULL) ;; VVIN - (.visitInsn Opcodes/AASTORE) ;; V - )] + (matchv ::M/objects [def-type] + ["type"] + (|do [:let [;; ?type* (&&type/->analysis ?type) + _ (doto **writer** + ;; Tail: Begin + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + (.visitLdcInsn "lux;TypeD") ;; VVIT + (.visitInsn Opcodes/AASTORE) ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN + (.visitInsn Opcodes/AASTORE) ;; V + )] + ;; _ (compile ?type*) + ;; :let [_ (.visitInsn **writer** Opcodes/AASTORE)] + ] (return nil)) - [["lux;ValueD" _]] + ["value"] (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - [?def-value ?def-type] (matchv ::M/objects [?body] - [[["ann" [?def-value ?type-expr]] ?def-type]] - (&/T ?def-value ?type-expr) + ?def-type (matchv ::M/objects [?body] + [[["ann" [?def-value ?type-expr]] ?def-type]] + ?type-expr - [[?def-value ?def-type]] - (&/T ?body (&&type/->analysis ?def-type)))] + [[?def-value ?def-type]] + (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V @@ -173,13 +178,31 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI )] + :let [_ (doto **writer** + (.visitLdcInsn (int 2)) ;; S + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 0)) ;; VVI + )] _ (compile ?def-type) + :let [_ (.visitInsn **writer** Opcodes/AASTORE)] + :let [_ (doto **writer** + (.visitInsn Opcodes/DUP) ;; VV + (.visitLdcInsn (int 1)) ;; VVI + (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitInsn Opcodes/AASTORE))] :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] (return nil))) ))) -(defn compile-def [compile ?name ?body ?def-data] - (|do [^ClassWriter *writer* &/get-writer +(defn compile-def [compile ?name ?body] + (|do [=value-type (&a/expr-type ?body) + :let [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) @@ -198,7 +221,7 @@ :let [_ (.visitCode **writer**)] _ (compile ?body) :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] - _ (compile-def-type compile ?body ?def-data) + _ (compile-def-type compile current-class ?body def-type) :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_meta" datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) @@ -206,7 +229,10 @@ (.visitEnd))]] (return nil))) :let [_ (.visitEnd *writer*)] - _ (&&/save-class! def-name (.toByteArray =class))] + _ (&&/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") (.get nil)) =value-type)] (return nil))) (defn compile-ann [compile *type* ?value-ex ?type-ex] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index a92911444..01141f8e4 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -75,7 +75,7 @@ (variant$ "lux;AllT" (tuple$ (&/|list (matchv ::M/objects [?env] [["lux;None" _]] - (variant$ "lux;Some" (tuple$ (&/|list))) + (variant$ "lux;None" (tuple$ (&/|list))) [["lux;Some" ??env]] (variant$ "lux;Some" diff --git a/src/lux/host.clj b/src/lux/host.clj index 906e3c714..91582c526 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -40,6 +40,9 @@ (defn ^String ->class [class] (string/replace class #"\." "/")) +(defn ^String ->class-name [module] + (string/replace module #"/" ".")) + (defn ^String ->module-class [module-name] (string/replace module-name #"/" module-separator)) diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 5056a09e0..65dc4eb0d 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -22,5 +22,5 @@ ;; Local var aliasing. ;; [Exports] -(defn optimize [eval! compile-module] - (&analyser/analyse eval! compile-module)) +(defn optimize [eval! compile-module compile-token] + (&analyser/analyse eval! compile-module compile-token)) diff --git a/src/lux/type.clj b/src/lux/type.clj index e3255ac5c..f40996d7e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -142,8 +142,8 @@ (def DefData* (fAll "lux;DefData'" "" - (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Unit) - (&/T "lux;ValueD" Type) + (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Type) + (&/T "lux;ValueD" (&/V "lux;TupleT" (&/|list Type Unit))) (&/T "lux;MacroD" (&/V "lux;BoundT" "")) (&/T "lux;AliasD" Ident))))) -- cgit v1.2.3 From a8ac885a008f519816d747eca0f894ec9794e938 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 4 Aug 2015 19:40:58 -0400 Subject: - Renamed the Syntax type to AST. - Created the lux/meta/ast module. --- src/lux/type.clj | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/lux/type.clj b/src/lux/type.clj index f40996d7e..18f618b43 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -91,12 +91,12 @@ (def Ident (&/V "lux;TupleT" (&/|list Text Text))) -(def Syntax* - (let [Syntax* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Syntax'") +(def AST* + (let [AST* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") + (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;AST'") (&/V "lux;BoundT" "w"))))) - Syntax*List (&/V "lux;AppT" (&/T List Syntax*))] - (fAll "lux;Syntax'" "w" + AST*List (&/V "lux;AppT" (&/T List AST*))] + (fAll "lux;AST'" "w" (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) (&/T "lux;IntS" Int) (&/T "lux;RealS" Real) @@ -104,16 +104,16 @@ (&/T "lux;TextS" Text) (&/T "lux;SymbolS" Ident) (&/T "lux;TagS" Ident) - (&/T "lux;FormS" Syntax*List) - (&/T "lux;TupleS" Syntax*List) - (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Syntax* Syntax*)))))) + (&/T "lux;FormS" AST*List) + (&/T "lux;TupleS" AST*List) + (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) )))) -(def Syntax +(def AST (let [w (&/V "lux;AppT" (&/T Meta Cursor))] - (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T Syntax* w)))))) + (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T AST* w)))))) -(def ^:private SyntaxList (&/V "lux;AppT" (&/T List Syntax))) +(def ^:private ASTList (&/V "lux;AppT" (&/T List AST))) (def Either (fAll "lux;Either" "l" @@ -159,9 +159,9 @@ (&/|list Text (&/V "lux;TupleT" (&/|list Bool (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T SyntaxList + (&/V "lux;LambdaT" (&/T ASTList (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) - SyntaxList))))))))))))) + ASTList))))))))))))) (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) (def $Compiler @@ -183,9 +183,9 @@ $Void))) (def Macro - (&/V "lux;LambdaT" (&/T SyntaxList + (&/V "lux;LambdaT" (&/T ASTList (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) - SyntaxList))))) + ASTList))))) (defn bound? [id] (fn [state] -- cgit v1.2.3 From f855c20a7af7428b638e4c2a3c4c654bd01576dc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 00:05:04 -0400 Subject: - The compiler now stores the cursor of the last analysed AST in order to avoid the problem of error ocurring "nowhere" (at ["" -1 -1]). --- src/lux/analyser.clj | 43 ++++++++++++++++++++++--------------------- src/lux/base.clj | 35 ++++++++++++++++++++++++++--------- src/lux/type.clj | 1 + 3 files changed, 49 insertions(+), 30 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 774188d82..d18c2cfcf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -501,10 +501,10 @@ (return* state* output) [["lux;Left" ""]] - (fail* (add-loc meta (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) [["lux;Left" msg]] - (fail* (add-loc meta msg)) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) ;; [_] @@ -527,25 +527,26 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - (&/with-expected-type exo-type - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] - (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - [_] - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - [_] - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))) + (&/with-cursor (aget token 1 0) + (&/with-expected-type exo-type + (matchv ::M/objects [token] + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) + + [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + (fn [state] + (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) + ] + [["lux;Right" [state* =fn]]] + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + [_] + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + [_] + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/base.clj b/src/lux/base.clj index ef3c81041..85e8df4d1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -31,14 +31,15 @@ (def $WRITER 2) ;; Compiler -(def $ENVS 0) -(def $EVAL? 1) -(def $EXPECTED 2) -(def $HOST 3) -(def $MODULES 4) -(def $SEED 5) -(def $SOURCE 6) -(def $TYPES 7) +(def $cursor 0) +(def $ENVS 1) +(def $EVAL? 2) +(def $EXPECTED 3) +(def $HOST 4) +(def $MODULES 5) +(def $SEED 6) +(def $SOURCE 7) +(def $TYPES 8) ;; [Exports] (def +name-separator+ ";") @@ -487,7 +488,9 @@ (V "lux;None" nil)))) (defn init-state [_] - (R ;; "lux;envs" + (R ;; "lux;cursor" + (T "" -1 -1) + ;; "lux;envs" (|list) ;; "lux;eval?" false @@ -628,6 +631,20 @@ [_] output)))) +(defn with-cursor [cursor body] + "(All [a] (-> Cursor (Lux a)))" + (if (= "" (aget cursor 0)) + body + (fn [state] + (let [output (body (set$ $cursor cursor state))] + (matchv ::M/objects [output] + [["lux;Right" [?state ?value]]] + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) + + [_] + output))))) + (defn show-ast [ast] (matchv ::M/objects [ast] [["lux;Meta" [_ ["lux;BoolS" ?value]]]] diff --git a/src/lux/type.clj b/src/lux/type.clj index 18f618b43..e4117492c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -179,6 +179,7 @@ (&/T "lux;seed" Int) (&/T "lux;eval?" Bool) (&/T "lux;expected" Type) + (&/T "lux;cursor" Cursor) ))) $Void))) -- cgit v1.2.3 From 24cc40e76f83188688ad43c499a44508e1aa5d60 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 5 Aug 2015 20:21:04 -0400 Subject: - Local vars can now longer have prefixed symbols. --- src/lux/analyser.clj | 18 +++-- src/lux/analyser/case.clj | 7 +- src/lux/analyser/host.clj | 17 +++-- src/lux/analyser/lambda.clj | 24 +++---- src/lux/analyser/lux.clj | 167 ++++++++++++++++++++++---------------------- 5 files changed, 118 insertions(+), 115 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d18c2cfcf..7dc4c7607 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -24,15 +24,18 @@ (matchv ::M/objects [token] [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?ex-arg]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ex-arg]]]] ["lux;Cons" [?catch-body ["lux;Nil" _]]]]]]]]]]]]] - (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] ["lux;Cons" [?finally-body ["lux;Nil" _]]]]]]]]] - (&/T catch+ (&/V "lux;Some" ?finally-body)))) + (return (&/T catch+ (&/V "lux;Some" ?finally-body))) + + [_] + (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (matchv ::M/objects [token] @@ -74,7 +77,7 @@ ;; Programs [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?args]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?args]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]] (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -246,7 +249,8 @@ [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] ["lux;Cons" [?body ?handlers]]]]]] - (&&host/analyse-jvm-try analyse exo-type ?body (&/fold parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)) + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] + (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] ["lux;Cons" [?ex @@ -398,8 +402,8 @@ (&&lux/analyse-case analyse exo-type ?value ?branches) [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?self]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?arg]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?self]]]] + ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?arg]]]] ["lux;Cons" [?body ["lux;Nil" _]]]]]]]]]]] (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 77f8c418c..7f2c34924 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -116,12 +116,15 @@ (matchv ::M/objects [pattern] [["lux;Meta" [_ pattern*]]] (matchv ::M/objects [pattern*] - [["lux;SymbolS" ?ident]] - (|do [=kont (&env/with-local (&/ident->text ?ident) value-type + [["lux;SymbolS" ["" name]]] + (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) + [["lux;SymbolS" ident]] + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) + [["lux;BoolS" ?value]] (|do [_ (&type/check value-type &type/Bool) =kont kont] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 663c650e7..d03d0e65c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -299,10 +299,10 @@ ["lux;Nil" _]]]]]]]]]]]]]]]] (|do [=method-inputs (&/map% (fn [minput] (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ?input-name]]] + [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?input-name]]]] ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] ["lux;Nil" _]]]]]]]]] - (return (&/T (&/ident->text ?input-name) ?input-type)) + (return (&/T ?input-name ?input-type)) [_] (fail "[Analyser Error] Wrong syntax for method input."))) @@ -358,7 +358,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local (str ";" ?ex-arg) (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -434,9 +434,8 @@ ) (defn analyse-jvm-program [analyse compile-token ?args ?body] - (|let [[_module _name] ?args] - (|do [=body (&/with-scope "" - (&&env/with-local (str _module ";" _name) (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V "jvm-program" =body))] - (return (&/|list))))) + (|do [=body (&/with-scope "" + (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V "jvm-program" =body))] + (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b1b9e2c22..7c7b80577 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -16,26 +16,22 @@ ;; [Resource] (defn with-lambda [self self-type arg arg-type body] - (|let [[?module1 ?name1] self - [?module2 ?name2] arg] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local (str ?module1 ";" ?name1) self-type - (&env/with-local (str ?module2 ";" ?name2) arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T scope-name =captured =return))))))))) + (&/with-closure + (|do [scope-name &/get-scope-name] + (&env/with-local self self-type + (&env/with-local arg arg-type + (|do [=return body + =captured &env/captured-vars] + (return (&/T scope-name =captured =return)))))))) -(defn close-over [scope ident register frame] +(defn close-over [scope name register frame] (matchv ::M/objects [register] [[_ register-type]] (|let [register* (&/T (&/V "captured" (&/T scope (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) register)) - register-type) - [?module ?name] ident - full-name (str ?module ";" ?name)] + register-type)] (&/T register* (&/update$ &/$CLOSURE #(->> % (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put full-name register* mps)))) + (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) frame))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c86df3027..7aba5dd39 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -143,90 +143,91 @@ ?elems)] (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) +(defn ^:private analyse-global [analyse exo-type module name] + (|do [[[r-module r-name] $def] (&&module/find-def module name) + ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" [?type _]]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type))))) + +(defn ^:private analyse-local [analyse exo-type name] + (fn [state] + (|let [stack (&/get$ &/$ENVS state) + no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) + (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) + [inner outer] (&/|split-with no-binding? stack)] + (matchv ::M/objects [outer] + [["lux;Nil" _]] + (&/run-state (|do [module-name &/get-module-name] + (analyse-global analyse exo-type module-name name)) + state) + + [["lux;Cons" [?genv ["lux;Nil" _]]]] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) + (matchv ::M/objects [global] + [[["lux;Global" [?module* name*]] _]] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) + ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] + endo-type (matchv ::M/objects [$def] + [["lux;ValueD" [?type _]]] + (return ?type) + + [["lux;MacroD" _]] + (return &type/Macro) + + [["lux;TypeD" _]] + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type))] + (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + endo-type)))) + state) + + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + (fail* "_{_ analyse-symbol _}_"))) + + [["lux;Cons" [top-outer _]]] + (do ;; (prn 'analyse-symbol/_3 ?module name) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) + (&/|map #(&/get$ &/$NAME %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name)) + (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name))) + (&/|list)) + (&/|reverse inner) scopes)] + ((|do [btype (&&/expr-type =local) + _ (&type/check exo-type btype)] + (return (&/|list =local))) + (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + )))) + (defn analyse-symbol [analyse exo-type ident] - (|do [module-name &/get-module-name] - (fn [state] - (|let [[?module ?name] ident - ;; _ (prn 'analyse-symbol/_0 ?module ?name) - local-ident (str ?module ";" ?name) - stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? local-ident) not)) - [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] - (do ;; (prn 'analyse-symbol/_1 - ;; [?module ?name] - ;; [(if (.equals "" ?module) module-name ?module) - ;; ?name]) - ((|do [[[r-module r-name] $def] (&&module/find-def (if (.equals "" ?module) module-name ?module) - ?name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state)) - - [["lux;Cons" [?genv ["lux;Nil" _]]]] - (do ;; (prn 'analyse-symbol/_2 ?module ?name local-ident (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident))] - (do ;; (prn 'analyse-symbol/_2.1 ?module ?name local-ident (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* ?name*]] _]] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* ?name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] - (return ?type) - - [["lux;MacroD" _]] - (return &type/Macro) - - [["lux;TypeD" _]] - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) - endo-type)))) - state) - - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module ?name local-ident) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) - - [["lux;Cons" [top-outer _]]] - (do ;; (prn 'analyse-symbol/_3 ?module ?name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over (&/|reverse in-scope) ident register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get local-ident)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get local-ident))) - (&/|list)) - (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] - (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) - ))) + (|do [:let [[?module ?name] ident]] + (if (= "" ?module) + (analyse-local analyse exo-type ?name) + (analyse-global analyse exo-type ?module ?name)) )) (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] -- cgit v1.2.3 From 218af254c30f35d290ab944aef1cf2b33e179224 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 18:33:25 -0400 Subject: - Refacted the compiler by shifting to a pattern-matching syntax more akin to Lux's, while also allowing non-literal tags that can be defined as constants elsewhere. - Added some extra JVM ops for bit-fiddling that were missing. --- src/lux/analyser.clj | 499 ++++++++++++++++++++++---------------------- src/lux/analyser/base.clj | 13 +- src/lux/analyser/case.clj | 157 +++++++------- src/lux/analyser/env.clj | 10 +- src/lux/analyser/host.clj | 117 ++++++----- src/lux/analyser/lambda.clj | 23 +- src/lux/analyser/lux.clj | 169 ++++++++------- src/lux/analyser/module.clj | 85 ++++---- src/lux/base.clj | 297 ++++++++++++++------------ src/lux/compiler.clj | 247 +++++++++++----------- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 24 +-- src/lux/compiler/host.clj | 67 +++--- src/lux/compiler/lambda.clj | 16 +- src/lux/compiler/lux.clj | 16 +- src/lux/compiler/type.clj | 28 +-- src/lux/host.clj | 12 +- src/lux/parser.clj | 87 ++++---- src/lux/reader.clj | 34 +-- src/lux/type.clj | 343 +++++++++++++++--------------- 20 files changed, 1141 insertions(+), 1111 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7dc4c7607..e49797fa5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -8,9 +8,9 @@ (ns lux.analyser (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail*]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -21,471 +21,483 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_catch"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?ex-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ex-arg]]]] - ["lux;Cons" [?catch-body - ["lux;Nil" _]]]]]]]]]]]]] + (|case token + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_catch")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?ex-class)) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ex-arg)) + ("lux;Cons" ?catch-body + ("lux;Nil"))))))) (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_finally"]]]] - ["lux;Cons" [?finally-body - ["lux;Nil" _]]]]]]]]] + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_finally")) + ("lux;Cons" ?finally-body + ("lux;Nil"))))) (return (&/T catch+ (&/V "lux;Some" ?finally-body))) - [_] + _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Arrays - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new-array"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ ?class]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?length]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new-array")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?length)) + ("lux;Nil"))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aastore"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Cons" [?elem - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aastore")) + ("lux;Cons" ?array + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) + ("lux;Cons" ?elem + ("lux;Nil")))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_aaload"]]]] - ["lux;Cons" [?array - ["lux;Cons" [["lux;Meta" [_ ["lux;IntS" ?idx]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aaload")) + ("lux;Cons" ?array + ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) + ("lux;Nil"))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_class"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?super-class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?interfaces]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?fields]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?methods]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_class")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?super-class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?interfaces)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?fields)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?methods)) + ("lux;Nil")))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_interface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?supers]]] - ?methods]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_interface")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?supers)) + ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_program"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?args]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_program")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?args)) + ("lux;Cons" ?body + ("lux;Nil"))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) - [_] + _ (fail ""))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Primitive conversions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_d2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_f2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2b"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2b")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2c"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2c")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2l"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2l")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_i2s"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2s")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2d"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2d")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2f"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2f")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_l2i"]]]] ["lux;Cons" [?value ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2i")) ("lux;Cons" ?value ("lux;Nil")))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iand"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iand")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ior"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ior")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_land"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ixor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) + + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_land")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lxor"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lxor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshl"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lshr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lushr"]]]] ["lux;Cons" [?x ["lux;Cons" [?y ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) - [_] + _ (aba7 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Objects - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_null?"]]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_null?")) + ("lux;Cons" ?object + ("lux;Nil")))) (&&host/analyse-jvm-null? analyse exo-type ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_instanceof"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_instanceof")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ?object + ("lux;Nil"))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_new"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getstatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Nil"))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_getfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getfield")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?object + ("lux;Nil")))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putstatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putstatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?value + ("lux;Nil")))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_putfield"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field]]] - ["lux;Cons" [?object - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putfield")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) + ("lux;Cons" ?object + ("lux;Cons" ?value + ("lux;Nil"))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokestatic"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokestatic")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil"))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokevirtual"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokevirtual")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokeinterface"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokeinterface")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_invokespecial"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?class]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?classes]]] - ["lux;Cons" [?object - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?args]]] - ["lux;Nil" _]]]]]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokespecial")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) + ("lux;Cons" ?object + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) + ("lux;Nil")))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_try"]]]] - ["lux;Cons" [?body - ?handlers]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_try")) + ("lux;Cons" ?body + ?handlers))) (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_throw"]]]] - ["lux;Cons" [?ex - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_throw")) + ("lux;Cons" ?ex + ("lux;Nil")))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorenter"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorenter")) + ("lux;Cons" ?monitor + ("lux;Nil")))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_monitorexit"]]]] - ["lux;Cons" [?monitor - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorexit")) + ("lux;Cons" ?monitor + ("lux;Nil")))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) - [_] + _ (aba6 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Float arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fdiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_frem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_feq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_flt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_fgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ddiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_drem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_deq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dlt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_dgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) - - [_] + + _ (aba5 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba3 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Host special forms ;; Characters - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ceq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_clt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_cgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_iadd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_isub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_imul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_idiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_irem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ieq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ilt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_igt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ladd"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lsub"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lmul"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_ldiv"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lrem"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_leq"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_llt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_jvm_lgt"]]]] ["lux;Cons" [?y ["lux;Cons" [?x ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) - [_] + _ (aba4 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] - [["lux;SymbolS" ?ident]] + (|case token + ("lux;SymbolS" ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_case"]]]] - ["lux;Cons" [?value ?branches]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_case")) + ("lux;Cons" ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_lambda"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?self]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?arg]]]] - ["lux;Cons" [?body - ["lux;Nil" _]]]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_lambda")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?self)) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?arg)) + ("lux;Cons" ?body + ("lux;Nil")))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_def"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_def")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-def analyse compile-token ?name ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_declare-macro"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?name]]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_declare-macro")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) + ("lux;Nil")))) (&&lux/analyse-declare-macro analyse compile-token ?name) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_import"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?path]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_import")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?path)) + ("lux;Nil")))) (&&lux/analyse-import analyse compile-module compile-token ?path) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:")) + ("lux;Cons" ?type + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_:!"]]]] - ["lux;Cons" [?type - ["lux;Cons" [?value - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:!")) + ("lux;Cons" ?type + ("lux;Cons" ?value + ("lux;Nil"))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_export"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?ident]]]] - ["lux;Nil" _]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_export")) + ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ident)) + ("lux;Nil")))) (&&lux/analyse-export analyse compile-token ?ident) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" [_ "_lux_alias"]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?alias]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?module]]] - ["lux;Nil" _]]]]]]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_alias")) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?alias)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?module)) + ("lux;Nil"))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) - [_] + _ (aba3 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] - (matchv ::M/objects [token] + (|case token ;; Standard special forms - [["lux;BoolS" ?value]] + ("lux;BoolS" ?value) (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - [["lux;IntS" ?value]] + ("lux;IntS" ?value) (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - [["lux;RealS" ?value]] + ("lux;RealS" ?value) (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - [["lux;CharS" ?value]] + ("lux;CharS" ?value) (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - [["lux;TextS" ?value]] + ("lux;TextS" ?value) (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - [["lux;TupleS" ?elems]] + ("lux;TupleS" ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) - [["lux;RecordS" ?elems]] + ("lux;RecordS" ?elems) (&&lux/analyse-record analyse exo-type ?elems) - [["lux;TagS" ?ident]] + ("lux;TagS" ?ident) (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) - [["lux;SymbolS" [_ "_jvm_null"]]] + ("lux;SymbolS" _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) - [_] + _ (aba2 analyse eval! compile-module compile-token exo-type token) )) @@ -497,30 +509,27 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) - (matchv ::M/objects [token] - [["lux;Meta" [meta ?token]]] + (|case token + ("lux;Meta" meta ?token) (fn [state] - (matchv ::M/objects [((aba1 analyse eval! compile-module compile-token exo-type ?token) state)] - [["lux;Right" [state* output]]] + (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" ""]] + ("lux;Left" "") (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* (add-loc (&/get$ &/$cursor state) msg)) )) - - ;; [_] - ;; (assert false (aget token 0)) )) (defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] - (matchv ::M/objects [?var ?output-type] - [["lux;VarT" ?e-id] ["lux;VarT" ?a-id]] + (|case [?var ?output-type] + [("lux;VarT" ?e-id) ("lux;VarT" ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] (return (&/T ?output-term ?output-type*))) @@ -533,23 +542,21 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type - (matchv ::M/objects [token] - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] ?values]]]]]] + (|case token + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) ?values))) (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - [["lux;Meta" [meta ["lux;FormS" ["lux;Cons" [?fn ?args]]]]]] + ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ?fn ?args))) (fn [state] - (matchv ::M/objects [((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ;; ((&type/with-var #(&&/analyse-1 (partial analyse-ast eval! compile-module) % ?fn)) state) - ] - [["lux;Right" [state* =fn]]] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + ("lux;Right" state* =fn) (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - [_] + _ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - [_] + _ (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 9fc3f1030..beeb57b08 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -7,24 +7,23 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.base - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [type :as &type]))) ;; [Exports] (defn expr-type [syntax+] - (matchv ::M/objects [syntax+] - [[_ type]] + (|let [[_ type] syntax+] (return type))) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] + (|case output + ("lux;Cons" x ("lux;Nil")) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn resolved-ident [ident] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7f2c34924..2cdf233cc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.case - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |let]] + (lux [base :as & :refer [|do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -20,13 +20,13 @@ (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) (defn ^:private resolve-type [type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + ("lux;VarT" ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - [["lux;AllT" [_aenv _aname _aarg _abody]]] + ("lux;AllT" _aenv _aname _aarg _abody) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -36,20 +36,20 @@ ;; (|do [=type (&type/apply-type type $var)] ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type type))) (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - (matchv ::M/objects [type] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + (|case type + ("lux;AllT" _aenv _aname _aarg _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - [["lux;TupleT" ?members]] - (|do [["lux;TupleT" ?members*] (&/fold% (fn [_abody ena] + ("lux;TupleT" ?members) + (|do [("lux;TupleT" ?members*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -63,8 +63,8 @@ up)) ?members*)))) - [["lux;RecordT" ?fields]] - (|do [["lux;RecordT" ?fields*] (&/fold% (fn [_abody ena] + ("lux;RecordT" ?fields) + (|do [("lux;RecordT" ?fields*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -79,8 +79,8 @@ up)))) ?fields*)))) - [["lux;VariantT" ?cases]] - (|do [["lux;VariantT" ?cases*] (&/fold% (fn [_abody ena] + ("lux;VariantT" ?cases) + (|do [("lux;VariantT" ?cases*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] (&type/clean* _avar _abody)))) @@ -95,11 +95,11 @@ up)))) ?cases*)))) - [["lux;AppT" [?tfun ?targ]]] + ("lux;AppT" ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - [["lux;VarT" ?id]] + ("lux;VarT" ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) @@ -113,48 +113,47 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (matchv ::M/objects [pattern] - [["lux;Meta" [_ pattern*]]] - (matchv ::M/objects [pattern*] - [["lux;SymbolS" ["" name]]] + (|let [("lux;Meta" _ pattern*) pattern] + (|case pattern* + ("lux;SymbolS" "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) - [["lux;SymbolS" ident]] + ("lux;SymbolS" ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - [["lux;BoolS" ?value]] + ("lux;BoolS" ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] (return (&/T (&/V "BoolTestAC" ?value) =kont))) - [["lux;IntS" ?value]] + ("lux;IntS" ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] (return (&/T (&/V "IntTestAC" ?value) =kont))) - [["lux;RealS" ?value]] + ("lux;RealS" ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] (return (&/T (&/V "RealTestAC" ?value) =kont))) - [["lux;CharS" ?value]] + ("lux;CharS" ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] (return (&/T (&/V "CharTestAC" ?value) =kont))) - [["lux;TextS" ?value]] + ("lux;TextS" ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] (return (&/T (&/V "TextTestAC" ?value) =kont))) - [["lux;TupleS" ?members]] + ("lux;TupleS" ?members) (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?member-types]] + (|case value-type* + ("lux;TupleT" ?member-types) (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) @@ -167,48 +166,48 @@ (&/|reverse (&/zip2 ?member-types ?members)))] (return (&/T (&/V "TupleTestAC" =tests) =kont))))) - [_] + _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - - [["lux;RecordS" ?slots]] + + ("lux;RecordS" ?slots) (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] ;; value-type* (resolve-type value-type) ] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?slot-types]] + (|case value-type* + ("lux;RecordT" ?slot-types) (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] - (matchv ::M/objects [sn] - [["lux;Meta" [_ ["lux;TagS" ?ident]]]] + (|case sn + ("lux;Meta" _ ("lux;TagS" ?ident)) (|do [=tag (&&/resolved-ident ?ident)] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - [_] + _ (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] (return (&/T (&/V "RecordTestAC" =tests) =kont)))) - [_] + _ (fail "[Pattern-matching Error] Record requires record-type."))) - [["lux;TagS" ?ident]] + ("lux;TagS" ?ident) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - [["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TagS" ?ident]]] - ?values]]]] + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) + ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) @@ -228,50 +227,50 @@ (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] - (matchv ::M/objects [struct test] - [["DefaultTotal" total?] ["StoreTestAC" ?idx]] + (|case [struct test] + [("DefaultTotal" total?) ("StoreTestAC" ?idx)] (return (&/V "DefaultTotal" true)) - [[?tag [total? ?values]] ["StoreTestAC" ?idx]] + [[?tag [total? ?values]] ("StoreTestAC" ?idx)] (return (&/V ?tag (&/T true ?values))) - [["DefaultTotal" total?] ["BoolTestAC" ?value]] + [("DefaultTotal" total?) ("BoolTestAC" ?value)] (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) - [["BoolTotal" [total? ?values]] ["BoolTestAC" ?value]] + [("BoolTotal" total? ?values) ("BoolTestAC" ?value)] (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["IntTestAC" ?value]] + [("DefaultTotal" total?) ("IntTestAC" ?value)] (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) - [["IntTotal" [total? ?values]] ["IntTestAC" ?value]] + [("IntTotal" total? ?values) ("IntTestAC" ?value)] (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["RealTestAC" ?value]] + [("DefaultTotal" total?) ("RealTestAC" ?value)] (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) - [["RealTotal" [total? ?values]] ["RealTestAC" ?value]] + [("RealTotal" total? ?values) ("RealTestAC" ?value)] (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["CharTestAC" ?value]] + [("DefaultTotal" total?) ("CharTestAC" ?value)] (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) - [["CharTotal" [total? ?values]] ["CharTestAC" ?value]] + [("CharTotal" total? ?values) ("CharTestAC" ?value)] (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["TextTestAC" ?value]] + [("DefaultTotal" total?) ("TextTestAC" ?value)] (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) - [["TextTotal" [total? ?values]] ["TextTestAC" ?value]] + [("TextTotal" total? ?values) ("TextTestAC" ?value)] (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) - [["DefaultTotal" total?] ["TupleTestAC" ?tests]] + [("DefaultTotal" total?) ("TupleTestAC" ?tests)] (|do [structs (&/map% (fn [t] (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) ?tests)] (return (&/V "TupleTotal" (&/T total? structs)))) - [["TupleTotal" [total? ?values]] ["TupleTestAC" ?tests]] + [("TupleTotal" total? ?values) ("TupleTestAC" ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) @@ -279,7 +278,7 @@ (return (&/V "TupleTotal" (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [["DefaultTotal" total?] ["RecordTestAC" ?tests]] + [("DefaultTotal" total?) ("RecordTestAC" ?tests)] (|do [structs (&/map% (fn [t] (|let [[slot value] t] (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] @@ -290,7 +289,7 @@ &/->list))] (return (&/V "RecordTotal" (&/T total? structs)))) - [["RecordTotal" [total? ?values]] ["RecordTestAC" ?tests]] + [("RecordTotal" total? ?values) ("RecordTestAC" ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left @@ -307,12 +306,12 @@ (return (&/V "RecordTotal" (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent record-size.")) - [["DefaultTotal" total?] ["VariantTestAC" [?tag ?test]]] + [("DefaultTotal" total?) ("VariantTestAC" ?tag ?test)] (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) (&/T ?test ?body))] (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - [["VariantTotal" [total? ?branches]] ["VariantTestAC" [?tag ?test]]] + [("VariantTotal" total? ?branches) ("VariantTestAC" ?tag ?test)] (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) (&/V "DefaultTotal" total?)) (&/T ?test ?body))] @@ -320,43 +319,43 @@ )))) (defn ^:private check-totality [value-type struct] - (matchv ::M/objects [struct] - [["BoolTotal" [?total ?values]]] + (|case struct + ("BoolTotal" ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) - [["IntTotal" [?total _]]] + ("IntTotal" ?total _) (return ?total) - [["RealTotal" [?total _]]] + ("RealTotal" ?total _) (return ?total) - [["CharTotal" [?total _]]] + ("CharTotal" ?total _) (return ?total) - [["TextTotal" [?total _]]] + ("TextTotal" ?total _) (return ?total) - [["TupleTotal" [?total ?structs]]] + ("TupleTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;TupleT" ?members]] + (|case value-type* + ("lux;TupleT" ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Tuple is not total.")))) - [["RecordTotal" [?total ?structs]]] + ("RecordTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;RecordT" ?fields]] + (|case value-type* + ("lux;RecordT" ?fields) (|do [totals (&/map% (fn [field] (|let [[?tk ?tv] field] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -365,15 +364,15 @@ ?fields)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Record is not total.")))) - [["VariantTotal" [?total ?structs]]] + ("VariantTotal" ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (matchv ::M/objects [value-type*] - [["lux;VariantT" ?cases]] + (|case value-type* + ("lux;VariantT" ?cases) (|do [totals (&/map% (fn [case] (|let [[?tk ?tv] case] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -382,10 +381,10 @@ ?cases)] (return (&/fold #(and %1 %2) true totals))) - [_] + _ (fail "[Pattern-maching Error] Variant is not total.")))) - [["DefaultTotal" ?total]] + ("DefaultTotal" ?total) (return ?total) )) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 391d78411..a39ec490a 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.env - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail]]) + (lux [base :as & :refer [|do return return* fail |case]]) [lux.analyser.base :as &&])) ;; [Exports] @@ -31,8 +31,8 @@ (&/|head stack)) (&/|tail stack)))) state))] - (matchv ::M/objects [=return] - [["lux;Right" [?state ?value]]] + (|case =return + ("lux;Right" ?state ?value) (return* (&/update$ &/$ENVS (fn [stack*] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER dec) @@ -42,7 +42,7 @@ ?state) ?value) - [_] + _ =return)))) (def captured-vars diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index d03d0e65c..707060323 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -8,9 +8,9 @@ (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -19,39 +19,37 @@ ;; [Utils] (defn ^:private extract-text [text] - (matchv ::M/objects [text] - [["lux;Meta" [_ ["lux;TextS" ?text]]]] + (|case text + ("lux;Meta" _ ("lux;TextS" ?text)) (return ?text) - [_] + _ (fail "[Analyser Error] Can't extract Text."))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) + (|do [=expr (&&/analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" - (matchv ::M/objects [token] - [[_ ["lux;DataT" _]]] + (|case token + [_ ("lux;DataT" _)] (return nil) - [_] + _ (fail "[Analyser Error] Expecting object"))) (defn ^:private as-object [type] "(-> Type Type)" - (matchv ::M/objects [type] - [["lux;DataT" class]] + (|case type + ("lux;DataT" class) (&/V "lux;DataT" (&type/as-obj class)) - [_] + _ type)) ;; [Resources] @@ -225,32 +223,32 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] - (matchv ::M/objects [modif] - [["lux;Meta" [_ ["lux;TextS" "public"]]]] + (|case modif + ("lux;Meta" _ ("lux;TextS" "public")) (return (assoc so-far :visibility "public")) - [["lux;Meta" [_ ["lux;TextS" "private"]]]] + ("lux;Meta" _ ("lux;TextS" "private")) (return (assoc so-far :visibility "private")) - [["lux;Meta" [_ ["lux;TextS" "protected"]]]] + ("lux;Meta" _ ("lux;TextS" "protected")) (return (assoc so-far :visibility "protected")) - [["lux;Meta" [_ ["lux;TextS" "static"]]]] + ("lux;Meta" _ ("lux;TextS" "static")) (return (assoc so-far :static? true)) - [["lux;Meta" [_ ["lux;TextS" "final"]]]] + ("lux;Meta" _ ("lux;TextS" "final")) (return (assoc so-far :final? true)) - [["lux;Meta" [_ ["lux;TextS" "abstract"]]]] + ("lux;Meta" _ ("lux;TextS" "abstract")) (return (assoc so-far :abstract? true)) - [["lux;Meta" [_ ["lux;TextS" "synchronized"]]]] + ("lux;Meta" _ ("lux;TextS" "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [["lux;Meta" [_ ["lux;TextS" "volatile"]]]] + ("lux;Meta" _ ("lux;TextS" "volatile")) (return (assoc so-far :concurrency "volatile")) - [_] + _ (fail (str "[Analyser Error] Unknown modifier: " (&/show-ast modif))))) {:visibility "default" :static? false @@ -276,35 +274,35 @@ (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] - (matchv ::M/objects [?field] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?field-type]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?field-modifiers]]] - ["lux;Nil" _]]]]]]]]]]] + (|case ?field + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-type)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?field-modifiers)) + ("lux;Nil")))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers :type ?field-type})) - [_] + _ (fail "[Analyser Error] Wrong syntax for field."))) ?fields) =methods (&/map% (fn [?method] - (matchv ::M/objects [?method] - [[?idx ["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?method-modifiers]]] - ["lux;Cons" [?method-body - ["lux;Nil" _]]]]]]]]]]]]]]]] + (|case ?method + [?idx ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-inputs)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-output)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-modifiers)) + ("lux;Cons" ?method-body + ("lux;Nil"))))))))] (|do [=method-inputs (&/map% (fn [minput] - (matchv ::M/objects [minput] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;SymbolS" ["" ?input-name]]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?input-type]]] - ["lux;Nil" _]]]]]]]]] + (|case minput + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?input-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?input-type)) + ("lux;Nil"))))) (return (&/T ?input-name ?input-type)) - [_] + _ (fail "[Analyser Error] Wrong syntax for method input."))) ?method-inputs) =method-modifiers (analyse-modifiers ?method-modifiers) @@ -326,7 +324,7 @@ :output ?method-output :body =method-body})) - [_] + _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] @@ -335,12 +333,12 @@ (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] - (matchv ::M/objects [method] - [["lux;Meta" [_ ["lux;FormS" ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?method-name]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?inputs]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TextS" ?output]]] - ["lux;Cons" [["lux;Meta" [_ ["lux;TupleS" ?modifiers]]] - ["lux;Nil" _]]]]]]]]]]]]] + (|case method + ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?inputs)) + ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?output)) + ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?modifiers)) + ("lux;Nil"))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -348,7 +346,7 @@ :inputs =inputs :output ?output})) - [_] + _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] @@ -363,10 +361,10 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (matchv ::M/objects [?finally] - [["lux;None" _]] (return (&/V "lux;None" nil)) - [["lux;Some" ?finally*]] (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V "lux;Some" =finally))))] + =finally (|case [?finally] + ("lux;None") (return (&/V "lux;None" nil)) + ("lux;Some" ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V "lux;Some" =finally))))] (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] @@ -423,11 +421,14 @@ analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor "jvm-ixor" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl "jvm-ishl" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr "jvm-ishr" "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr "jvm-iushr" "java.lang.Integer" "java.lang.Integer" analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long" analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long" analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer" analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer" analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 7c7b80577..a230c8642 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.analyser.lambda - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -25,13 +25,12 @@ (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] - (matchv ::M/objects [register] - [[_ register-type]] - (|let [register* (&/T (&/V "captured" (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) - register)) - register-type)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) - frame))))) + (|let [[_ register-type] register + register* (&/T (&/V "captured" (&/T scope + (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + register)) + register-type)] + (&/T register* (&/update$ &/$CLOSURE #(->> % + (&/update$ &/$COUNTER inc) + (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 7aba5dd39..cd89764c3 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -8,9 +8,9 @@ (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -23,68 +23,66 @@ (defn ^:private analyse-1+ [analyse ?token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token)] - (matchv ::M/objects [=expr] - [[?item ?type]] - (|do [=type (&type/clean $var ?type)] - (return (&/T ?item =type))) - ))))) + (|do [=expr (&&/analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] - (matchv ::M/objects [form] - [["lux;Meta" [_ syntax]]] + (|case form + ("lux;Meta" _ syntax) (&/V "lux;Meta" (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type*] - [["lux;TupleT" ?members]] + (|case exo-type* + ("lux;TupleT" ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) - [["lux;AllT" _]] + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-tuple analyse exo-type** ?elems)))) - [_] + _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (matchv ::M/objects [?values] - [["lux;Nil" _]] + (|do [output (|case ?values + ("lux;Nil") (analyse-tuple analyse exo-type (&/|list)) - [["lux;Cons" [?value ["lux;Nil" _]]]] + ("lux;Cons" ?value ("lux;Nil")) (analyse exo-type ?value) - [_] + _ (analyse-tuple analyse exo-type ?values) )] - (matchv ::M/objects [output] - [["lux;Cons" [x ["lux;Nil" _]]]] + (|case output + ("lux;Cons" x ("lux;Nil")) (return x) - [_] + _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type ident ?values] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] + (|do [exo-type* (|case exo-type + ("lux;VarT" ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] (&type/actual-type &type/Type)))) - [_] + _ (&type/actual-type exo-type))] - (matchv ::M/objects [exo-type*] - [["lux;VariantT" ?cases]] + (|case exo-type* + ("lux;VariantT" ?cases) (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] @@ -92,22 +90,22 @@ exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - [["lux;AllT" _]] + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** ident ?values)))) - [_] + _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [exo-type* (matchv ::M/objects [exo-type] - [["lux;VarT" ?id]] + (|do [exo-type* (|case exo-type + ("lux;VarT" ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - [["lux;AllT" _]] + ("lux;AllT" _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -116,21 +114,21 @@ ;; (|do [=type (&type/apply-type exo-type $var)] ;; (&type/actual-type =type)))) - [_] + _ (&type/actual-type exo-type)) - types (matchv ::M/objects [exo-type*] - [["lux;RecordT" ?table]] + types (|case exo-type* + ("lux;RecordT" ?table) (return ?table) - [_] + _ (fail (str "[Analyser Error] The type of a record must be a record type:\n" (&type/show-type exo-type*) "\n"))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] - (matchv ::M/objects [kv] - [[["lux;Meta" [_ ["lux;TagS" ?ident]]] ?value]] + (|case kv + [("lux;Meta" _ ["lux;TagS" ?ident]) ?value] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) @@ -138,7 +136,7 @@ =value (&&/analyse-1 analyse slot-type ?value)] (return (&/T ?tag =value))) - [_] + _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) @@ -146,14 +144,14 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] + endo-type (|case $def + ("lux;ValueD" ?type _) (return ?type) - [["lux;MacroD" _]] + ("lux;MacroD" _) (return &type/Macro) - [["lux;TypeD" _]] + ("lux;TypeD" _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -168,28 +166,28 @@ no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] - (matchv ::M/objects [outer] - [["lux;Nil" _]] + (|case outer + ("lux;Nil") (&/run-state (|do [module-name &/get-module-name] (analyse-global analyse exo-type module-name name)) state) - [["lux;Cons" [?genv ["lux;Nil" _]]]] + ("lux;Cons" ?genv ("lux;Nil")) (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) - (matchv ::M/objects [global] - [[["lux;Global" [?module* name*]] _]] + (|case global + [("lux;Global" ?module* name*) _] ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (matchv ::M/objects [$def] - [["lux;ValueD" [?type _]]] + endo-type (|case $def + ("lux;ValueD" ?type _) (return ?type) - [["lux;MacroD" _]] + ("lux;MacroD" _) (return &type/Macro) - [["lux;TypeD" _]] + ("lux;TypeD" _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -204,7 +202,7 @@ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) - [["lux;Cons" [top-outer _]]] + ("lux;Cons" top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) (&/|map #(&/get$ &/$NAME %) outer) @@ -232,15 +230,15 @@ (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] ;; (prn 'analyse-apply* (aget fun-type 0)) - (matchv ::M/objects [?args] - [["lux;Nil" _]] + (|case ?args + ("lux;Nil") (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type (&/|list)))) - [["lux;Cons" [?arg ?args*]]] + ("lux;Cons" ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] - (matchv ::M/objects [?fun-type*] - [["lux;AllT" [_aenv _aname _aarg _abody]]] + (|case ?fun-type* + ("lux;AllT" _aenv _aname _aarg _abody) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -248,8 +246,8 @@ (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + ("lux;VarT" ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) @@ -258,7 +256,7 @@ (return (&/T type** =args))) )))) - [["lux;LambdaT" [?input-t ?output-t]]] + ("lux;LambdaT" ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) @@ -266,19 +264,18 @@ ;; [["lux;VarT" ?id-t]] ;; (|do [ (&type/deref ?id-t)]) - [_] + _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) (defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] - (matchv ::M/objects [=fn] - [[=fn-form =fn-type]] - (matchv ::M/objects [=fn-form] - [["lux;Global" [?module ?name]]] + (|let [[=fn-form =fn-type] =fn] + (|case =fn-form + ("lux;Global" ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] - (matchv ::M/objects [$def] - [["lux;MacroD" macro]] + (|case $def + ("lux;MacroD" macro) (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] @@ -293,12 +290,12 @@ ] (&/flat-map% (partial analyse exo-type) macro-expansion*)) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) =output-t)))))) - [_] + _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) =output-t))))) @@ -316,8 +313,8 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] - (matchv ::M/objects [exo-type] - [["lux;AllT" _]] + (|case exo-type + ("lux;AllT" _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -326,38 +323,38 @@ ;; exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - [["lux;LambdaT" [?arg-t ?return-t]]] + ("lux;LambdaT" ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) - [_] + _ (fail (str "[Analyser Error] Functions require function types: " (&type/show-type exo-type*)))))) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] - (matchv ::M/objects [exo-type] - [["lux;AllT" [_env _self _arg _body]]] + (|case exo-type + ("lux;AllT" _env _self _arg _body) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (matchv ::M/objects [$var] - [["lux;VarT" ?id]] + (|case $var + ("lux;VarT" ?id) (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id) ;; dtype* (&type/actual-type dtype) ] - (matchv ::M/objects [dtype] - [["lux;BoundT" ?vname]] + (|case dtype + ("lux;BoundT" ?vname) (return (&/T _expr exo-type)) - [["lux;ExT" _]] + ("lux;ExT" _) (return (&/T _expr exo-type)) - [["lux;VarT" ?_id]] + ("lux;VarT" ?_id) (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? @@ -365,11 +362,11 @@ (return (&/T _expr exo-type))) ) - [_] + _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) - [_] + _ (|do [exo-type* (&type/actual-type exo-type)] (analyse-lambda* analyse exo-type* ?self ?arg ?body)) )) @@ -389,15 +386,15 @@ (|do [=value (&/with-scope ?name (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] - (matchv ::M/objects [=value] - [[["lux;Global" [?r-module ?r-name]] _]] + (|case =value + [("lux;Global" ?r-module ?r-name) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] (return (&/|list))) - [_] + _ (do (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] (return (&/|list))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 327dad27f..c92b7b976 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -9,9 +9,9 @@ (ns lux.analyser.module (:refer-clojure :exclude [alias]) (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail*]] + (lux [base :as & :refer [|let |do return return* fail fail* |case]] [type :as &type] [host :as &host]) [lux.analyser.base :as &&])) @@ -44,8 +44,8 @@ (defn define [module name def-data type] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -57,7 +57,7 @@ ms)))) nil) - [_] + _ (fail* (str "[Analyser Error] Can't create a new global definition outside of a global environment: " module ";" name))))) (defn def-type [module name] @@ -65,17 +65,17 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[_ ["lux;TypeD" _]]] + (|case $def + [_ ("lux;TypeD" _)] (return* state &type/Type) - [[_ ["lux;MacroD" _]]] + [_ ("lux;MacroD" _)] (return* state &type/Macro) - [[_ ["lux;ValueD" [_type _]]]] + [_ ("lux;ValueD" _type _)] (return* state _type) - [[_ ["lux;AliasD" [?r-module ?r-name]]]] + [_ ("lux;AliasD" ?r-module ?r-name)] (&/run-state (def-type ?r-module ?r-name) state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) @@ -84,8 +84,8 @@ (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -97,7 +97,7 @@ ms)))) nil) - [_] + _ (fail* "[Analyser Error] Can't alias a global definition outside of a global environment.")))) (defn exists? [name] @@ -133,17 +133,16 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[exported? $$def]] + (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) - (matchv ::M/objects [$$def] - [["lux;AliasD" [?r-module ?r-name]]] + (|case $$def + ("lux;AliasD" ?r-module ?r-name) (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) ((find-def ?r-module ?r-name) state)) - [_] + _ (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) @@ -158,8 +157,8 @@ (fn [state] (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] - (matchv ::M/objects [$def] - [[exported? ["lux;ValueD" [?type _]]]] + (|case $def + [exported? ("lux;ValueD" ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -178,24 +177,24 @@ nil))) state) - [[_ ["lux;MacroD" _]]] + [_ ("lux;MacroD" _)] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) - [[_ _]] + [_ _] (fail* (str "[Analyser Error] Definition does not have macro type: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module does not exist: " module))))) (defn export [module name] (fn [state] - (matchv ::M/objects [(&/get$ &/$ENVS state)] - [["lux;Cons" [?env ["lux;Nil" _]]]] + (|case (&/get$ &/$ENVS state) + ("lux;Cons" ?env ("lux;Nil")) (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] - (matchv ::M/objects [$def] - [[true _]] + (|case $def + [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) - [[false ?data]] + [false ?data] (return* (->> state (&/update$ &/$MODULES (fn [ms] (&/|update module (fn [m] @@ -206,7 +205,7 @@ nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) - [_] + _ (fail* "[Analyser Error] Can't export a global definition outside of a global environment.")))) (def defs @@ -214,22 +213,20 @@ (fn [state] (return* state (&/|map (fn [kv] - (|let [[k v] kv] - (matchv ::M/objects [v] - [[?exported? ?def]] - (do ;; (prn 'defs k ?exported?) - (matchv ::M/objects [?def] - [["lux;AliasD" [?r-module ?r-name]]] - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - - [["lux;MacroD" _]] - (&/T ?exported? k "M") - - [["lux;TypeD" _]] - (&/T ?exported? k "T") - - [_] - (&/T ?exported? k "V")))))) + (|let [[k [?exported? ?def]] kv] + (do ;; (prn 'defs k ?exported?) + (|case ?def + ("lux;AliasD" ?r-module ?r-name) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + + ("lux;MacroD" _) + (&/T ?exported? k "M") + + ("lux;TypeD" _) + (&/T ?exported? k "T") + + _ + (&/T ?exported? k "V"))))) (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) (def imports diff --git a/src/lux/base.clj b/src/lux/base.clj index 85e8df4d1..bcd113daa 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,6 +12,7 @@ clojure.core.match.array)) ;; [Tags] +(def $Nil "lux;Nil") (def $Cons "lux;Cons") ;; [Fields] @@ -73,10 +74,33 @@ (defn return* [state value] (V "lux;Right" (T state value))) +(defn transform-pattern [pattern] + (cond (vector? pattern) (mapv transform-pattern pattern) + (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] + (vec (cons (eval (first pattern)) + (list (case (count parts) + 0 '_ + 1 (first parts) + ;; else + `[~@parts]))))) + :else pattern + )) + +(defmacro |case [value & branches] + (assert (= 0 (mod (count branches) 2))) + (let [value* (if (vector? value) + [`(T ~@value)] + [value])] + `(matchv ::M/objects ~value* + ~@(mapcat (fn [[pattern body]] + (list [(transform-pattern pattern)] + body)) + (partition 2 branches))))) + (defmacro |let [bindings body] (reduce (fn [inner [left right]] - `(matchv ::M/objects [~right] - [~left] + `(|case ~right + ~left ~inner)) body (reverse (partition 2 bindings)))) @@ -94,59 +118,62 @@ (reverse (partition 2 elems)))) (defn |get [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) nil - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) v (|get slot table*)))) (defn |put [slot value table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) (V "lux;Cons" (T (T slot value) table*)) - (V "lux;Cons" (T (T k v) (|put slot value table*)))))) + (V "lux;Cons" (T (T k v) (|put slot value table*)))) + + _ + (assert false (prn-str '|put (aget table 0))))) (defn |remove [slot table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k v] table*]]] + ($Cons [k v] table*) (if (.equals ^Object k slot) table* (V "lux;Cons" (T (T k v) (|remove slot table*)))))) (defn |update [k f table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) table - [["lux;Cons" [[k* v] table*]]] + ($Cons [k* v] table*) (if (.equals ^Object k k*) (V "lux;Cons" (T (T k* (f v)) table*)) (V "lux;Cons" (T (T k* v) (|update k f table*)))))) (defn |head [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (assert false) - [["lux;Cons" [x _]]] + ($Cons x _) x)) (defn |tail [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (assert false) - [["lux;Cons" [_ xs*]]] + ($Cons _ xs*) xs*)) ;; [Resources/Monads] @@ -161,11 +188,11 @@ (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] - (matchv ::M/objects [inputs] - [["lux;Right" [?state ?datum]]] + (|case inputs + ("lux;Right" ?state ?datum) ((step ?datum) ?state) - [["lux;Left" _]] + ("lux;Left" _) inputs )))) @@ -177,8 +204,8 @@ ;; else `(bind ~computation (fn [val#] - (matchv ::M/objects [val#] - [~label] + (|case val# + ~label ~inner))))) return (reverse (partition 2 steps)))) @@ -188,90 +215,90 @@ (V "lux;Cons" (T head tail))) (defn |++ [xs ys] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) ys - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T x (|++ xs* ys))))) (defn |map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T (f x) (|map f xs*))))) (defn |empty? [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) true - [["lux;Cons" [_ _]]] + ($Cons _ _) false)) (defn |filter [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (V "lux;Cons" (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|++ (f x) (flat-map f xs*)))) (defn |split-with [p xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (T xs xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] (T (|cons x pre) post)) (T (V "lux;Nil" nil) xs)))) (defn |contains? [k table] - (matchv ::M/objects [table] - [["lux;Nil" _]] + (|case table + ($Nil) false - [["lux;Cons" [[k* _] table*]]] + ($Cons [k* _] table*) (or (.equals ^Object k k*) (|contains? k table*)))) (defn fold [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) init - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (fold f (f init x) xs*))) (defn fold% [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [init* (f init x)] (fold% f init* xs*)))) (defn folds [f init xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (|list init) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|cons init (folds f (f init x) xs*)))) (defn |length [xs] @@ -293,47 +320,47 @@ _2)) (defn zip2 [xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (V "lux;Cons" (T (T x y) (zip2 xs* ys*))) [_ _] (V "lux;Nil" nil))) (defn |keys [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] + (|case plist + ($Nil) (|list) - [["lux;Cons" [[k v] plist*]]] + ($Cons [k v] plist*) (|cons k (|keys plist*)))) (defn |vals [plist] - (matchv ::M/objects [plist] - [["lux;Nil" _]] + (|case plist + ($Nil) (|list) - [["lux;Cons" [[k v] plist*]]] + ($Cons [k v] plist*) (|cons v (|vals plist*)))) (defn |interpose [sep xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) xs - [["lux;Cons" [_ ["lux;Nil" _]]]] + ($Cons _ ($Nil)) xs - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (return xs) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (|do [y (f x) ys ( f xs*)] (return ( y ys))))) @@ -345,11 +372,11 @@ (fold |++ (V "lux;Nil" nil) xss)) (defn |as-pairs [xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x ["lux;Cons" [y xs*]]]]] + (|case xs + ($Cons x ($Cons y xs*)) (V "lux;Cons" (T (T x y) (|as-pairs xs*))) - [_] + _ (V "lux;Nil" nil))) (defn |reverse [xs] @@ -368,18 +395,18 @@ (return* state state))) (defn try-all% [monads] - (matchv ::M/objects [monads] - [["lux;Nil" _]] + (|case monads + ($Nil) (fail "There are no alternatives to try!") - [["lux;Cons" [m monads*]]] + ($Cons m monads*) (fn [state] (let [output (m state)] - (matchv ::M/objects [output monads*] - [["lux;Right" _] _] + (|case [output monads*] + [("lux;Right" _) _] output - [_ ["lux;Nil" _]] + [_ ($Nil)] output [_ _] @@ -395,11 +422,11 @@ (defn exhaust% [step] (fn [state] - (matchv ::M/objects [(step state)] - [["lux;Right" [state* _]]] + (|case (step state) + ("lux;Right" state* _) ((exhaust% step) state*) - [["lux;Left" msg]] + ("lux;Left" msg) (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -510,23 +537,23 @@ (defn save-module [body] (fn [state] - (matchv ::M/objects [(body state)] - [["lux;Right" [state* output]]] + (|case (body state) + ("lux;Right" state* output) (return* (->> state* (set$ $ENVS (get$ $ENVS state)) (set$ $SOURCE (get$ $SOURCE state))) output) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg)))) (defn with-eval [body] (fn [state] - (matchv ::M/objects [(body (set$ $EVAL? true state))] - [["lux;Right" [state* output]]] + (|case (body (set$ $EVAL? true state)) + ("lux;Right" state* output) (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg)))) (def get-eval @@ -536,11 +563,11 @@ (def get-writer (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] - (matchv ::M/objects [writer*] - [["lux;Some" datum]] + (|case writer* + ("lux;Some" datum) (return* state datum) - [_] + _ (fail* "Writer hasn't been set."))))) (def get-top-local-env @@ -556,11 +583,11 @@ (return* (set$ $SEED (inc seed) state) seed)))) (defn ->seq [xs] - (matchv ::M/objects [xs] - [["lux;Nil" _]] + (|case xs + ($Nil) (list) - [["lux;Cons" [x xs*]]] + ($Cons x xs*) (cons x (->seq xs*)))) (defn ->list [seq] @@ -575,21 +602,21 @@ (def get-module-name (fn [state] - (matchv ::M/objects [(|reverse (get$ $ENVS state))] - [["lux;Nil"]] + (|case (|reverse (get$ $ENVS state)) + ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") - [["lux;Cons" [?global _]]] + ($Cons ?global _) (return* state (get$ $NAME ?global))))) (defn with-scope [name body] (fn [state] (let [output (body (update$ $ENVS #(|cons (env name) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [state* datum]]] + (|case output + ("lux;Right" state* datum) (return* (update$ $ENVS |tail state*) datum) - [_] + _ output)))) (defn run-state [monad state] @@ -611,24 +638,24 @@ (defn with-writer [writer body] (fn [state] (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) ?value) - [_] + _ output)))) (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] (let [output (body (set$ $EXPECTED type state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) ?value) - [_] + _ output)))) (defn with-cursor [cursor body] @@ -637,50 +664,50 @@ body (fn [state] (let [output (body (set$ $cursor cursor state))] - (matchv ::M/objects [output] - [["lux;Right" [?state ?value]]] + (|case output + ("lux;Right" ?state ?value) (return* (set$ $cursor (get$ $cursor state) ?state) ?value) - [_] + _ output))))) (defn show-ast [ast] - (matchv ::M/objects [ast] - [["lux;Meta" [_ ["lux;BoolS" ?value]]]] + (|case ast + ("lux;Meta" _ ["lux;BoolS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;IntS" ?value]]]] + ("lux;Meta" _ ["lux;IntS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;RealS" ?value]]]] + ("lux;Meta" _ ["lux;RealS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;CharS" ?value]]]] + ("lux;Meta" _ ["lux;CharS" ?value]) (pr-str ?value) - [["lux;Meta" [_ ["lux;TextS" ?value]]]] + ("lux;Meta" _ ["lux;TextS" ?value]) (str "\"" ?value "\"") - [["lux;Meta" [_ ["lux;TagS" [?module ?tag]]]]] + ("lux;Meta" _ ["lux;TagS" ?module ?tag]) (str "#" ?module ";" ?tag) - [["lux;Meta" [_ ["lux;SymbolS" [?module ?ident]]]]] + ("lux;Meta" _ ["lux;SymbolS" ?module ?ident]) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [["lux;Meta" [_ ["lux;TupleS" ?elems]]]] + ("lux;Meta" _ ["lux;TupleS" ?elems]) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [["lux;Meta" [_ ["lux;RecordS" ?elems]]]] + ("lux;Meta" _ ["lux;RecordS" ?elems]) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [["lux;Meta" [_ ["lux;FormS" ?elems]]]] + ("lux;Meta" _ ["lux;FormS" ?elems]) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) @@ -689,57 +716,57 @@ (str ?module ";" ?name))) (defn fold2% [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [init* (f init x y)] (fold2% f init* xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return init) [_ _] (fail "Lists don't match in size."))) (defn map2% [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] (return (|cons z zs))) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] (return (V "lux;Nil" nil)) [_ _] (fail "Lists don't match in size."))) (defn map2 [f xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (|cons (f x y) (map2 f xs* ys*)) [_ _] (V "lux;Nil" nil))) (defn fold2 [f init xs ys] - (matchv ::M/objects [xs ys] - [["lux;Cons" [x xs*]] ["lux;Cons" [y ys*]]] + (|case [xs ys] + [($Cons x xs*) ($Cons y ys*)] (and init (fold2 f (f init x y) xs* ys*)) - [["lux;Nil" _] ["lux;Nil" _]] + [($Nil) ($Nil)] init [_ _] false)) (defn ^:private enumerate* [idx xs] - (matchv ::M/objects [xs] - [["lux;Cons" [x xs*]]] + (|case xs + ($Cons x xs*) (V "lux;Cons" (T (T idx x) (enumerate* (inc idx) xs*))) - [["lux;Nil" _]] + ($Nil) xs )) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 4c12f9519..7463bdce7 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -11,9 +11,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] + (lux [base :as & :refer [|let |do return* return fail fail* |case]] [type :as &type] [reader :as &reader] [lexer :as &lexer] @@ -38,327 +38,338 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - (matchv ::M/objects [syntax] - [[?form ?type]] - (matchv ::M/objects [?form] - [["bool" ?value]] + (|let [[?form ?type] syntax] + (|case ?form + ("bool" ?value) (&&lux/compile-bool compile-expression ?type ?value) - [["int" ?value]] + ("int" ?value) (&&lux/compile-int compile-expression ?type ?value) - [["real" ?value]] + ("real" ?value) (&&lux/compile-real compile-expression ?type ?value) - [["char" ?value]] + ("char" ?value) (&&lux/compile-char compile-expression ?type ?value) - [["text" ?value]] + ("text" ?value) (&&lux/compile-text compile-expression ?type ?value) - [["tuple" ?elems]] + ("tuple" ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - [["record" ?elems]] + ("record" ?elems) (&&lux/compile-record compile-expression ?type ?elems) - [["lux;Local" ?idx]] + ("lux;Local" ?idx) (&&lux/compile-local compile-expression ?type ?idx) - [["captured" [?scope ?captured-id ?source]]] + ("captured" ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - [["lux;Global" [?owner-class ?name]]] + ("lux;Global" ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) - [["apply" [?fn ?args]]] + ("apply" ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - [["variant" [?tag ?members]]] + ("variant" ?tag ?members) (&&lux/compile-variant compile-expression ?type ?tag ?members) - [["case" [?value ?match]]] + ("case" ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) - [["lambda" [?scope ?env ?body]]] + ("lambda" ?scope ?env ?body) (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - [["ann" [?value-ex ?type-ex]]] + ("ann" ?value-ex ?type-ex) (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) ;; Characters - [["jvm-ceq" [?x ?y]]] + ("jvm-ceq" ?x ?y) (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - [["jvm-clt" [?x ?y]]] + ("jvm-clt" ?x ?y) (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - [["jvm-cgt" [?x ?y]]] + ("jvm-cgt" ?x ?y) (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic - [["jvm-iadd" [?x ?y]]] + ("jvm-iadd" ?x ?y) (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - [["jvm-isub" [?x ?y]]] + ("jvm-isub" ?x ?y) (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - [["jvm-imul" [?x ?y]]] + ("jvm-imul" ?x ?y) (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - [["jvm-idiv" [?x ?y]]] + ("jvm-idiv" ?x ?y) (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - [["jvm-irem" [?x ?y]]] + ("jvm-irem" ?x ?y) (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - [["jvm-ieq" [?x ?y]]] + ("jvm-ieq" ?x ?y) (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - [["jvm-ilt" [?x ?y]]] + ("jvm-ilt" ?x ?y) (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - [["jvm-igt" [?x ?y]]] + ("jvm-igt" ?x ?y) (&&host/compile-jvm-igt compile-expression ?type ?x ?y) ;; Long arithmetic - [["jvm-ladd" [?x ?y]]] + ("jvm-ladd" ?x ?y) (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - [["jvm-lsub" [?x ?y]]] + ("jvm-lsub" ?x ?y) (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - [["jvm-lmul" [?x ?y]]] + ("jvm-lmul" ?x ?y) (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - [["jvm-ldiv" [?x ?y]]] + ("jvm-ldiv" ?x ?y) (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - [["jvm-lrem" [?x ?y]]] + ("jvm-lrem" ?x ?y) (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - [["jvm-leq" [?x ?y]]] + ("jvm-leq" ?x ?y) (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - [["jvm-llt" [?x ?y]]] + ("jvm-llt" ?x ?y) (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - [["jvm-lgt" [?x ?y]]] + ("jvm-lgt" ?x ?y) (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) ;; Float arithmetic - [["jvm-fadd" [?x ?y]]] + ("jvm-fadd" ?x ?y) (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - [["jvm-fsub" [?x ?y]]] + ("jvm-fsub" ?x ?y) (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - [["jvm-fmul" [?x ?y]]] + ("jvm-fmul" ?x ?y) (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - [["jvm-fdiv" [?x ?y]]] + ("jvm-fdiv" ?x ?y) (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - [["jvm-frem" [?x ?y]]] + ("jvm-frem" ?x ?y) (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - [["jvm-feq" [?x ?y]]] + ("jvm-feq" ?x ?y) (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - [["jvm-flt" [?x ?y]]] + ("jvm-flt" ?x ?y) (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - [["jvm-fgt" [?x ?y]]] + ("jvm-fgt" ?x ?y) (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) ;; Double arithmetic - [["jvm-dadd" [?x ?y]]] + ("jvm-dadd" ?x ?y) (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - [["jvm-dsub" [?x ?y]]] + ("jvm-dsub" ?x ?y) (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - [["jvm-dmul" [?x ?y]]] + ("jvm-dmul" ?x ?y) (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - [["jvm-ddiv" [?x ?y]]] + ("jvm-ddiv" ?x ?y) (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - [["jvm-drem" [?x ?y]]] + ("jvm-drem" ?x ?y) (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - [["jvm-deq" [?x ?y]]] + ("jvm-deq" ?x ?y) (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - [["jvm-dlt" [?x ?y]]] + ("jvm-dlt" ?x ?y) (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - [["jvm-dgt" [?x ?y]]] + ("jvm-dgt" ?x ?y) (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - [["jvm-null" _]] + ("jvm-null" _) (&&host/compile-jvm-null compile-expression ?type) - [["jvm-null?" ?object]] + ("jvm-null?" ?object) (&&host/compile-jvm-null? compile-expression ?type ?object) - [["jvm-new" [?class ?classes ?args]]] + ("jvm-new" ?class ?classes ?args) (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - [["jvm-getstatic" [?class ?field]]] + ("jvm-getstatic" ?class ?field) (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - [["jvm-getfield" [?class ?field ?object]]] + ("jvm-getfield" ?class ?field ?object) (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - [["jvm-putstatic" [?class ?field ?value]]] + ("jvm-putstatic" ?class ?field ?value) (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - [["jvm-putfield" [?class ?field ?object ?value]]] + ("jvm-putfield" ?class ?field ?object ?value) (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - [["jvm-invokestatic" [?class ?method ?classes ?args]]] + ("jvm-invokestatic" ?class ?method ?classes ?args) (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - [["jvm-invokevirtual" [?class ?method ?classes ?object ?args]]] + ("jvm-invokevirtual" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokeinterface" [?class ?method ?classes ?object ?args]]] + ("jvm-invokeinterface" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-invokespecial" [?class ?method ?classes ?object ?args]]] + ("jvm-invokespecial" ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - [["jvm-new-array" [?class ?length]]] + ("jvm-new-array" ?class ?length) (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - [["jvm-aastore" [?array ?idx ?elem]]] + ("jvm-aastore" ?array ?idx ?elem) (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - [["jvm-aaload" [?array ?idx]]] + ("jvm-aaload" ?array ?idx) (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - [["jvm-try" [?body ?catches ?finally]]] + ("jvm-try" ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - [["jvm-throw" ?ex]] + ("jvm-throw" ?ex) (&&host/compile-jvm-throw compile-expression ?type ?ex) - [["jvm-monitorenter" ?monitor]] + ("jvm-monitorenter" ?monitor) (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - [["jvm-monitorexit" ?monitor]] + ("jvm-monitorexit" ?monitor) (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - [["jvm-d2f" ?value]] + ("jvm-d2f" ?value) (&&host/compile-jvm-d2f compile-expression ?type ?value) - [["jvm-d2i" ?value]] + ("jvm-d2i" ?value) (&&host/compile-jvm-d2i compile-expression ?type ?value) - [["jvm-d2l" ?value]] + ("jvm-d2l" ?value) (&&host/compile-jvm-d2l compile-expression ?type ?value) - [["jvm-f2d" ?value]] + ("jvm-f2d" ?value) (&&host/compile-jvm-f2d compile-expression ?type ?value) - [["jvm-f2i" ?value]] + ("jvm-f2i" ?value) (&&host/compile-jvm-f2i compile-expression ?type ?value) - [["jvm-f2l" ?value]] + ("jvm-f2l" ?value) (&&host/compile-jvm-f2l compile-expression ?type ?value) - [["jvm-i2b" ?value]] + ("jvm-i2b" ?value) (&&host/compile-jvm-i2b compile-expression ?type ?value) - [["jvm-i2c" ?value]] + ("jvm-i2c" ?value) (&&host/compile-jvm-i2c compile-expression ?type ?value) - [["jvm-i2d" ?value]] + ("jvm-i2d" ?value) (&&host/compile-jvm-i2d compile-expression ?type ?value) - [["jvm-i2f" ?value]] + ("jvm-i2f" ?value) (&&host/compile-jvm-i2f compile-expression ?type ?value) - [["jvm-i2l" ?value]] + ("jvm-i2l" ?value) (&&host/compile-jvm-i2l compile-expression ?type ?value) - [["jvm-i2s" ?value]] + ("jvm-i2s" ?value) (&&host/compile-jvm-i2s compile-expression ?type ?value) - [["jvm-l2d" ?value]] + ("jvm-l2d" ?value) (&&host/compile-jvm-l2d compile-expression ?type ?value) - [["jvm-l2f" ?value]] + ("jvm-l2f" ?value) (&&host/compile-jvm-l2f compile-expression ?type ?value) - [["jvm-l2i" ?value]] + ("jvm-l2i" ?value) (&&host/compile-jvm-l2i compile-expression ?type ?value) - [["jvm-iand" [?x ?y]]] + ("jvm-iand" ?x ?y) (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - [["jvm-ior" [?x ?y]]] + ("jvm-ior" ?x ?y) (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - [["jvm-land" [?x ?y]]] + ("jvm-ixor" ?x ?y) + (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) + + ("jvm-ishl" ?x ?y) + (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) + + ("jvm-ishr" ?x ?y) + (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) + + ("jvm-iushr" ?x ?y) + (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) + + ("jvm-land" ?x ?y) (&&host/compile-jvm-land compile-expression ?type ?x ?y) - [["jvm-lor" [?x ?y]]] + ("jvm-lor" ?x ?y) (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - [["jvm-lxor" [?x ?y]]] + ("jvm-lxor" ?x ?y) (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - [["jvm-lshl" [?x ?y]]] + ("jvm-lshl" ?x ?y) (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - [["jvm-lshr" [?x ?y]]] + ("jvm-lshr" ?x ?y) (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - [["jvm-lushr" [?x ?y]]] + ("jvm-lushr" ?x ?y) (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - [["jvm-instanceof" [?class ?object]]] + ("jvm-instanceof" ?class ?object) (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) (defn ^:private compile-statement [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body]]] + (|case syntax + ("def" ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + ("declare-macro" ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + ("jvm-program" ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] + ("jvm-interface" ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private compile-token [syntax] - (matchv ::M/objects [syntax] - [["def" [?name ?body]]] + (|case syntax + ("def" ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - [["declare-macro" [?module ?name]]] + ("declare-macro" ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - [["jvm-program" ?body]] + ("jvm-program" ?body) (&&host/compile-jvm-program compile-expression ?body) - [["jvm-interface" [?name ?supers ?methods]]] + ("jvm-interface" ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - [["jvm-class" [?name ?super-class ?interfaces ?fields ?methods]]] + ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) - [_] + _ (compile-expression syntax))) (defn ^:private eval! [expr] @@ -413,10 +424,10 @@ ;; _ (prn 'compile-module name =class) ]] (fn [state] - (matchv ::M/objects [((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state))] - [["lux;Right" [?state _]]] + (|case ((&/with-writer =class + (&/exhaust% compiler-step)) + (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) + ("lux;Right" ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports :let [_ (doto =class @@ -437,7 +448,7 @@ (&&/save-class! "_" (.toByteArray =class))) ?state) - [["lux;Left" ?message]] + ("lux;Left" ?message) (fail* ?message))))))) )) )) @@ -448,11 +459,11 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (matchv ::M/objects [((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil))] - [["lux;Right" [?state _]]] + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + ("lux;Right" ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) (&&package/package program-module)) - [["lux;Left" ?message]] + ("lux;Left" ?message) (assert false ?message))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 565eae898..2b6f2e919 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -10,9 +10,9 @@ (:refer-clojure :exclude [load]) (:require [clojure.string :as string] [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] @@ -126,8 +126,8 @@ "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) def-meta (get-field "_meta" def-class)] - (matchv ::M/objects [def-meta] - [["lux;ValueD" [def-type _]]] + (|case def-meta + ("lux;ValueD" def-type _) (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 906cc1ca8..d27577be1 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -9,9 +9,9 @@ (ns lux.compiler.case (:require (clojure [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -26,13 +26,13 @@ ;; [Utils] (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] - (matchv ::M/objects [?match] - [["StoreTestAC" ?idx]] + (|case ?match + ("StoreTestAC" ?idx) (doto writer (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - [["BoolTestAC" ?value]] + ("BoolTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) @@ -42,7 +42,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["IntTestAC" ?value]] + ("IntTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) @@ -53,7 +53,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RealTestAC" ?value]] + ("RealTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) @@ -64,7 +64,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["CharTestAC" ?value]] + ("CharTestAC" ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) @@ -74,7 +74,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TextTestAC" ?value]] + ("TextTestAC" ?value) (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -83,7 +83,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["TupleTestAC" ?members]] + ("TupleTestAC" ?members) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -101,7 +101,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["RecordTestAC" ?slots]] + ("RecordTestAC" ?slots) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -124,7 +124,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - [["VariantTestAC" [?tag ?test]]] + ("VariantTestAC" ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 542bd9a40..bde19d8fb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -51,35 +51,35 @@ double-class "java.lang.Double" char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] - (matchv ::M/objects [*type*] - [["lux;TupleT" ["lux;Nil" _]]] + (|case *type* + ("lux;TupleT" ("lux;Nil")) (.visitInsn *writer* Opcodes/ACONST_NULL) - [["lux;DataT" "boolean"]] + ("lux;DataT" "boolean") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - [["lux;DataT" "byte"]] + ("lux;DataT" "byte") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - [["lux;DataT" "short"]] + ("lux;DataT" "short") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - [["lux;DataT" "int"]] + ("lux;DataT" "int") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - [["lux;DataT" "long"]] + ("lux;DataT" "long") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - [["lux;DataT" "float"]] + ("lux;DataT" "float") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - [["lux;DataT" "double"]] + ("lux;DataT" "double") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - [["lux;DataT" "char"]] + ("lux;DataT" "char") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - [["lux;DataT" _]] + ("lux;DataT" _) nil) *writer*)) @@ -413,16 +413,16 @@ $to (new Label) $end (new Label) $catch-finally (new Label) - compile-finally (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + compile-finally (|case ?finally + ("lux;Some" ?finally*) (|do [_ (return nil) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) + ("lux;None") (|do [_ (return nil) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -447,14 +447,14 @@ catch-boundaries) ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] - _ (matchv ::M/objects [?finally] - [["lux;Some" ?finally*]] (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) - [["lux;None" _]] (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + _ (|case ?finally + ("lux;Some" ?finally*) (|do [_ (compile ?finally*) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) + ("lux;None") (|do [_ (return nil) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) @@ -533,11 +533,14 @@ compile-jvm-iand Opcodes/IAND "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-ior Opcodes/IOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ixor Opcodes/IXOR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishl Opcodes/ISHL "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-ishr Opcodes/ISHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" + compile-jvm-iushr Opcodes/IUSHR "intValue" "()I" "java.lang.Integer" "intValue" "()I" "java.lang.Integer" "java.lang.Integer" "(I)V" compile-jvm-land Opcodes/LAND "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lor Opcodes/LOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" compile-jvm-lxor Opcodes/LXOR "longValue" "()J" "java.lang.Long" "longValue" "()J" "java.lang.Long" "java.lang.Long" "(J)V" - compile-jvm-lshl Opcodes/LSHL "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lshr Opcodes/LSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" compile-jvm-lushr Opcodes/LUSHR "longValue" "()J" "java.lang.Long" "intValue" "()I" "java.lang.Integer" "java.lang.Long" "(J)V" diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index ccd12e68a..0d1ea4844 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [|do return* return fail fail* |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -46,8 +46,8 @@ (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [("captured" _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -83,8 +83,8 @@ (.visitTypeInsn Opcodes/NEW lambda-class) (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ _ ?source]] _]]] + (|case ?name+?captured + [?name [("captured" _ _ ?source) _]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -101,8 +101,8 @@ (-> (doto (.visitField (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL) captured-name clo-field-sig nil nil) (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (matchv ::M/objects [?name+?captured] - [[?name [["captured" [_ ?captured-id ?source]] _]]]) + (|case ?name+?captured + [?name [("captured" _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq ?env)]))) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index def5220f7..9a3a7a6f2 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -10,9 +10,9 @@ (:require (clojure [string :as string] [set :as set] [template :refer [do-template]]) - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -138,8 +138,8 @@ (defn ^:private compile-def-type [compile current-class ?body def-type] (|do [^MethodVisitor **writer** &/get-writer] - (matchv ::M/objects [def-type] - ["type"] + (|case def-type + "type" (|do [:let [;; ?type* (&&type/->analysis ?type) _ (doto **writer** ;; Tail: Begin @@ -160,13 +160,13 @@ ] (return nil)) - ["value"] + "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - ?def-type (matchv ::M/objects [?body] - [[["ann" [?def-value ?type-expr]] ?def-type]] + ?def-type (|case ?body + [("ann" ?def-value ?type-expr) ?def-type] ?type-expr - [[?def-value ?def-type]] + [?def-value ?def-type] (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 01141f8e4..bfa322206 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -7,9 +7,9 @@ ;; You must not remove this notice, or any other, from this software. (ns lux.compiler.type - (:require [clojure.core.match :as M :refer [matchv]] + (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]))) ;; [Utils] @@ -39,18 +39,18 @@ ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" - (matchv ::M/objects [type] - [["lux;DataT" ?class]] + (|case type + ("lux;DataT" ?class) (variant$ "lux;DataT" (text$ ?class)) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (variant$ "lux;TupleT" (&/fold (fn [tail head] (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?members))) - [["lux;VariantT" ?cases]] + ("lux;VariantT" ?cases) (variant$ "lux;VariantT" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -59,7 +59,7 @@ $Nil (&/|reverse ?cases))) - [["lux;RecordT" ?slots]] + ("lux;RecordT" ?slots) (variant$ "lux;RecordT" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -68,16 +68,16 @@ $Nil (&/|reverse ?slots))) - [["lux;LambdaT" [?input ?output]]] + ("lux;LambdaT" ?input ?output) (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - [["lux;AllT" [?env ?name ?arg ?body]]] + ("lux;AllT" ?env ?name ?arg ?body) (variant$ "lux;AllT" - (tuple$ (&/|list (matchv ::M/objects [?env] - [["lux;None" _]] + (tuple$ (&/|list (|case ?env + ("lux;None") (variant$ "lux;None" (tuple$ (&/|list))) - [["lux;Some" ??env]] + ("lux;Some" ??env) (variant$ "lux;Some" (&/fold (fn [tail head] (|let [[hlabel htype] head] @@ -89,9 +89,9 @@ (text$ ?arg) (->analysis ?body)))) - [["lux;BoundT" ?name]] + ("lux;BoundT" ?name) (variant$ "lux;BoundT" (text$ ?name)) - [["lux;AppT" [?fun ?arg]]] + ("lux;AppT" ?fun ?arg) (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 91582c526..2414d97b6 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -9,9 +9,9 @@ (ns lux.host (:require (clojure [string :as string] [template :refer [do-template]]) - [clojure.core.match :as M :refer [match matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) (:import (java.lang.reflect Field Method Modifier))) @@ -68,14 +68,14 @@ )) (defn ->java-sig [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" ?name]] + (|case type + ("lux;DataT" ?name) (->type-signature ?name) - [["lux;LambdaT" [_ _]]] + ("lux;LambdaT" _ _) (->type-signature function-class) - [["lux;TupleT" ["lux;Nil" _]]] + ("lux;TupleT" ("lux;Nil")) "V" )) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 966c322bf..aa05b48af 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -8,9 +8,9 @@ (ns lux.parser (:require [clojure.template :refer [do-template]] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail]] + (lux [base :as & :refer [|do return fail |case]] [lexer :as &lexer]))) ;; [Utils] @@ -18,11 +18,11 @@ (defn [parse] (|do [elems (&/repeat% parse) token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta [ _]]]] + (|case token + ("lux;Meta" meta [ _]) (return (&/V (&/fold &/|++ (&/|list) elems))) - [_] + _ (fail (str "[Parser Error] Unbalanced " "."))))) ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" @@ -33,60 +33,59 @@ (|do [elems* (&/repeat% parse) token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] - (matchv ::M/objects [token] - [["lux;Meta" [meta ["Close_Brace" _]]]] + (|case token + ("lux;Meta" meta ("Close_Brace" _)) (if (even? (&/|length elems)) (return (&/V "lux;RecordS" (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) - [_] + _ (fail (str "[Parser Error] Unbalanced braces."))))) ;; [Interface] (def parse - (|do [token &lexer/lex] - (matchv ::M/objects [token] - [["lux;Meta" [meta token*]]] - (matchv ::M/objects [token*] - [["White_Space" _]] - (return (&/|list)) + (|do [token &lexer/lex + :let [("lux;Meta" meta token*) token]] + (|case token* + ("White_Space" _) + (return (&/|list)) - [["Comment" _]] - (return (&/|list)) - - [["Bool" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) + ("Comment" _) + (return (&/|list)) + + ("Bool" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) - [["Int" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) + ("Int" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) - [["Real" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) + ("Real" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) - [["Char" ^String ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) + ("Char" ^String ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) - [["Text" ?value]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) + ("Text" ?value) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) - [["Symbol" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) + ("Symbol" ?ident) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) - [["Tag" ?ident]] - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) + ("Tag" ?ident) + (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) - [["Open_Paren" _]] - (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - - [["Open_Bracket" _]] - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + ("Open_Paren" _) + (|do [syntax (parse-form parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + + ("Open_Bracket" _) + (|do [syntax (parse-tuple parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [["Open_Brace" _]] - (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + ("Open_Brace" _) + (|do [syntax (parse-record parse)] + (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) - [_] - (fail "[Parser Error] Unknown lexer token.") - )))) + _ + (fail "[Parser Error] Unknown lexer token.") + ))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 9fd9b14ea..6bda8f166 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -8,40 +8,40 @@ (ns lux.reader (:require [clojure.string :as string] - [clojure.core.match :as M :refer [matchv]] + clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* |let]])) + [lux.base :as & :refer [|do return* return fail fail* |let |case]])) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (matchv ::M/objects [(&/get$ &/$SOURCE state)] - [["lux;Nil" _]] + (|case (&/get$ &/$SOURCE state) + ("lux;Nil") (fail* "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] line] - more]]] - (matchv ::M/objects [(body file-name line-num column-num line)] - [["No" msg]] + ("lux;Cons" [[file-name line-num column-num] line] + more) + (|case (body file-name line-num column-num line) + ("No" msg) (fail* msg) - [["Done" output]] + ("Done" output) (return* (&/set$ &/$SOURCE more state) output) - [["Yes" [output line*]]] + ("Yes" output line*) (return* (&/set$ &/$SOURCE (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (matchv ::M/objects [(body (&/get$ &/$SOURCE state))] - [["lux;Right" [reader* match]]] + (|case (body (&/get$ &/$SOURCE state)) + ("lux;Right" reader* match) (return* (&/set$ &/$SOURCE reader* state) match) - [["lux;Left" msg]] + ("lux;Left" msg) (fail* msg) ))) @@ -102,12 +102,12 @@ (fn [reader] (loop [prefix "" reader* reader] - (matchv ::M/objects [reader*] - [["lux;Nil" _]] + (|case reader* + ("lux;Nil") (&/V "lux;Left" "[Reader Error] EOF") - [["lux;Cons" [[[file-name line-num column-num] ^String line] - reader**]]] + ("lux;Cons" [[file-name line-num column-num] ^String line] + reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] (let [match-length (.length match) diff --git a/src/lux/type.clj b/src/lux/type.clj index e4117492c..ab8ea4e61 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -8,9 +8,9 @@ (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) - (:require [clojure.core.match :as M :refer [match matchv]] + (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) (declare show-type) @@ -191,33 +191,33 @@ (defn bound? [id] (fn [state] (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type] - [["lux;Some" type*]] + (|case type + ("lux;Some" type*) (return* state true) - [["lux;None" _]] + ("lux;None") (return* state false)) (fail* (str "[Type Error] Unknown type-var: " id))))) (defn deref [id] (fn [state] (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [type*] - [["lux;Some" type]] + (|case type* + ("lux;Some" type) (return* state type) - [["lux;None" _]] + ("lux;None") (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] - (matchv ::M/objects [tvar] - [["lux;Some" bound]] + (|case tvar + ("lux;Some" bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - [["lux;None" _]] + ("lux;None") (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) ts)) state) @@ -251,18 +251,18 @@ (|let [[?id ?type] binding] (if (.equals ^Object id ?id) (return binding) - (matchv ::M/objects [?type] - [["lux;None" _]] + (|case ?type + ("lux;None") (return binding) - [["lux;Some" ?type*]] - (matchv ::M/objects [?type*] - [["lux;VarT" ?id*]] + ("lux;Some" ?type*) + (|case ?type* + ("lux;VarT" ?id*) (if (.equals ^Object id ?id*) (return (&/T ?id (&/V "lux;None" nil))) (return binding)) - [_] + _ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V "lux;Some" ?type**))))) )))) @@ -288,46 +288,46 @@ (return output))) (defn clean* [?tid type] - (matchv ::M/objects [type] - [["lux;VarT" ?id]] + (|case type + ("lux;VarT" ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - [["lux;LambdaT" [?arg ?return]]] + ("lux;LambdaT" ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] (return (&/V "lux;LambdaT" (&/T =arg =return)))) - [["lux;AppT" [?lambda ?param]]] + ("lux;AppT" ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] (return (&/V "lux;AppT" (&/T =lambda =param)))) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (&/V "lux;TupleT" =members))) - [["lux;VariantT" ?members]] + ("lux;VariantT" ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;VariantT" =members))) - [["lux;RecordT" ?members]] + ("lux;RecordT" ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] (return (&/V "lux;RecordT" =members))) - [["lux;AllT" [?env ?name ?arg ?body]]] - (|do [=env (matchv ::M/objects [?env] - [["lux;None" _]] + ("lux;AllT" ?env ?name ?arg ?body) + (|do [=env (|case ?env + ("lux;None") (return ?env) - [["lux;Some" ?env*]] + ("lux;Some" ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) @@ -336,96 +336,96 @@ body* (clean* ?tid ?body)] (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) - [_] + _ (return type) )) (defn clean [tvar type] - (matchv ::M/objects [tvar] - [["lux;VarT" ?id]] + (|case tvar + ("lux;VarT" ?id) (clean* ?id type) - [_] + _ (fail (str "[Type Error] Not type-var: " (show-type tvar))))) (defn ^:private unravel-fun [type] - (matchv ::M/objects [type] - [["lux;LambdaT" [?in ?out]]] + (|case type + ("lux;LambdaT" ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] (&/T ??out (&/|cons ?in ?args))) - [_] + _ (&/T type (&/|list)))) (defn ^:private unravel-app [fun-type] - (matchv ::M/objects [fun-type] - [["lux;AppT" [?left ?right]]] + (|case fun-type + ("lux;AppT" ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) - [_] + _ (&/T fun-type (&/|list)))) (defn show-type [^objects type] - (matchv ::M/objects [type] - [["lux;DataT" name]] + (|case type + ("lux;DataT" name) (str "(^ " name ")") - [["lux;TupleT" elems]] + ("lux;TupleT" elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;VariantT" cases]] + ("lux;VariantT" cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k ["lux;TupleT" ["lux;Nil" _]]]] + (|case kv + [k ("lux;TupleT" ("lux;Nil"))] (str "#" k) - [[k v]] + [k v] (str "(#" k " " (show-type v) ")")))) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;RecordT" fields]] + ("lux;RecordT" fields) (str "(& " (->> fields (&/|map (fn [kv] - (matchv ::M/objects [kv] - [[k v]] + (|case kv + [k v] (str "#" k " " (show-type v))))) (&/|interpose " ") (&/fold str "")) ")") - [["lux;LambdaT" [input output]]] + ("lux;LambdaT" input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - [["lux;VarT" id]] + ("lux;VarT" id) (str "⌈" id "⌋") - [["lux;ExT" ?id]] + ("lux;ExT" ?id) (str "⟨" ?id "⟩") - [["lux;BoundT" name]] + ("lux;BoundT" name) name - [["lux;AppT" [_ _]]] + ("lux;AppT" _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - [["lux;AllT" [?env ?name ?arg ?body]]] + ("lux;AllT" ?env ?name ?arg ?body) (if (= "" ?name) (let [[args body] (loop [args (list ?arg) body* ?body] - (matchv ::M/objects [body*] - [["lux;AllT" [?env* ?name* ?arg* ?body*]]] + (|case body* + ("lux;AllT" ?env* ?name* ?arg* ?body*) (recur (cons ?arg* args) ?body*) - [_] + _ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) @@ -433,17 +433,17 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) - (let [output (matchv ::M/objects [x y] - [["lux;DataT" xname] ["lux;DataT" yname]] + (let [output (|case [x y] + [("lux;DataT" xname) ("lux;DataT" yname)] (.equals ^Object xname yname) - [["lux;TupleT" xelems] ["lux;TupleT" yelems]] + [("lux;TupleT" xelems) ("lux;TupleT" yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [["lux;VariantT" xcases] ["lux;VariantT" ycases]] + [("lux;VariantT" xcases) ("lux;VariantT" ycases)] (&/fold2 (fn [old xcase ycase] (|let [[xname xtype] xcase [yname ytype] ycase] @@ -451,7 +451,7 @@ true xcases ycases) - [["lux;RecordT" xslots] ["lux;RecordT" yslots]] + [("lux;RecordT" xslots) ("lux;RecordT" yslots)] (&/fold2 (fn [old xslot yslot] (|let [[xname xtype] xslot [yname ytype] yslot] @@ -459,23 +459,23 @@ true xslots yslots) - [["lux;LambdaT" [xinput xoutput]] ["lux;LambdaT" [yinput youtput]]] + [("lux;LambdaT" xinput xoutput) ("lux;LambdaT" yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [["lux;VarT" xid] ["lux;VarT" yid]] + [("lux;VarT" xid) ("lux;VarT" yid)] (.equals ^Object xid yid) - [["lux;BoundT" xname] ["lux;BoundT" yname]] + [("lux;BoundT" xname) ("lux;BoundT" yname)] (.equals ^Object xname yname) - [["lux;ExT" xid] ["lux;ExT" yid]] + [("lux;ExT" xid) ("lux;ExT" yid)] (.equals ^Object xid yid) - [["lux;AppT" [xlambda xparam]] ["lux;AppT" [ylambda yparam]]] + [("lux;AppT" xlambda xparam) ("lux;AppT" ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [["lux;AllT" [xenv xname xarg xbody]] ["lux;AllT" [yenv yname yarg ybody]]] + [("lux;AllT" xenv xname xarg xbody) ("lux;AllT" yenv yname yarg ybody)] (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] @@ -501,11 +501,11 @@ (defn ^:private fp-get [k fixpoints] (|let [[e a] k] - (matchv ::M/objects [fixpoints] - [["lux;Nil" _]] + (|case fixpoints + ("lux;Nil") (&/V "lux;None" nil) - [["lux;Cons" [[[e* a*] v*] fixpoints*]]] + ("lux;Cons" [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) (&/V "lux;Some" v*) @@ -521,73 +521,64 @@ "\n")) (defn beta-reduce [env type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] + (|case type + ("lux;VariantT" ?cases) (&/V "lux;VariantT" (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?cases)) - [["lux;RecordT" ?fields]] + ("lux;RecordT" ?fields) (&/V "lux;RecordT" (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?fields)) - [["lux;TupleT" ?members]] + ("lux;TupleT" ?members) (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) - [["lux;AppT" [?type-fn ?type-arg]]] + ("lux;AppT" ?type-fn ?type-arg) (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - [["lux;AllT" [?local-env ?local-name ?local-arg ?local-def]]] - (matchv ::M/objects [?local-env] - [["lux;None" _]] + ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) + (|case ?local-env + ("lux;None") (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def)) - [["lux;Some" _]] + ("lux;Some" _) type) - [["lux;LambdaT" [?input ?output]]] + ("lux;LambdaT" ?input ?output) (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) - [["lux;BoundT" ?name]] + ("lux;BoundT" ?name) (if-let [bound (&/|get ?name env)] (beta-reduce env bound) type) - [_] + _ type )) -(defn slot-type [record slot] - (fn [state] - (matchv ::M/objects [(&/|get slot record)] - [["lux;Left" msg]] - (fail* msg) - - [["lux;Right" type]] - (return* state type)))) - (defn apply-type [type-fn param] - (matchv ::M/objects [type-fn] - [["lux;AllT" [local-env local-name local-arg local-def]]] - (let [local-env* (matchv ::M/objects [local-env] - [["lux;None" _]] + (|case type-fn + ("lux;AllT" local-env local-name local-arg local-def) + (let [local-env* (|case local-env + ("lux;None") (&/|table) - [["lux;Some" local-env*]] + ("lux;Some" local-env*) local-env*)] (return (beta-reduce (->> local-env* (&/|put local-name type-fn) (&/|put local-arg param)) local-def))) - [["lux;AppT" [F A]]] + ("lux;AppT" F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) - [_] + _ (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] @@ -610,85 +601,85 @@ (defn ^:private check* [class-loader fixpoints expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) - (matchv ::M/objects [expected actual] - [["lux;VarT" ?eid] ["lux;VarT" ?aid]] + (|case [expected actual] + [("lux;VarT" ?eid) ("lux;VarT" ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] - (matchv ::M/objects [((deref ?eid) state)] - [["lux;Right" [state* ebound]]] + (|case ((deref ?eid) state) + ("lux;Right" state* ebound) (return* state* (&/V "lux;Some" ebound)) - [["lux;Left" _]] + ("lux;Left" _) (return* state (&/V "lux;None" nil)))) abound (fn [state] - (matchv ::M/objects [((deref ?aid) state)] - [["lux;Right" [state* abound]]] + (|case ((deref ?aid) state) + ("lux;Right" state* abound) (return* state* (&/V "lux;Some" abound)) - [["lux;Left" _]] + ("lux;Left" _) (return* state (&/V "lux;None" nil))))] - (matchv ::M/objects [ebound abound] - [["lux;None" _] ["lux;None" _]] + (|case [ebound abound] + [("lux;None" _) ("lux;None" _)] (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) - [["lux;Some" etype] ["lux;None" _]] + [("lux;Some" etype) ("lux;None" _)] (check* class-loader fixpoints etype actual) - [["lux;None" _] ["lux;Some" atype]] + [("lux;None" _) ("lux;Some" atype)] (check* class-loader fixpoints expected atype) - [["lux;Some" etype] ["lux;Some" atype]] + [("lux;Some" etype) ("lux;Some" atype)] (check* class-loader fixpoints etype atype)))) - [["lux;VarT" ?id] _] + [("lux;VarT" ?id) _] (fn [state] - (matchv ::M/objects [((set-var ?id actual) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id actual) state) + ("lux;Right" state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + ("lux;Left" _) ((|do [bound (deref ?id)] (check* class-loader fixpoints bound actual)) state))) - [_ ["lux;VarT" ?id]] + [_ ("lux;VarT" ?id)] (fn [state] - (matchv ::M/objects [((set-var ?id expected) state)] - [["lux;Right" [state* _]]] + (|case ((set-var ?id expected) state) + ("lux;Right" state* _) (return* state* (&/T fixpoints nil)) - [["lux;Left" _]] + ("lux;Left" _) ((|do [bound (deref ?id)] (check* class-loader fixpoints expected bound)) state))) - [["lux;AppT" [["lux;VarT" ?eid] A1]] ["lux;AppT" [["lux;VarT" ?aid] A2]]] + [("lux;AppT" ("lux;VarT" ?eid) A1) ("lux;AppT" ("lux;VarT" ?aid) A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?eid)] - (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] - (return* state* output) - - [["lux;Left" _]] - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) - state)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?eid)] + (fn [state] + (|case [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + state)] + ("lux;Right" state* output) + (return* state* output) + + ("lux;Left" _) + ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + state)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] - (matchv ::M/objects [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + ("lux;Left" _) + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) @@ -697,15 +688,15 @@ ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] + [("lux;AppT" ("lux;VarT" ?id) A1) ("lux;AppT" F2 A2)] (fn [state] - (matchv ::M/objects [((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F1 (deref ?id)] + (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) @@ -719,15 +710,15 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] + [("lux;AppT" F1 A1) ("lux;AppT" ("lux;VarT" ?id) A2)] (fn [state] - (matchv ::M/objects [((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) - state)] - [["lux;Right" [state* output]]] + (|case ((|do [F2 (deref ?id)] + (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + state) + ("lux;Right" state* output) (return* state* output) - [["lux;Left" _]] + ("lux;Left" _) ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) @@ -741,7 +732,7 @@ ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [["lux;AppT" [F A]] _] + [("lux;AppT" F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -752,33 +743,33 @@ (&/|interpose "\n\n") (&/fold str ""))) (assert false))] - (matchv ::M/objects [(fp-get fp-pair fixpoints)] - [["lux;Some" ?]] + (|case (fp-get fp-pair fixpoints) + ("lux;Some" ?) (if ? (return (&/T fixpoints nil)) (fail (check-error expected actual))) - [["lux;None" _]] + ("lux;None") (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [_ ["lux;AppT" [F A]]] + [_ ("lux;AppT" F A)] (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [["lux;AllT" _] _] + [("lux;AllT" _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ ["lux;AllT" _]] + [_ ("lux;AllT" _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints expected actual*)))) - [["lux;DataT" e!name] ["lux;DataT" "null"]] + [("lux;DataT" e!name) ("lux;DataT" "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -791,11 +782,11 @@ (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [["lux;LambdaT" [eI eO]] ["lux;LambdaT" [aI aO]]] + [("lux;LambdaT" eI eO) ("lux;LambdaT" aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [["lux;TupleT" e!members] ["lux;TupleT" a!members]] + [("lux;TupleT" e!members) ("lux;TupleT" a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) @@ -803,7 +794,7 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [["lux;VariantT" e!cases] ["lux;VariantT" a!cases]] + [("lux;VariantT" e!cases) ("lux;VariantT" a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] (|let [[e!name e!type] e!case [a!name a!type] a!case] @@ -815,7 +806,7 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [["lux;RecordT" e!slots] ["lux;RecordT" a!slots]] + [("lux;RecordT" e!slots) ("lux;RecordT" a!slots)] (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] (|let [[e!name e!type] e!slot [a!name a!type] a!slot] @@ -827,7 +818,7 @@ e!slots a!slots)] (return (&/T fixpoints* nil))) - [["lux;ExT" e!id] ["lux;ExT" a!id]] + [("lux;ExT" e!id) ("lux;ExT" a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -842,41 +833,41 @@ (return nil))) (defn apply-lambda [func param] - (matchv ::M/objects [func] - [["lux;LambdaT" [input output]]] + (|case func + ("lux;LambdaT" input output) (|do [_ (check* init-fixpoints input param)] (return output)) - [["lux;AllT" _]] + ("lux;AllT" _) (with-var (fn [$var] (|do [func* (apply-type func $var) =return (apply-lambda func* param)] (clean $var =return)))) - [_] + _ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] - (matchv ::M/objects [type] - [["lux;AppT" [?all ?param]]] + (|case type + ("lux;AppT" ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - [["lux;VarT" ?id]] + ("lux;VarT" ?id) (deref ?id) - [_] + _ (return type) )) (defn variant-case [case type] - (matchv ::M/objects [type] - [["lux;VariantT" ?cases]] + (|case type + ("lux;VariantT" ?cases) (if-let [case-type (&/|get case ?cases)] (return case-type) (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) - [_] + _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) -- cgit v1.2.3 From 39b1f7161c4fd5c9c5a90d2f85758ed9febfd4ef Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 19:06:00 -0400 Subject: - Fixed some errors with argument ordering with JVM arithmetic ops. --- src/lux/analyser.clj | 70 +++++++++++++++++++++++------------------------ src/lux/compiler/host.clj | 12 ++++---- 2 files changed, 41 insertions(+), 41 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index e49797fa5..95e8f5f43 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -286,53 +286,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -342,63 +342,63 @@ (|case token ;; Host special forms ;; Characters - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?y ("lux;Cons" ?x ("lux;Nil"))))) + ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index bde19d8fb..8a9c8dfcc 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,11 +88,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) @@ -130,11 +130,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) @@ -162,11 +162,11 @@ (defn [compile *type* ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer - _ (compile ?x) + _ (compile ?y) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ ))] - _ (compile ?y) + _ (compile ?x) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST +wrapper-class+) (.visitMethodInsn Opcodes/INVOKEVIRTUAL +wrapper-class+ )) -- cgit v1.2.3 From 8c448ad5500a732b2fd560f26d5e75fcaac80917 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 20:03:04 -0400 Subject: Started factoring out the tags used in variants within the compiler. --- src/lux/analyser.clj | 440 ++++++++++++++++++++++---------------------- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 30 +-- src/lux/analyser/env.clj | 2 +- src/lux/analyser/host.clj | 62 +++---- src/lux/analyser/lux.clj | 22 +-- src/lux/analyser/module.clj | 6 +- src/lux/base.clj | 131 +++++++------ src/lux/compiler.clj | 8 +- src/lux/compiler/host.clj | 14 +- src/lux/compiler/type.clj | 12 +- src/lux/host.clj | 2 +- src/lux/lexer.clj | 18 +- src/lux/parser.clj | 32 ++-- src/lux/reader.clj | 18 +- src/lux/type.clj | 156 ++++++++-------- 16 files changed, 487 insertions(+), 468 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 95e8f5f43..0ad6553bf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -22,17 +22,17 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_catch")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?ex-class)) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ex-arg)) - ("lux;Cons" ?catch-body - ("lux;Nil"))))))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) + (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) + (&/$Cons ?catch-body + (&/$Nil))))))) (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_finally")) - ("lux;Cons" ?finally-body - ("lux;Nil"))))) - (return (&/T catch+ (&/V "lux;Some" ?finally-body))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) + (&/$Cons ?finally-body + (&/$Nil))))) + (return (&/T catch+ (&/V &/$Some ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) @@ -40,46 +40,46 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new-array")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?length)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) + (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) + (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aastore")) - ("lux;Cons" ?array - ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) - ("lux;Cons" ?elem - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$Cons ?array + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons ?elem + (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_aaload")) - ("lux;Cons" ?array - ("lux;Cons" ("lux;Meta" _ ("lux;IntS" ?idx)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$Cons ?array + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_class")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?super-class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?interfaces)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?fields)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?methods)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) + (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) + (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) + (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_interface")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?supers)) - ?methods)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_program")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?args)) - ("lux;Cons" ?body - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$Cons ?body + (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) _ @@ -88,86 +88,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2f")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2i")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_d2l")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2d")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2i")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_f2l")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2b")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2c")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2d")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2f")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2l")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_i2s")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2d")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2f")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_l2i")) ("lux;Cons" ?value ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iand")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ior")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ixor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ishr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_land")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lxor")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshl")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lshr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lushr")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -176,108 +176,108 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_null?")) - ("lux;Cons" ?object - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$Cons ?object + (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_instanceof")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ?object - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons ?object + (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_new")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getstatic")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_getfield")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Cons" ?object - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Cons ?object + (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putstatic")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Cons" ?value - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Cons ?value + (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_putfield")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field)) - ("lux;Cons" ?object - ("lux;Cons" ?value - ("lux;Nil"))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$Cons ?object + (&/$Cons ?value + (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokestatic")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil"))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokevirtual")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ?object - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons ?object + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokeinterface")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ?object - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons ?object + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_invokespecial")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?class)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?classes)) - ("lux;Cons" ?object - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?args)) - ("lux;Nil")))))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons ?object + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_try")) - ("lux;Cons" ?body - ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V "lux;None" nil)) ?handlers)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$Cons ?body + ?handlers))) + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_throw")) - ("lux;Cons" ?ex - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$Cons ?ex + (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorenter")) - ("lux;Cons" ?monitor - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$Cons ?monitor + (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_monitorexit")) - ("lux;Cons" ?monitor - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$Cons ?monitor + (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) _ @@ -286,53 +286,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fdiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_frem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_feq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_flt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_fgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ddiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_drem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_deq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dlt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_dgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -342,63 +342,63 @@ (|case token ;; Host special forms ;; Characters - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ceq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_clt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_cgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_iadd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_isub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_imul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_idiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_irem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ieq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ilt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_igt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ladd")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lsub")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lmul")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_ldiv")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lrem")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_leq")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_llt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_jvm_lgt")) ("lux;Cons" ?x ("lux;Cons" ?y ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -406,57 +406,57 @@ (defn ^:private aba2 [analyse eval! compile-module compile-token exo-type token] (|case token - ("lux;SymbolS" ?ident) + (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_case")) - ("lux;Cons" ?value ?branches))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_lambda")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?self)) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?arg)) - ("lux;Cons" ?body - ("lux;Nil")))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$Cons ?body + (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_def")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) - ("lux;Cons" ?value - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_declare-macro")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?name)) - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_import")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?path)) - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) + (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:")) - ("lux;Cons" ?type - ("lux;Cons" ?value - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$Cons ?type + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_:!")) - ("lux;Cons" ?type - ("lux;Cons" ?value - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$Cons ?type + (&/$Cons ?value + (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_export")) - ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?ident)) - ("lux;Nil")))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" _ "_lux_alias")) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?alias)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?module)) - ("lux;Nil"))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) + (&/$Cons (&/$Meta _ (&/$TextS ?alias)) + (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) _ @@ -465,36 +465,36 @@ (defn ^:private aba1 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Standard special forms - ("lux;BoolS" ?value) + (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) - ("lux;IntS" ?value) + (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] (return (&/|list (&/T (&/V "int" ?value) exo-type)))) - ("lux;RealS" ?value) + (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] (return (&/|list (&/T (&/V "real" ?value) exo-type)))) - ("lux;CharS" ?value) + (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] (return (&/|list (&/T (&/V "char" ?value) exo-type)))) - ("lux;TextS" ?value) + (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] (return (&/|list (&/T (&/V "text" ?value) exo-type)))) - ("lux;TupleS" ?elems) + (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) - ("lux;RecordS" ?elems) + (&/$RecordS ?elems) (&&lux/analyse-record analyse exo-type ?elems) - ("lux;TagS" ?ident) + (&/$TagS ?ident) (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) - ("lux;SymbolS" _ "_jvm_null") + (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) _ @@ -510,16 +510,16 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - ("lux;Meta" meta ?token) + (&/$Meta meta ?token) (fn [state] (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" "") + (&/$Left "") (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) - ("lux;Left" msg) + (&/$Left msg) (fail* (add-loc (&/get$ &/$cursor state) msg)) )) )) @@ -543,13 +543,13 @@ (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type (|case token - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) ?values))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) - ("lux;Meta" meta ("lux;FormS" ("lux;Cons" ?fn ?args))) + (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - ("lux;Right" state* =fn) + (&/$Right state* =fn) (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index beeb57b08..ed81aa9bc 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -20,7 +20,7 @@ (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] (|case output - ("lux;Cons" x ("lux;Nil")) + (&/$Cons x (&/$Nil)) (return x) _ diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 2cdf233cc..0bbbde2d7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -17,7 +17,7 @@ ;; [Utils] (def ^:private unit - (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" (&/|list))))) + (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) (defn ^:private resolve-type [type] (|case type @@ -113,43 +113,43 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [("lux;Meta" _ pattern*) pattern] + (|let [(&/$Meta _ pattern*) pattern] (|case pattern* - ("lux;SymbolS" "" name) + (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] (return (&/T (&/V "StoreTestAC" idx) =kont))) - ("lux;SymbolS" ident) + (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - ("lux;BoolS" ?value) + (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] (return (&/T (&/V "BoolTestAC" ?value) =kont))) - ("lux;IntS" ?value) + (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] (return (&/T (&/V "IntTestAC" ?value) =kont))) - ("lux;RealS" ?value) + (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] (return (&/T (&/V "RealTestAC" ?value) =kont))) - ("lux;CharS" ?value) + (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] (return (&/T (&/V "CharTestAC" ?value) =kont))) - ("lux;TextS" ?value) + (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] (return (&/T (&/V "TextTestAC" ?value) =kont))) - ("lux;TupleS" ?members) + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) (|case value-type* @@ -169,7 +169,7 @@ _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - ("lux;RecordS" ?slots) + (&/$RecordS ?slots) (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] @@ -182,7 +182,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* slot] (|let [[sn sv] slot] (|case sn - ("lux;Meta" _ ("lux;TagS" ?ident)) + (&/$Meta _ (&/$TagS ?ident)) (|do [=tag (&&/resolved-ident ?ident)] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] @@ -199,14 +199,14 @@ _ (fail "[Pattern-matching Error] Record requires record-type."))) - ("lux;TagS" ?ident) + (&/$TagS ?ident) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) - ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TagS" ?ident)) + (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) @@ -215,7 +215,7 @@ 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V "lux;Meta" (&/T (&/T "" -1 -1) (&/V "lux;TupleS" ?values))) kont))] + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))] (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) ))) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index a39ec490a..9a8a6a3d7 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -32,7 +32,7 @@ (&/|tail stack)))) state))] (|case =return - ("lux;Right" ?state ?value) + (&/$Right ?state ?value) (return* (&/update$ &/$ENVS (fn [stack*] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER dec) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 707060323..06cb5ebfc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - ("lux;Meta" _ ("lux;TextS" ?text)) + (&/$Meta _ (&/$TextS ?text)) (return ?text) _ @@ -208,7 +208,7 @@ (defn analyse-jvm-new-array [analyse ?class ?length] (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) - (&/V "lux;Nil" nil))))))) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) @@ -224,28 +224,28 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - ("lux;Meta" _ ("lux;TextS" "public")) + (&/$Meta _ (&/$TextS "public")) (return (assoc so-far :visibility "public")) - ("lux;Meta" _ ("lux;TextS" "private")) + (&/$Meta _ (&/$TextS "private")) (return (assoc so-far :visibility "private")) - ("lux;Meta" _ ("lux;TextS" "protected")) + (&/$Meta _ (&/$TextS "protected")) (return (assoc so-far :visibility "protected")) - ("lux;Meta" _ ("lux;TextS" "static")) + (&/$Meta _ (&/$TextS "static")) (return (assoc so-far :static? true)) - ("lux;Meta" _ ("lux;TextS" "final")) + (&/$Meta _ (&/$TextS "final")) (return (assoc so-far :final? true)) - ("lux;Meta" _ ("lux;TextS" "abstract")) + (&/$Meta _ (&/$TextS "abstract")) (return (assoc so-far :abstract? true)) - ("lux;Meta" _ ("lux;TextS" "synchronized")) + (&/$Meta _ (&/$TextS "synchronized")) (return (assoc so-far :concurrency "synchronized")) - ("lux;Meta" _ ("lux;TextS" "volatile")) + (&/$Meta _ (&/$TextS "volatile")) (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?field-type)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?field-modifiers)) - ("lux;Nil")))))) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) + (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) + (&/$Nil)))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,17 +289,17 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-inputs)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-output)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?method-modifiers)) - ("lux;Cons" ?method-body - ("lux;Nil"))))))))] + [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) + (&/$Cons ?method-body + (&/$Nil))))))))] (|do [=method-inputs (&/map% (fn [minput] (|case minput - ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;SymbolS" "" ?input-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?input-type)) - ("lux;Nil"))))) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) + (&/$Nil))))) (return (&/T ?input-name ?input-type)) _ @@ -334,11 +334,11 @@ (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - ("lux;Meta" _ ("lux;FormS" ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?method-name)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?inputs)) - ("lux;Cons" ("lux;Meta" _ ("lux;TextS" ?output)) - ("lux;Cons" ("lux;Meta" _ ("lux;TupleS" ?modifiers)) - ("lux;Nil"))))))) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) + (&/$Nil))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -362,9 +362,9 @@ (return (&/T ?ex-class idx =catch-body)))) ?catches) =finally (|case [?finally] - ("lux;None") (return (&/V "lux;None" nil)) - ("lux;Some" ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V "lux;Some" =finally))))] + (&/$None) (return (&/V &/$None nil)) + (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index cd89764c3..ac7e56ef4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -30,8 +30,8 @@ (defn ^:private with-cursor [cursor form] (|case form - ("lux;Meta" _ syntax) - (&/V "lux;Meta" (&/T cursor syntax)))) + (&/$Meta _ syntax) + (&/V &/$Meta (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] @@ -55,17 +55,17 @@ (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values - ("lux;Nil") + (&/$Nil) (analyse-tuple analyse exo-type (&/|list)) - ("lux;Cons" ?value ("lux;Nil")) + (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) _ (analyse-tuple analyse exo-type ?values) )] (|case output - ("lux;Cons" x ("lux;Nil")) + (&/$Cons x (&/$Nil)) (return x) _ @@ -128,7 +128,7 @@ (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) =slots (&/map% (fn [kv] (|case kv - [("lux;Meta" _ ["lux;TagS" ?ident]) ?value] + [(&/$Meta _ (&/$TagS ?ident)) ?value] (|do [?tag (&&/resolved-ident ?ident) slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) @@ -167,12 +167,12 @@ (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer - ("lux;Nil") + (&/$Nil) (&/run-state (|do [module-name &/get-module-name] (analyse-global analyse exo-type module-name name)) state) - ("lux;Cons" ?genv ("lux;Nil")) + (&/$Cons ?genv (&/$Nil)) (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) @@ -202,7 +202,7 @@ (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) - ("lux;Cons" top-outer _) + (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) (&/|map #(&/get$ &/$NAME %) outer) @@ -231,11 +231,11 @@ (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] ;; (prn 'analyse-apply* (aget fun-type 0)) (|case ?args - ("lux;Nil") + (&/$Nil) (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type (&/|list)))) - ("lux;Cons" ?arg ?args*) + (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* ("lux;AllT" _aenv _aname _aarg _abody) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index c92b7b976..78f5c675d 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -45,7 +45,7 @@ (defn define [module name def-data type] (fn [state] (|case (&/get$ &/$ENVS state) - ("lux;Cons" ?env ("lux;Nil")) + (&/$Cons ?env (&/$Nil)) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -85,7 +85,7 @@ ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] (|case (&/get$ &/$ENVS state) - ("lux;Cons" ?env ("lux;Nil")) + (&/$Cons ?env (&/$Nil)) (return* (->> state (&/update$ &/$MODULES (fn [ms] @@ -188,7 +188,7 @@ (defn export [module name] (fn [state] (|case (&/get$ &/$ENVS state) - ("lux;Cons" ?env ("lux;Nil")) + (&/$Cons ?env (&/$Nil)) (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] (|case $def [true _] diff --git a/src/lux/base.clj b/src/lux/base.clj index bcd113daa..7ec9e3029 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -15,6 +15,25 @@ (def $Nil "lux;Nil") (def $Cons "lux;Cons") +(def $None "lux;None") +(def $Some "lux;Some") + +(def $Meta "lux;Meta") + +(def $Left "lux;Left") +(def $Right "lux;Right") + +(def $BoolS "lux;BoolS") +(def $IntS "lux;IntS") +(def $RealS "lux;RealS") +(def $CharS "lux;CharS") +(def $TextS "lux;TextS") +(def $SymbolS "lux;SymbolS") +(def $TagS "lux;TagS") +(def $FormS "lux;FormS") +(def $TupleS "lux;TupleS") +(def $RecordS "lux;RecordS") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -69,10 +88,10 @@ record#))) (defn fail* [message] - (V "lux;Left" message)) + (V $Left message)) (defn return* [state value] - (V "lux;Right" (T state value))) + (V $Right (T state value))) (defn transform-pattern [pattern] (cond (vector? pattern) (mapv transform-pattern pattern) @@ -107,8 +126,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(V "lux;Cons" (T ~head ~tail))) - `(V "lux;Nil" nil) + `(V $Cons (T ~head ~tail))) + `(V $Nil nil) (reverse elems))) (defmacro |table [& elems] @@ -130,12 +149,12 @@ (defn |put [slot value table] (|case table ($Nil) - (V "lux;Cons" (T (T slot value) (V "lux;Nil" nil))) + (V $Cons (T (T slot value) (V $Nil nil))) ($Cons [k v] table*) (if (.equals ^Object k slot) - (V "lux;Cons" (T (T slot value) table*)) - (V "lux;Cons" (T (T k v) (|put slot value table*)))) + (V $Cons (T (T slot value) table*)) + (V $Cons (T (T k v) (|put slot value table*)))) _ (assert false (prn-str '|put (aget table 0))))) @@ -148,7 +167,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V "lux;Cons" (T (T k v) (|remove slot table*)))))) + (V $Cons (T (T k v) (|remove slot table*)))))) (defn |update [k f table] (|case table @@ -157,8 +176,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V "lux;Cons" (T (T k* (f v)) table*)) - (V "lux;Cons" (T (T k* v) (|update k f table*)))))) + (V $Cons (T (T k* (f v)) table*)) + (V $Cons (T (T k* v) (|update k f table*)))))) (defn |head [xs] (|case xs @@ -179,20 +198,20 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (V "lux;Left" message))) + (V $Left message))) (defn return [value] (fn [state] - (V "lux;Right" (T state value)))) + (V $Right (T state value)))) (defn bind [m-value step] (fn [state] (let [inputs (m-value state)] (|case inputs - ("lux;Right" ?state ?datum) + ($Right ?state ?datum) ((step ?datum) ?state) - ("lux;Left" _) + ($Left _) inputs )))) @@ -212,7 +231,7 @@ ;; [Resources/Combinators] (defn |cons [head tail] - (V "lux;Cons" (T head tail))) + (V $Cons (T head tail))) (defn |++ [xs ys] (|case xs @@ -220,7 +239,7 @@ ys ($Cons x xs*) - (V "lux;Cons" (T x (|++ xs* ys))))) + (V $Cons (T x (|++ xs* ys))))) (defn |map [f xs] (|case xs @@ -228,7 +247,7 @@ xs ($Cons x xs*) - (V "lux;Cons" (T (f x) (|map f xs*))))) + (V $Cons (T (f x) (|map f xs*))))) (defn |empty? [xs] (|case xs @@ -245,7 +264,7 @@ ($Cons x xs*) (if (p x) - (V "lux;Cons" (T x (|filter p xs*))) + (V $Cons (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] @@ -265,7 +284,7 @@ (if (p x) (|let [[pre post] (|split-with p xs*)] (T (|cons x pre) post)) - (T (V "lux;Nil" nil) xs)))) + (T (V $Nil nil) xs)))) (defn |contains? [k table] (|case table @@ -306,8 +325,8 @@ (let [|range* (fn |range* [from to] (if (< from to) - (V "lux;Cons" (T from (|range* (inc from) to))) - (V "lux;Nil" nil)))] + (V $Cons (T from (|range* (inc from) to))) + (V $Nil nil)))] (defn |range [n] (|range* 0 n))) @@ -322,10 +341,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (V "lux;Cons" (T (T x y) (zip2 xs* ys*))) + (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - (V "lux;Nil" nil))) + (V $Nil nil))) (defn |keys [plist] (|case plist @@ -352,7 +371,7 @@ xs ($Cons x xs*) - (V "lux;Cons" (T x (V "lux;Cons" (T sep (|interpose sep xs*))))))) + (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] @@ -369,15 +388,15 @@ flat-map% |++) (defn list-join [xss] - (fold |++ (V "lux;Nil" nil) xss)) + (fold |++ (V $Nil nil) xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (V "lux;Cons" (T (T x y) (|as-pairs xs*))) + (V $Cons (T (T x y) (|as-pairs xs*))) _ - (V "lux;Nil" nil))) + (V $Nil nil))) (defn |reverse [xs] (fold (fn [tail head] @@ -403,7 +422,7 @@ (fn [state] (let [output (m state)] (|case [output monads*] - [("lux;Right" _) _] + [($Right _) _] output [_ ($Nil)] @@ -423,10 +442,10 @@ (defn exhaust% [step] (fn [state] (|case (step state) - ("lux;Right" state* _) + ($Right state* _) ((exhaust% step) state*) - ("lux;Left" msg) + ($Left msg) (if (.equals "[Reader Error] EOF" msg) (return* state nil) (fail* msg))))) @@ -512,7 +531,7 @@ ;; "lux;loader" (memory-class-loader store) ;; "lux;writer" - (V "lux;None" nil)))) + (V $None nil)))) (defn init-state [_] (R ;; "lux;cursor" @@ -530,7 +549,7 @@ ;; "lux;seed" 0 ;; "lux;source" - (V "lux;None" nil) + (V $None nil) ;; "lux;types" +init-bindings+ )) @@ -538,22 +557,22 @@ (defn save-module [body] (fn [state] (|case (body state) - ("lux;Right" state* output) + ($Right state* output) (return* (->> state* (set$ $ENVS (get$ $ENVS state)) (set$ $SOURCE (get$ $SOURCE state))) output) - ("lux;Left" msg) + ($Left msg) (fail* msg)))) (defn with-eval [body] (fn [state] (|case (body (set$ $EVAL? true state)) - ("lux;Right" state* output) + ($Right state* output) (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) - ("lux;Left" msg) + ($Left msg) (fail* msg)))) (def get-eval @@ -564,7 +583,7 @@ (fn [state] (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] (|case writer* - ("lux;Some" datum) + ($Some datum) (return* state datum) _ @@ -613,7 +632,7 @@ (fn [state] (let [output (body (update$ $ENVS #(|cons (env name) %) state))] (|case output - ("lux;Right" state* datum) + ($Right state* datum) (return* (update$ $ENVS |tail state*) datum) _ @@ -637,9 +656,9 @@ (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $HOST #(set$ $WRITER (V "lux;Some" writer) %) state))] + (let [output (body (update$ $HOST #(set$ $WRITER (V $Some writer) %) state))] (|case output - ("lux;Right" ?state ?value) + ($Right ?state ?value) (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) ?value) @@ -651,7 +670,7 @@ (fn [state] (let [output (body (set$ $EXPECTED type state))] (|case output - ("lux;Right" ?state ?value) + ($Right ?state ?value) (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) ?value) @@ -665,7 +684,7 @@ (fn [state] (let [output (body (set$ $cursor cursor state))] (|case output - ("lux;Right" ?state ?value) + ($Right ?state ?value) (return* (set$ $cursor (get$ $cursor state) ?state) ?value) @@ -674,40 +693,40 @@ (defn show-ast [ast] (|case ast - ("lux;Meta" _ ["lux;BoolS" ?value]) + ($Meta _ ($BoolS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;IntS" ?value]) + ($Meta _ ($IntS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;RealS" ?value]) + ($Meta _ ($RealS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;CharS" ?value]) + ($Meta _ ($CharS ?value)) (pr-str ?value) - ("lux;Meta" _ ["lux;TextS" ?value]) + ($Meta _ ($TextS ?value)) (str "\"" ?value "\"") - ("lux;Meta" _ ["lux;TagS" ?module ?tag]) + ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - ("lux;Meta" _ ["lux;SymbolS" ?module ?ident]) + ($Meta _ ($SymbolS ?module ?ident)) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - ("lux;Meta" _ ["lux;TupleS" ?elems]) + ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ("lux;Meta" _ ["lux;RecordS" ?elems]) + ($Meta _ ($RecordS ?elems)) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ("lux;Meta" _ ["lux;FormS" ?elems]) + ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") )) @@ -735,7 +754,7 @@ (return (|cons z zs))) [($Nil) ($Nil)] - (return (V "lux;Nil" nil)) + (return (V $Nil nil)) [_ _] (fail "Lists don't match in size."))) @@ -746,7 +765,7 @@ (|cons (f x y) (map2 f xs* ys*)) [_ _] - (V "lux;Nil" nil))) + (V $Nil nil))) (defn fold2 [f init xs ys] (|case [xs ys] @@ -763,8 +782,8 @@ (defn ^:private enumerate* [idx xs] (|case xs ($Cons x xs*) - (V "lux;Cons" (T (T idx x) - (enumerate* (inc idx) xs*))) + (V $Cons (T (T idx x) + (enumerate* (inc idx) xs*))) ($Nil) xs diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 7463bdce7..86359d26e 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -427,7 +427,7 @@ (|case ((&/with-writer =class (&/exhaust% compiler-step)) (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) - ("lux;Right" ?state _) + (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports :let [_ (doto =class @@ -448,7 +448,7 @@ (&&/save-class! "_" (.toByteArray =class))) ?state) - ("lux;Left" ?message) + (&/$Left ?message) (fail* ?message))))))) )) )) @@ -460,10 +460,10 @@ (defn compile-program [program-module] (init!) (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) - ("lux;Right" ?state _) + (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) (&&package/package program-module)) - ("lux;Left" ?message) + (&/$Left ?message) (assert false ?message))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 8a9c8dfcc..02e9e1430 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - ("lux;TupleT" ("lux;Nil")) + ("lux;TupleT" (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) ("lux;DataT" "boolean") @@ -414,13 +414,13 @@ $end (new Label) $catch-finally (new Label) compile-finally (|case ?finally - ("lux;Some" ?finally*) (|do [_ (return nil) + (&/$Some ?finally*) (|do [_ (return nil) _ (compile ?finally*) :let [_ (doto *writer* (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $end))]] (return nil)) - ("lux;None") (|do [_ (return nil) + (&/$None) (|do [_ (return nil) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) @@ -448,11 +448,11 @@ ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally - ("lux;Some" ?finally*) (|do [_ (compile ?finally*) + (&/$Some ?finally*) (|do [_ (compile ?finally*) :let [_ (.visitInsn *writer* Opcodes/POP)] :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil)) - ("lux;None") (|do [_ (return nil) + (&/$None) (|do [_ (return nil) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] @@ -564,7 +564,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;Nil") ;; VVIT + (.visitLdcInsn &/$Nil) ;; VVIT (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -609,7 +609,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; I2V (.visitInsn Opcodes/DUP) ;; I2VV (.visitLdcInsn (int 0)) ;; I2VVI - (.visitLdcInsn "lux;Cons") ;; I2VVIT + (.visitLdcInsn &/$Cons) ;; I2VVIT (.visitInsn Opcodes/AASTORE) ;; I2V (.visitInsn Opcodes/DUP_X1) ;; IV2V (.visitInsn Opcodes/SWAP) ;; IVV2 diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index bfa322206..6f785905a 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -30,11 +30,11 @@ (def ^:private $Nil "Analysis" - (variant$ "lux;Nil" (tuple$ (&/|list)))) + (variant$ &/$Nil (tuple$ (&/|list)))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ "lux;Cons" (tuple$ (&/|list head tail)))) + (variant$ &/$Cons (tuple$ (&/|list head tail)))) ;; [Exports] (defn ->analysis [type] @@ -74,11 +74,11 @@ ("lux;AllT" ?env ?name ?arg ?body) (variant$ "lux;AllT" (tuple$ (&/|list (|case ?env - ("lux;None") - (variant$ "lux;None" (tuple$ (&/|list))) + (&/$None) + (variant$ &/$None (tuple$ (&/|list))) - ("lux;Some" ??env) - (variant$ "lux;Some" + (&/$Some ??env) + (variant$ &/$Some (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 2414d97b6..3f1ffb25a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -75,7 +75,7 @@ ("lux;LambdaT" _ _) (->type-signature function-class) - ("lux;TupleT" ("lux;Nil")) + ("lux;TupleT" (&/$Nil)) "V" )) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index bb6e54cb4..22e1b3de1 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -39,12 +39,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V "lux;Meta" (&/T meta (&/V "White_Space" white-space)))))) + (return (&/V &/$Meta (&/T meta (&/V "White_Space" white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -63,7 +63,7 @@ (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V "lux;Meta" (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -72,7 +72,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/V "lux;Meta" (&/T meta (&/V token)))))) + (return (&/V &/$Meta (&/T meta (&/V token)))))) ^:private lex-bool "Bool" #"^(true|false)" ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" @@ -86,13 +86,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V "lux;Meta" (&/T meta (&/V "Char" token)))))) + (return (&/V &/$Meta (&/T meta (&/V "Char" token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V "lux;Meta" (&/T meta (&/V "Text" token)))))) + (return (&/V &/$Meta (&/T meta (&/V "Text" token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -118,17 +118,17 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V "lux;Meta" (&/T meta (&/V "Symbol" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V "Symbol" ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V "lux;Meta" (&/T meta (&/V "Tag" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V "Tag" ident)))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/V "lux;Meta" (&/T meta (&/V nil)))))) + (return (&/V &/$Meta (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" "Open_Paren" ^:private lex-close-paren ")" "Close_Paren" diff --git a/src/lux/parser.clj b/src/lux/parser.clj index aa05b48af..762e2582f 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -19,14 +19,14 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - ("lux;Meta" meta [ _]) + (&/$Meta meta [ _]) (return (&/V (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form "Close_Paren" "parantheses" "lux;FormS" - ^:private parse-tuple "Close_Bracket" "brackets" "lux;TupleS" + ^:private parse-form "Close_Paren" "parantheses" &/$FormS + ^:private parse-tuple "Close_Bracket" "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -34,9 +34,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - ("lux;Meta" meta ("Close_Brace" _)) + (&/$Meta meta ("Close_Brace" _)) (if (even? (&/|length elems)) - (return (&/V "lux;RecordS" (&/|as-pairs elems))) + (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -45,7 +45,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [("lux;Meta" meta token*) token]] + :let [(&/$Meta meta token*) token]] (|case token* ("White_Space" _) (return (&/|list)) @@ -54,37 +54,37 @@ (return (&/|list)) ("Bool" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;BoolS" (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ("Int" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;IntS" (Integer/parseInt ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) ("Real" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;RealS" (Float/parseFloat ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) ("Char" ^String ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;CharS" (.charAt ?value 0)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) ("Text" ?value) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TextS" ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) ("Symbol" ?ident) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;SymbolS" ?ident))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) ("Tag" ?ident) - (return (&/|list (&/V "lux;Meta" (&/T meta (&/V "lux;TagS" ?ident))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) ("Open_Paren" _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ("Open_Bracket" _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ("Open_Brace" _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V "lux;Meta" (&/T meta syntax))))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 6bda8f166..7cdf9efdf 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -16,10 +16,10 @@ (defn ^:private with-line [body] (fn [state] (|case (&/get$ &/$SOURCE state) - ("lux;Nil") + (&/$Nil) (fail* "[Reader Error] EOF") - ("lux;Cons" [[file-name line-num column-num] line] + (&/$Cons [[file-name line-num column-num] line] more) (|case (body file-name line-num column-num line) ("No" msg) @@ -37,11 +37,11 @@ (defn ^:private with-lines [body] (fn [state] (|case (body (&/get$ &/$SOURCE state)) - ("lux;Right" reader* match) + (&/$Right reader* match) (return* (&/set$ &/$SOURCE reader* state) match) - ("lux;Left" msg) + (&/$Left msg) (fail* msg) ))) @@ -103,10 +103,10 @@ (loop [prefix "" reader* reader] (|case reader* - ("lux;Nil") - (&/V "lux;Left" "[Reader Error] EOF") + (&/$Nil) + (&/V &/$Left "[Reader Error] EOF") - ("lux;Cons" [[file-name line-num column-num] ^String line] + (&/$Cons [[file-name line-num column-num] ^String line] reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] @@ -114,10 +114,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V "lux;Right" (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) (&/T (&/T file-name line-num column-num) (str prefix match)))))) - (&/V "lux;Left" (str "[Reader Error] Pattern failed: " regex)))))))) + (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line diff --git a/src/lux/type.clj b/src/lux/type.clj index ab8ea4e61..45c1f2247 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -24,26 +24,26 @@ (def $Void (&/V "lux;VariantT" (&/|list))) (def IO - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "IO" "a" + (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) (def List - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;List" "a" - (&/V "lux;VariantT" (&/|list (&/T "lux;Nil" Unit) - (&/T "lux;Cons" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") + (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" + (&/V "lux;VariantT" (&/|list (&/T &/$Nil Unit) + (&/T &/$Cons (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") (&/V "lux;BoundT" "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "lux;Maybe" "a" - (&/V "lux;VariantT" (&/|list (&/T "lux;None" Unit) - (&/T "lux;Some" (&/V "lux;BoundT" "a"))))))) + (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" + (&/V "lux;VariantT" (&/|list (&/T &/$None Unit) + (&/T &/$Some (&/V "lux;BoundT" "a"))))))) (def Type (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V "lux;Some" (&/V "lux;Nil" nil)) "Type" "_" + (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) (&/T "lux;VariantT" TypeEnv) @@ -58,7 +58,7 @@ $Void)))) (defn fAll [name arg body] - (&/V "lux;AllT" (&/T (&/V "lux;None" nil) name arg body))) + (&/V "lux;AllT" (&/T (&/V &/$None nil) name arg body))) (def Bindings (fAll "lux;Bindings" "k" @@ -84,9 +84,9 @@ (&/V "lux;TupleT" (&/|list Text Int Int))) (def Meta - (fAll "lux;Meta" "m" + (fAll &/$Meta "m" (fAll "" "v" - (&/V "lux;VariantT" (&/|list (&/T "lux;Meta" (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") + (&/V "lux;VariantT" (&/|list (&/T &/$Meta (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") (&/V "lux;BoundT" "v"))))))))) (def Ident (&/V "lux;TupleT" (&/|list Text Text))) @@ -97,16 +97,16 @@ (&/V "lux;BoundT" "w"))))) AST*List (&/V "lux;AppT" (&/T List AST*))] (fAll "lux;AST'" "w" - (&/V "lux;VariantT" (&/|list (&/T "lux;BoolS" Bool) - (&/T "lux;IntS" Int) - (&/T "lux;RealS" Real) - (&/T "lux;CharS" Char) - (&/T "lux;TextS" Text) - (&/T "lux;SymbolS" Ident) - (&/T "lux;TagS" Ident) - (&/T "lux;FormS" AST*List) - (&/T "lux;TupleS" AST*List) - (&/T "lux;RecordS" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) + (&/V "lux;VariantT" (&/|list (&/T &/$BoolS Bool) + (&/T &/$IntS Int) + (&/T &/$RealS Real) + (&/T &/$CharS Char) + (&/T &/$TextS Text) + (&/T &/$SymbolS Ident) + (&/T &/$TagS Ident) + (&/T &/$FormS AST*List) + (&/T &/$TupleS AST*List) + (&/T &/$RecordS (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) )))) (def AST @@ -118,8 +118,8 @@ (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V "lux;VariantT" (&/|list (&/T "lux;Left" (&/V "lux;BoundT" "l")) - (&/T "lux;Right" (&/V "lux;BoundT" "r"))))))) + (&/V "lux;VariantT" (&/|list (&/T &/$Left (&/V "lux;BoundT" "l")) + (&/T &/$Right (&/V "lux;BoundT" "r"))))))) (def StateE (fAll "lux;StateE" "s" @@ -192,10 +192,10 @@ (fn [state] (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] (|case type - ("lux;Some" type*) + (&/$Some type*) (return* state true) - ("lux;None") + (&/$None) (return* state false)) (fail* (str "[Type Error] Unknown type-var: " id))))) @@ -203,10 +203,10 @@ (fn [state] (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] (|case type* - ("lux;Some" type) + (&/$Some type) (return* state type) - ("lux;None") + (&/$None) (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) @@ -214,11 +214,11 @@ (fn [state] (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] (|case tvar - ("lux;Some" bound) + (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) - ("lux;None") - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V "lux;Some" type) %) + (&/$None) + (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V &/$Some type) %) ts)) state) nil)) @@ -231,7 +231,7 @@ (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] (return* (&/update$ &/$TYPES #(->> % (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V "lux;None" nil) ms)))) + (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -252,19 +252,19 @@ (if (.equals ^Object id ?id) (return binding) (|case ?type - ("lux;None") + (&/$None) (return binding) - ("lux;Some" ?type*) + (&/$Some ?type*) (|case ?type* ("lux;VarT" ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V "lux;None" nil))) + (return (&/T ?id (&/V &/$None nil))) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V "lux;Some" ?type**))))) + (return (&/T ?id (&/V &/$Some ?type**))))) )))) (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] (fn [state] @@ -324,15 +324,15 @@ ("lux;AllT" ?env ?name ?arg ?body) (|do [=env (|case ?env - ("lux;None") + (&/$None) (return ?env) - ("lux;Some" ?env*) + (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?env*)] - (return (&/V "lux;Some" clean-env)))) + (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) @@ -382,7 +382,7 @@ (str "(| " (->> cases (&/|map (fn [kv] (|case kv - [k ("lux;TupleT" ("lux;Nil"))] + [k ("lux;TupleT" (&/$Nil))] (str "#" k) [k v] @@ -479,10 +479,10 @@ (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] - ;; [["lux;None" _] ["lux;None" _]] + ;; [[&/$None _] [&/$None _]] ;; true - ;; [["lux;Some" xenv*] ["lux;Some" yenv*]] + ;; [[&/$Some xenv*] [&/$Some yenv*]] ;; (&/fold (fn [old bname] ;; (and old ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) @@ -502,13 +502,13 @@ (defn ^:private fp-get [k fixpoints] (|let [[e a] k] (|case fixpoints - ("lux;Nil") - (&/V "lux;None" nil) + (&/$Nil) + (&/V &/$None nil) - ("lux;Cons" [[e* a*] v*] fixpoints*) + (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V "lux;Some" v*) + (&/V &/$Some v*) (fp-get k fixpoints*)) ))) @@ -542,10 +542,10 @@ ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env - ("lux;None") - (&/V "lux;AllT" (&/T (&/V "lux;Some" env) ?local-name ?local-arg ?local-def)) + (&/$None) + (&/V "lux;AllT" (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) - ("lux;Some" _) + (&/$Some _) type) ("lux;LambdaT" ?input ?output) @@ -564,10 +564,10 @@ (|case type-fn ("lux;AllT" local-env local-name local-arg local-def) (let [local-env* (|case local-env - ("lux;None") + (&/$None) (&/|table) - ("lux;Some" local-env*) + (&/$Some local-env*) local-env*)] (return (beta-reduce (->> local-env* (&/|put local-name type-fn) @@ -607,39 +607,39 @@ (return (&/T fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) - ("lux;Right" state* ebound) - (return* state* (&/V "lux;Some" ebound)) + (&/$Right state* ebound) + (return* state* (&/V &/$Some ebound)) - ("lux;Left" _) - (return* state (&/V "lux;None" nil)))) + (&/$Left _) + (return* state (&/V &/$None nil)))) abound (fn [state] (|case ((deref ?aid) state) - ("lux;Right" state* abound) - (return* state* (&/V "lux;Some" abound)) + (&/$Right state* abound) + (return* state* (&/V &/$Some abound)) - ("lux;Left" _) - (return* state (&/V "lux;None" nil))))] + (&/$Left _) + (return* state (&/V &/$None nil))))] (|case [ebound abound] - [("lux;None" _) ("lux;None" _)] + [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] (return (&/T fixpoints nil))) - [("lux;Some" etype) ("lux;None" _)] + [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) - [("lux;None" _) ("lux;Some" atype)] + [(&/$None _) (&/$Some atype)] (check* class-loader fixpoints expected atype) - [("lux;Some" etype) ("lux;Some" atype)] + [(&/$Some etype) (&/$Some atype)] (check* class-loader fixpoints etype atype)))) [("lux;VarT" ?id) _] (fn [state] (|case ((set-var ?id actual) state) - ("lux;Right" state* _) + (&/$Right state* _) (return* state* (&/T fixpoints nil)) - ("lux;Left" _) + (&/$Left _) ((|do [bound (deref ?id)] (check* class-loader fixpoints bound actual)) state))) @@ -647,10 +647,10 @@ [_ ("lux;VarT" ?id)] (fn [state] (|case ((set-var ?id expected) state) - ("lux;Right" state* _) + (&/$Right state* _) (return* state* (&/T fixpoints nil)) - ("lux;Left" _) + (&/$Left _) ((|do [bound (deref ?id)] (check* class-loader fixpoints expected bound)) state))) @@ -662,24 +662,24 @@ (|case [((|do [F2 (deref ?aid)] (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) state)] - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) state)))) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) (|case ((|do [F2 (deref ?aid)] (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) @@ -693,10 +693,10 @@ (|case ((|do [F1 (deref ?id)] (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) @@ -715,10 +715,10 @@ (|case ((|do [F2 (deref ?id)] (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) state) - ("lux;Right" state* output) + (&/$Right state* output) (return* state* output) - ("lux;Left" _) + (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) @@ -744,12 +744,12 @@ (&/fold str ""))) (assert false))] (|case (fp-get fp-pair fixpoints) - ("lux;Some" ?) + (&/$Some ?) (if ? (return (&/T fixpoints nil)) (fail (check-error expected actual))) - ("lux;None") + (&/$None) (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) -- cgit v1.2.3 From e6237709ed8954228e639a098d81fac2bcd81cab Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 6 Aug 2015 20:29:17 -0400 Subject: More factoring of tags. --- src/lux/analyser.clj | 2 +- src/lux/analyser/case.clj | 116 +++++++-------- src/lux/analyser/host.clj | 48 +++---- src/lux/analyser/lux.clj | 42 +++--- src/lux/base.clj | 26 +++- src/lux/compiler/base.clj | 2 +- src/lux/compiler/host.clj | 20 +-- src/lux/compiler/type.clj | 32 ++--- src/lux/host.clj | 8 +- src/lux/type.clj | 356 +++++++++++++++++++++++----------------------- 10 files changed, 335 insertions(+), 317 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0ad6553bf..f8dd13bd6 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -529,7 +529,7 @@ (fn [?var] (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] (|case [?var ?output-type] - [("lux;VarT" ?e-id) ("lux;VarT" ?a-id)] + [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] (return (&/T ?output-term ?output-type*))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 0bbbde2d7..aaf11ff15 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -21,12 +21,12 @@ (defn ^:private resolve-type [type] (|case type - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (resolve-type type*)) - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -42,64 +42,64 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" (|case type - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - ("lux;TupleT" ?members) - (|do [("lux;TupleT" ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;TupleT" (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - ("lux;RecordT" ?fields) - (|do [("lux;RecordT" ?fields*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;RecordT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?fields*)))) - - ("lux;VariantT" ?cases) - (|do [("lux;VariantT" ?cases*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg ["lux;VarT" _avar]] ena] - (|do [_ (&type/set-var _avar (&/V "lux;BoundT" _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V "lux;VariantT" (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V "lux;AllT" (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?cases*)))) - - ("lux;AppT" ?tfun ?targ) + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$TupleT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$RecordT ?fields) + (|do [(&/$RecordT ?fields*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$RecordT (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?fields*)))) + + (&/$VariantT ?cases) + (|do [(&/$VariantT ?cases*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [kv] + (|let [[k v] kv] + (&/T k (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)))) + ?cases*)))) + + (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] (adjust-type* up =type)) - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [type* (&/try-all% (&/|list (&type/deref ?id) (fail "##9##")))] (adjust-type* up type*)) @@ -153,7 +153,7 @@ (|do [value-type* (adjust-type value-type)] (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) (|case value-type* - ("lux;TupleT" ?member-types) + (&/$TupleT ?member-types) (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) @@ -176,7 +176,7 @@ ;; value-type* (resolve-type value-type) ] (|case value-type* - ("lux;RecordT" ?slot-types) + (&/$RecordT ?slot-types) (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) (|do [[=tests =kont] (&/fold (fn [kont* slot] @@ -207,7 +207,7 @@ (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) - ?values)) + ?values)) (|do [=tag (&&/resolved-ident ?ident) value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) @@ -341,7 +341,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) ?structs ?members)] @@ -355,7 +355,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;RecordT" ?fields) + (&/$RecordT ?fields) (|do [totals (&/map% (fn [field] (|let [[?tk ?tv] field] (if-let [sub-struct (&/|get ?tk ?structs)] @@ -372,7 +372,7 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (|do [totals (&/map% (fn [case] (|let [[?tk ?tv] case] (if-let [sub-struct (&/|get ?tk ?structs)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 06cb5ebfc..ec8b8b5db 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -37,7 +37,7 @@ (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token - [_ ("lux;DataT" _)] + [_ (&/$DataT _)] (return nil) _ @@ -46,16 +46,16 @@ (defn ^:private as-object [type] "(-> Type Type)" (|case type - ("lux;DataT" class) - (&/V "lux;DataT" (&type/as-obj class)) + (&/$DataT class) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&/V "lux;DataT" ) - output-type (&/V "lux;DataT" )] + (let [input-type (&/V &/$DataT ) + output-type (&/V &/$DataT )] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) @@ -140,10 +140,10 @@ =classes (&/map% extract-text ?classes) =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] - ;; [["lux;DataT" _return-class]] + ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V "lux;DataT" _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] @@ -162,8 +162,8 @@ (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] @@ -179,9 +179,9 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V "lux;DataT" ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V "lux;DataT" ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] @@ -195,19 +195,19 @@ (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V "lux;DataT" "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V "lux;DataT" ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V "lux;DataT" ?class) + (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] @@ -309,11 +309,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V "lux;DataT" (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V "lux;DataT" (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/|cons (&/T ";this" ?super-class) @@ -356,7 +356,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V "lux;DataT" ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -370,7 +370,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V "lux;DataT" "java.lang.Throwable") _type)] + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) (do-template [ ] @@ -386,9 +386,9 @@ ) (do-template [ ] - (let [output-type (&/V "lux;DataT" )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -413,9 +413,9 @@ ) (do-template [ ] - (let [output-type (&/V "lux;DataT" )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V "lux;DataT" ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V "lux;AppT" (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V "lux;AppT" (&/T &type/IO &type/Unit)) ?body))) + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) _ (compile-token (&/V "jvm-program" =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index ac7e56ef4..6503fe2ea 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -37,14 +37,14 @@ (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] (return (&/|list (&/T (&/V "tuple" =elems) exo-type)))) - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -73,7 +73,7 @@ (defn analyse-variant [analyse exo-type ident ?values] (|do [exo-type* (|case exo-type - ("lux;VarT" ?id) + (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) (|do [_ (&type/set-var ?id &type/Type)] @@ -82,7 +82,7 @@ _ (&type/actual-type exo-type))] (|case exo-type* - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] @@ -90,7 +90,7 @@ exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -101,11 +101,11 @@ (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (|case exo-type - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - ("lux;AllT" _) + (&/$AllT _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -117,7 +117,7 @@ _ (&type/actual-type exo-type)) types (|case exo-type* - ("lux;RecordT" ?table) + (&/$RecordT ?table) (return ?table) _ @@ -139,7 +139,7 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] - (return (&/|list (&/T (&/V "record" =slots) (&/V "lux;RecordT" exo-type)))))) + (return (&/|list (&/T (&/V "record" =slots) (&/V &/$RecordT exo-type)))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -238,7 +238,7 @@ (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* - ("lux;AllT" _aenv _aname _aarg _abody) + (&/$AllT _aenv _aname _aarg _abody) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -247,21 +247,21 @@ (|do [type* (&type/apply-type ?fun-type* $var) [=output-t =args] (analyse-apply* analyse exo-type type* ?args)] (|case $var - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V "lux;BoundT" _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) - ("lux;LambdaT" ?input-t ?output-t) + (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] (return (&/T =output-t (&/|cons =arg =args)))) - ;; [["lux;VarT" ?id-t]] + ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) _ @@ -314,7 +314,7 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type - ("lux;AllT" _) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -323,7 +323,7 @@ ;; exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - ("lux;LambdaT" ?arg-t ?return-t) + (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] @@ -335,26 +335,26 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type - ("lux;AllT" _env _self _arg _body) + (&/$AllT _env _self _arg _body) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] (|case $var - ("lux;VarT" ?id) + (&/$VarT ?id) (|do [? (&type/bound? ?id)] (if ? (|do [dtype (&type/deref ?id) ;; dtype* (&type/actual-type dtype) ] (|case dtype - ("lux;BoundT" ?vname) + (&/$BoundT ?vname) (return (&/T _expr exo-type)) - ("lux;ExT" _) + (&/$ExT _) (return (&/T _expr exo-type)) - ("lux;VarT" ?_id) + (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? diff --git a/src/lux/base.clj b/src/lux/base.clj index 7ec9e3029..532f56695 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,17 +12,22 @@ clojure.core.match.array)) ;; [Tags] +;; List (def $Nil "lux;Nil") (def $Cons "lux;Cons") +;; Maybe (def $None "lux;None") (def $Some "lux;Some") +;; Meta (def $Meta "lux;Meta") +;; Either (def $Left "lux;Left") (def $Right "lux;Right") +;; AST (def $BoolS "lux;BoolS") (def $IntS "lux;IntS") (def $RealS "lux;RealS") @@ -34,6 +39,18 @@ (def $TupleS "lux;TupleS") (def $RecordS "lux;RecordS") +;; Type +(def $DataT "lux;DataT") +(def $TupleT "lux;TupleT") +(def $VariantT "lux;VariantT") +(def $RecordT "lux;RecordT") +(def $LambdaT "lux;LambdaT") +(def $VarT "lux;VarT") +(def $ExT "lux;ExT") +(def $BoundT "lux;BoundT") +(def $AppT "lux;AppT") +(def $AllT "lux;AllT") + ;; [Fields] ;; Binding (def $COUNTER 0) @@ -156,8 +173,9 @@ (V $Cons (T (T slot value) table*)) (V $Cons (T (T k v) (|put slot value table*)))) - _ - (assert false (prn-str '|put (aget table 0))))) + ;; _ + ;; (assert false (prn-str '|put (aget table 0))) + )) (defn |remove [slot table] (|case table @@ -541,7 +559,7 @@ ;; "lux;eval?" false ;; "lux;expected" - (V "lux;VariantT" (|list)) + (V $VariantT (|list)) ;; "lux;host" (host nil) ;; "lux;modules" @@ -677,7 +695,7 @@ _ output)))) -(defn with-cursor [cursor body] +(defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" (if (= "" (aget cursor 0)) body diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 74e5625b3..03fae9fec 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -50,7 +50,7 @@ (write-file (str module-dir "/" name ".class") data))) ;; [Exports] -(defn load-class! [^ClassLoader loader name] +(defn ^Class load-class! [^ClassLoader loader name] ;; (prn 'load-class! name) (.loadClass loader name)) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 02e9e1430..78b9e72f6 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,34 +52,34 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - ("lux;TupleT" (&/$Nil)) + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) - ("lux;DataT" "boolean") + (&/$DataT "boolean") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - ("lux;DataT" "byte") + (&/$DataT "byte") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - ("lux;DataT" "short") + (&/$DataT "short") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - ("lux;DataT" "int") + (&/$DataT "int") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - ("lux;DataT" "long") + (&/$DataT "long") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - ("lux;DataT" "float") + (&/$DataT "float") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - ("lux;DataT" "double") + (&/$DataT "double") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - ("lux;DataT" "char") + (&/$DataT "char") (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - ("lux;DataT" _) + (&/$DataT _) nil) *writer*)) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 6f785905a..46e6ec2d9 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -40,18 +40,18 @@ (defn ->analysis [type] "(-> Type Analysis)" (|case type - ("lux;DataT" ?class) - (variant$ "lux;DataT" (text$ ?class)) + (&/$DataT ?class) + (variant$ &/$DataT (text$ ?class)) - ("lux;TupleT" ?members) - (variant$ "lux;TupleT" + (&/$TupleT ?members) + (variant$ &/$TupleT (&/fold (fn [tail head] (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?members))) - ("lux;VariantT" ?cases) - (variant$ "lux;VariantT" + (&/$VariantT ?cases) + (variant$ &/$VariantT (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) @@ -59,8 +59,8 @@ $Nil (&/|reverse ?cases))) - ("lux;RecordT" ?slots) - (variant$ "lux;RecordT" + (&/$RecordT ?slots) + (variant$ &/$RecordT (&/fold (fn [tail head] (|let [[hlabel htype] head] (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) @@ -68,11 +68,11 @@ $Nil (&/|reverse ?slots))) - ("lux;LambdaT" ?input ?output) - (variant$ "lux;LambdaT" (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + (&/$LambdaT ?input ?output) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - ("lux;AllT" ?env ?name ?arg ?body) - (variant$ "lux;AllT" + (&/$AllT ?env ?name ?arg ?body) + (variant$ &/$AllT (tuple$ (&/|list (|case ?env (&/$None) (variant$ &/$None (tuple$ (&/|list))) @@ -89,9 +89,9 @@ (text$ ?arg) (->analysis ?body)))) - ("lux;BoundT" ?name) - (variant$ "lux;BoundT" (text$ ?name)) + (&/$BoundT ?name) + (variant$ &/$BoundT (text$ ?name)) - ("lux;AppT" ?fun ?arg) - (variant$ "lux;AppT" (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (&/$AppT ?fun ?arg) + (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 3f1ffb25a..8ffe77b96 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,7 +29,7 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V "lux;DataT" (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base))) ))) @@ -69,13 +69,13 @@ (defn ->java-sig [^objects type] (|case type - ("lux;DataT" ?name) + (&/$DataT ?name) (->type-signature ?name) - ("lux;LambdaT" _ _) + (&/$LambdaT _ _) (->type-signature function-class) - ("lux;TupleT" (&/$Nil)) + (&/$TupleT (&/$Nil)) "V" )) diff --git a/src/lux/type.clj b/src/lux/type.clj index 45c1f2247..0a80d4fbc 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -15,65 +15,65 @@ (declare show-type) ;; [Util] -(def Bool (&/V "lux;DataT" "java.lang.Boolean")) -(def Int (&/V "lux;DataT" "java.lang.Long")) -(def Real (&/V "lux;DataT" "java.lang.Double")) -(def Char (&/V "lux;DataT" "java.lang.Character")) -(def Text (&/V "lux;DataT" "java.lang.String")) -(def Unit (&/V "lux;TupleT" (&/|list))) -(def $Void (&/V "lux;VariantT" (&/|list))) +(def Bool (&/V &/$DataT "java.lang.Boolean")) +(def Int (&/V &/$DataT "java.lang.Long")) +(def Real (&/V &/$DataT "java.lang.Double")) +(def Char (&/V &/$DataT "java.lang.Character")) +(def Text (&/V &/$DataT "java.lang.String")) +(def Unit (&/V &/$TupleT (&/|list))) +(def $Void (&/V &/$VariantT (&/|list))) (def IO - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" - (&/V "lux;LambdaT" (&/T Unit (&/V "lux;BoundT" "a")))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" + (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a")))))) (def List - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" - (&/V "lux;VariantT" (&/|list (&/T &/$Nil Unit) - (&/T &/$Cons (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "a") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;List") - (&/V "lux;BoundT" "a"))))))))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" + (&/V &/$VariantT (&/|list (&/T &/$Nil Unit) + (&/T &/$Cons (&/V &/$TupleT (&/|list (&/V &/$BoundT "a") + (&/V &/$AppT (&/T (&/V &/$BoundT "lux;List") + (&/V &/$BoundT "a"))))))))))) (def Maybe - (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" - (&/V "lux;VariantT" (&/|list (&/T &/$None Unit) - (&/T &/$Some (&/V "lux;BoundT" "a"))))))) + (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" + (&/V &/$VariantT (&/|list (&/T &/$None Unit) + (&/T &/$Some (&/V &/$BoundT "a"))))))) (def Type - (let [Type (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "Type") (&/V "lux;BoundT" "_"))) - TypeEnv (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Type)))) - TypePair (&/V "lux;TupleT" (&/|list Type Type))] - (&/V "lux;AppT" (&/T (&/V "lux;AllT" (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" - (&/V "lux;VariantT" (&/|list (&/T "lux;DataT" Text) - (&/T "lux;TupleT" (&/V "lux;AppT" (&/T List Type))) - (&/T "lux;VariantT" TypeEnv) - (&/T "lux;RecordT" TypeEnv) - (&/T "lux;LambdaT" TypePair) - (&/T "lux;BoundT" Text) - (&/T "lux;VarT" Int) - (&/T "lux;AllT" (&/V "lux;TupleT" (&/|list (&/V "lux;AppT" (&/T Maybe TypeEnv)) Text Text Type))) - (&/T "lux;AppT" TypePair) - (&/T "lux;ExT" Int) + (let [Type (&/V &/$AppT (&/T (&/V &/$BoundT "Type") (&/V &/$BoundT "_"))) + TypeEnv (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Type)))) + TypePair (&/V &/$TupleT (&/|list Type Type))] + (&/V &/$AppT (&/T (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" + (&/V &/$VariantT (&/|list (&/T &/$DataT Text) + (&/T &/$TupleT (&/V &/$AppT (&/T List Type))) + (&/T &/$VariantT TypeEnv) + (&/T &/$RecordT TypeEnv) + (&/T &/$LambdaT TypePair) + (&/T &/$BoundT Text) + (&/T &/$VarT Int) + (&/T &/$AllT (&/V &/$TupleT (&/|list (&/V &/$AppT (&/T Maybe TypeEnv)) Text Text Type))) + (&/T &/$AppT TypePair) + (&/T &/$ExT Int) )))) $Void)))) (defn fAll [name arg body] - (&/V "lux;AllT" (&/T (&/V &/$None nil) name arg body))) + (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) (def Bindings (fAll "lux;Bindings" "k" (fAll "" "v" - (&/V "lux;RecordT" (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V "lux;AppT" (&/T List - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "k") - (&/V "lux;BoundT" "v"))))))))))) + (&/V &/$RecordT (&/|list (&/T "lux;counter" Int) + (&/T "lux;mappings" (&/V &/$AppT (&/T List + (&/V &/$TupleT (&/|list (&/V &/$BoundT "k") + (&/V &/$BoundT "v"))))))))))) (def Env - (let [bindings (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings (&/V "lux;BoundT" "k"))) - (&/V "lux;BoundT" "v")))] + (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k"))) + (&/V &/$BoundT "v")))] (fAll "lux;Env" "k" (fAll "" "v" - (&/V "lux;RecordT" + (&/V &/$RecordT (&/|list (&/T "lux;name" Text) (&/T "lux;inner-closures" Int) (&/T "lux;locals" bindings) @@ -81,23 +81,23 @@ )))))) (def Cursor - (&/V "lux;TupleT" (&/|list Text Int Int))) + (&/V &/$TupleT (&/|list Text Int Int))) (def Meta (fAll &/$Meta "m" (fAll "" "v" - (&/V "lux;VariantT" (&/|list (&/T &/$Meta (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "m") - (&/V "lux;BoundT" "v"))))))))) + (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m") + (&/V &/$BoundT "v"))))))))) -(def Ident (&/V "lux;TupleT" (&/|list Text Text))) +(def Ident (&/V &/$TupleT (&/|list Text Text))) (def AST* - (let [AST* (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "w") - (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;AST'") - (&/V "lux;BoundT" "w"))))) - AST*List (&/V "lux;AppT" (&/T List AST*))] + (let [AST* (&/V &/$AppT (&/T (&/V &/$BoundT "w") + (&/V &/$AppT (&/T (&/V &/$BoundT "lux;AST'") + (&/V &/$BoundT "w"))))) + AST*List (&/V &/$AppT (&/T List AST*))] (fAll "lux;AST'" "w" - (&/V "lux;VariantT" (&/|list (&/T &/$BoolS Bool) + (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool) (&/T &/$IntS Int) (&/T &/$RealS Real) (&/T &/$CharS Char) @@ -106,75 +106,75 @@ (&/T &/$TagS Ident) (&/T &/$FormS AST*List) (&/T &/$TupleS AST*List) - (&/T &/$RecordS (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list AST* AST*)))))) + (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*)))))) )))) (def AST - (let [w (&/V "lux;AppT" (&/T Meta Cursor))] - (&/V "lux;AppT" (&/T w (&/V "lux;AppT" (&/T AST* w)))))) + (let [w (&/V &/$AppT (&/T Meta Cursor))] + (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w)))))) -(def ^:private ASTList (&/V "lux;AppT" (&/T List AST))) +(def ^:private ASTList (&/V &/$AppT (&/T List AST))) (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V "lux;VariantT" (&/|list (&/T &/$Left (&/V "lux;BoundT" "l")) - (&/T &/$Right (&/V "lux;BoundT" "r"))))))) + (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l")) + (&/T &/$Right (&/V &/$BoundT "r"))))))) (def StateE (fAll "lux;StateE" "s" (fAll "" "a" - (&/V "lux;LambdaT" (&/T (&/V "lux;BoundT" "s") - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Either Text)) - (&/V "lux;TupleT" (&/|list (&/V "lux;BoundT" "s") - (&/V "lux;BoundT" "a")))))))))) + (&/V &/$LambdaT (&/T (&/V &/$BoundT "s") + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text)) + (&/V &/$TupleT (&/|list (&/V &/$BoundT "s") + (&/V &/$BoundT "a")))))))))) (def Reader - (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Meta Cursor)) + (&/V &/$AppT (&/T List + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor)) Text))))) (def HostState - (&/V "lux;RecordT" - (&/|list (&/T "lux;writer" (&/V "lux;DataT" "org.objectweb.asm.ClassWriter")) - (&/T "lux;loader" (&/V "lux;DataT" "java.lang.ClassLoader")) - (&/T "lux;classes" (&/V "lux;DataT" "clojure.lang.Atom"))))) + (&/V &/$RecordT + (&/|list (&/T "lux;writer" (&/V &/$DataT "org.objectweb.asm.ClassWriter")) + (&/T "lux;loader" (&/V &/$DataT "java.lang.ClassLoader")) + (&/T "lux;classes" (&/V &/$DataT "clojure.lang.Atom"))))) (def DefData* (fAll "lux;DefData'" "" - (&/V "lux;VariantT" (&/|list (&/T "lux;TypeD" Type) - (&/T "lux;ValueD" (&/V "lux;TupleT" (&/|list Type Unit))) - (&/T "lux;MacroD" (&/V "lux;BoundT" "")) + (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type) + (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit))) + (&/T "lux;MacroD" (&/V &/$BoundT "")) (&/T "lux;AliasD" Ident))))) (def LuxVar - (&/V "lux;VariantT" (&/|list (&/T "lux;Local" Int) + (&/V &/$VariantT (&/|list (&/T "lux;Local" Int) (&/T "lux;Global" Ident)))) (def $Module (fAll "lux;$Module" "Compiler" - (&/V "lux;RecordT" - (&/|list (&/T "lux;module-aliases" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" (&/|list Text Text))))) - (&/T "lux;defs" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/V &/$RecordT + (&/|list (&/T "lux;module-aliases" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Text))))) + (&/T "lux;defs" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text - (&/V "lux;TupleT" (&/|list Bool - (&/V "lux;AppT" (&/T DefData* - (&/V "lux;LambdaT" (&/T ASTList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE (&/V "lux;BoundT" "Compiler"))) + (&/V &/$TupleT (&/|list Bool + (&/V &/$AppT (&/T DefData* + (&/V &/$LambdaT (&/T ASTList + (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE (&/V &/$BoundT "Compiler"))) ASTList))))))))))))) - (&/T "lux;imports" (&/V "lux;AppT" (&/T List Text))))))) + (&/T "lux;imports" (&/V &/$AppT (&/T List Text))))))) (def $Compiler - (&/V "lux;AppT" (&/T (fAll "lux;Compiler" "" - (&/V "lux;RecordT" + (&/V &/$AppT (&/T (fAll "lux;Compiler" "" + (&/V &/$RecordT (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V "lux;AppT" (&/T List (&/V "lux;TupleT" + (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text - (&/V "lux;AppT" (&/T $Module (&/V "lux;AppT" (&/T (&/V "lux;BoundT" "lux;Compiler") (&/V "lux;BoundT" "")))))))))) - (&/T "lux;envs" (&/V "lux;AppT" (&/T List - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Env Text)) - (&/V "lux;TupleT" (&/|list LuxVar Type))))))) - (&/T "lux;types" (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T Bindings Int)) Type))) + (&/V &/$AppT (&/T $Module (&/V &/$AppT (&/T (&/V &/$BoundT "lux;Compiler") (&/V &/$BoundT "")))))))))) + (&/T "lux;envs" (&/V &/$AppT (&/T List + (&/V &/$AppT (&/T (&/V &/$AppT (&/T Env Text)) + (&/V &/$TupleT (&/|list LuxVar Type))))))) + (&/T "lux;types" (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings Int)) Type))) (&/T "lux;host" HostState) (&/T "lux;seed" Int) (&/T "lux;eval?" Bool) @@ -184,8 +184,8 @@ $Void))) (def Macro - (&/V "lux;LambdaT" (&/T ASTList - (&/V "lux;AppT" (&/T (&/V "lux;AppT" (&/T StateE $Compiler)) + (&/V &/$LambdaT (&/T ASTList + (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler)) ASTList))))) (defn bound? [id] @@ -237,7 +237,7 @@ (def existential (|do [seed &/gen-id] - (return (&/V "lux;ExT" seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -257,7 +257,7 @@ (&/$Some ?type*) (|case ?type* - ("lux;VarT" ?id*) + (&/$VarT ?id*) (if (.equals ^Object id ?id*) (return (&/T ?id (&/V &/$None nil))) (return binding)) @@ -277,52 +277,52 @@ (defn with-var [k] (|do [id create-var - output (k (&/V "lux;VarT" id)) + output (k (&/V &/$VarT id)) _ (delete-var id)] (return output))) (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(&/V "lux;VarT" %) =vars)) + output (k (&/|map #(&/V &/$VarT %) =vars)) _ (&/map% delete-var (&/|reverse =vars))] (return output))) (defn clean* [?tid type] (|case type - ("lux;VarT" ?id) + (&/$VarT ?id) (if (.equals ^Object ?tid ?id) (deref ?id) (return type)) - ("lux;LambdaT" ?arg ?return) + (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V "lux;LambdaT" (&/T =arg =return)))) + (return (&/V &/$LambdaT (&/T =arg =return)))) - ("lux;AppT" ?lambda ?param) + (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V "lux;AppT" (&/T =lambda =param)))) + (return (&/V &/$AppT (&/T =lambda =param)))) - ("lux;TupleT" ?members) + (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V "lux;TupleT" =members))) + (return (&/V &/$TupleT =members))) - ("lux;VariantT" ?members) + (&/$VariantT ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] - (return (&/V "lux;VariantT" =members))) + (return (&/V &/$VariantT =members))) - ("lux;RecordT" ?members) + (&/$RecordT ?members) (|do [=members (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] (return (&/T k =v)))) ?members)] - (return (&/V "lux;RecordT" =members))) + (return (&/V &/$RecordT =members))) - ("lux;AllT" ?env ?name ?arg ?body) + (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env (&/$None) (return ?env) @@ -334,7 +334,7 @@ ?env*)] (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] - (return (&/V "lux;AllT" (&/T =env ?name ?arg body*)))) + (return (&/V &/$AllT (&/T =env ?name ?arg body*)))) _ (return type) @@ -342,7 +342,7 @@ (defn clean [tvar type] (|case tvar - ("lux;VarT" ?id) + (&/$VarT ?id) (clean* ?id type) _ @@ -350,7 +350,7 @@ (defn ^:private unravel-fun [type] (|case type - ("lux;LambdaT" ?in ?out) + (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] (&/T ??out (&/|cons ?in ?args))) @@ -359,7 +359,7 @@ (defn ^:private unravel-app [fun-type] (|case fun-type - ("lux;AppT" ?left ?right) + (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) @@ -368,21 +368,21 @@ (defn show-type [^objects type] (|case type - ("lux;DataT" name) + (&/$DataT name) (str "(^ " name ")") - ("lux;TupleT" elems) + (&/$TupleT elems) (if (&/|empty? elems) "(,)" (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - ("lux;VariantT" cases) + (&/$VariantT cases) (if (&/|empty? cases) "(|)" (str "(| " (->> cases (&/|map (fn [kv] (|case kv - [k ("lux;TupleT" (&/$Nil))] + [k (&/$TupleT (&/$Nil))] (str "#" k) [k v] @@ -391,7 +391,7 @@ (&/fold str "")) ")")) - ("lux;RecordT" fields) + (&/$RecordT fields) (str "(& " (->> fields (&/|map (fn [kv] (|case kv @@ -400,29 +400,29 @@ (&/|interpose " ") (&/fold str "")) ")") - ("lux;LambdaT" input output) + (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - ("lux;VarT" id) + (&/$VarT id) (str "⌈" id "⌋") - ("lux;ExT" ?id) + (&/$ExT ?id) (str "⟨" ?id "⟩") - ("lux;BoundT" name) + (&/$BoundT name) name - ("lux;AppT" _ _) + (&/$AppT _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - ("lux;AllT" ?env ?name ?arg ?body) + (&/$AllT ?env ?name ?arg ?body) (if (= "" ?name) (let [[args body] (loop [args (list ?arg) body* ?body] (|case body* - ("lux;AllT" ?env* ?name* ?arg* ?body*) + (&/$AllT ?env* ?name* ?arg* ?body*) (recur (cons ?arg* args) ?body*) _ @@ -434,16 +434,16 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] - [("lux;DataT" xname) ("lux;DataT" yname)] + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [("lux;TupleT" xelems) ("lux;TupleT" yelems)] + [(&/$TupleT xelems) (&/$TupleT yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) - [("lux;VariantT" xcases) ("lux;VariantT" ycases)] + [(&/$VariantT xcases) (&/$VariantT ycases)] (&/fold2 (fn [old xcase ycase] (|let [[xname xtype] xcase [yname ytype] ycase] @@ -451,7 +451,7 @@ true xcases ycases) - [("lux;RecordT" xslots) ("lux;RecordT" yslots)] + [(&/$RecordT xslots) (&/$RecordT yslots)] (&/fold2 (fn [old xslot yslot] (|let [[xname xtype] xslot [yname ytype] yslot] @@ -459,23 +459,23 @@ true xslots yslots) - [("lux;LambdaT" xinput xoutput) ("lux;LambdaT" yinput youtput)] + [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) - [("lux;VarT" xid) ("lux;VarT" yid)] + [(&/$VarT xid) (&/$VarT yid)] (.equals ^Object xid yid) - [("lux;BoundT" xname) ("lux;BoundT" yname)] + [(&/$BoundT xname) (&/$BoundT yname)] (.equals ^Object xname yname) - [("lux;ExT" xid) ("lux;ExT" yid)] + [(&/$ExT xid) (&/$ExT yid)] (.equals ^Object xid yid) - [("lux;AppT" xlambda xparam) ("lux;AppT" ylambda yparam)] + [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [("lux;AllT" xenv xname xarg xbody) ("lux;AllT" yenv yname yarg ybody)] + [(&/$AllT xenv xname xarg xbody) (&/$AllT yenv yname yarg ybody)] (and (.equals ^Object xname yname) (.equals ^Object xarg yarg) ;; (matchv ::M/objects [xenv yenv] @@ -522,36 +522,36 @@ (defn beta-reduce [env type] (|case type - ("lux;VariantT" ?cases) - (&/V "lux;VariantT" (&/|map (fn [kv] + (&/$VariantT ?cases) + (&/V &/$VariantT (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?cases)) - ("lux;RecordT" ?fields) - (&/V "lux;RecordT" (&/|map (fn [kv] + (&/$RecordT ?fields) + (&/V &/$RecordT (&/|map (fn [kv] (|let [[k v] kv] (&/T k (beta-reduce env v)))) ?fields)) - ("lux;TupleT" ?members) - (&/V "lux;TupleT" (&/|map (partial beta-reduce env) ?members)) + (&/$TupleT ?members) + (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members)) - ("lux;AppT" ?type-fn ?type-arg) - (&/V "lux;AppT" (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) + (&/$AppT ?type-fn ?type-arg) + (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) - ("lux;AllT" ?local-env ?local-name ?local-arg ?local-def) + (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (&/V "lux;AllT" (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) + (&/V &/$AllT (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) (&/$Some _) type) - ("lux;LambdaT" ?input ?output) - (&/V "lux;LambdaT" (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (&/$LambdaT ?input ?output) + (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output))) - ("lux;BoundT" ?name) + (&/$BoundT ?name) (if-let [bound (&/|get ?name env)] (beta-reduce env bound) type) @@ -562,7 +562,7 @@ (defn apply-type [type-fn param] (|case type-fn - ("lux;AllT" local-env local-name local-arg local-def) + (&/$AllT local-env local-name local-arg local-def) (let [local-env* (|case local-env (&/$None) (&/|table) @@ -574,7 +574,7 @@ (&/|put local-arg param)) local-def))) - ("lux;AppT" F A) + (&/$AppT F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) @@ -602,7 +602,7 @@ (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (|case [expected actual] - [("lux;VarT" ?eid) ("lux;VarT" ?aid)] + [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/T fixpoints nil)) (|do [ebound (fn [state] @@ -633,7 +633,7 @@ [(&/$Some etype) (&/$Some atype)] (check* class-loader fixpoints etype atype)))) - [("lux;VarT" ?id) _] + [(&/$VarT ?id) _] (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) @@ -644,7 +644,7 @@ (check* class-loader fixpoints bound actual)) state))) - [_ ("lux;VarT" ?id)] + [_ (&/$VarT ?id)] (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) @@ -655,18 +655,18 @@ (check* class-loader fixpoints expected bound)) state))) - [("lux;AppT" ("lux;VarT" ?eid) A1) ("lux;AppT" ("lux;VarT" ?aid) A2)] + [(&/$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 (&/V "lux;AppT" (&/T F1 A1)) (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2)))) state)] (&/$Right state* output) (return* state* output) (&/$Left _) - ((check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual) + ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual) state)))) state) (&/$Right state* output) @@ -674,65 +674,65 @@ (&/$Left _) (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] (return (&/T fixpoints** nil))) state)))) - ;; (|do [_ (check* class-loader fixpoints (&/V "lux;VarT" ?eid) (&/V "lux;VarT" ?aid)) + ;; (|do [_ (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) - [("lux;AppT" ("lux;VarT" ?id) A1) ("lux;AppT" F2 A2)] + [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V "lux;AppT" (&/T F1 A1)) actual)) + (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [["lux;VarT" ?id] A1]] ["lux;AppT" [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V "lux;VarT" ?id) F2) + ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [("lux;AppT" F1 A1) ("lux;AppT" ("lux;VarT" ?id) A2)] + [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V "lux;AppT" (&/T F2 A2)))) + (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] (return (&/T fixpoints** nil))) state))) - ;; [["lux;AppT" [F1 A1]] ["lux;AppT" [["lux;VarT" ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V "lux;VarT" ?id)) + ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] ;; (return (&/T fixpoints** nil))) - [("lux;AppT" F A) _] + [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) @@ -753,28 +753,28 @@ (|do [expected* (apply-type F A)] (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) - [_ ("lux;AppT" F A)] + [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [("lux;AllT" _) _] + [(&/$AllT _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ ("lux;AllT" _)] + [_ (&/$AllT _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints expected actual*)))) - [("lux;DataT" e!name) ("lux;DataT" "null")] + [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) - [["lux;DataT" e!name] ["lux;DataT" a!name]] + [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) @@ -782,11 +782,11 @@ (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) - [("lux;LambdaT" eI eO) ("lux;LambdaT" aI aO)] + [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [("lux;TupleT" e!members) ("lux;TupleT" a!members)] + [(&/$TupleT e!members) (&/$TupleT a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp e a)] (return fp*))) @@ -794,7 +794,7 @@ e!members a!members)] (return (&/T fixpoints* nil))) - [("lux;VariantT" e!cases) ("lux;VariantT" a!cases)] + [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] (|let [[e!name e!type] e!case [a!name a!type] a!case] @@ -806,7 +806,7 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [("lux;RecordT" e!slots) ("lux;RecordT" a!slots)] + [(&/$RecordT e!slots) (&/$RecordT a!slots)] (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] (|let [[e!name e!type] e!slot [a!name a!type] a!slot] @@ -818,7 +818,7 @@ e!slots a!slots)] (return (&/T fixpoints* nil))) - [("lux;ExT" e!id) ("lux;ExT" a!id)] + [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -834,11 +834,11 @@ (defn apply-lambda [func param] (|case func - ("lux;LambdaT" input output) + (&/$LambdaT input output) (|do [_ (check* init-fixpoints input param)] (return output)) - ("lux;AllT" _) + (&/$AllT _) (with-var (fn [$var] (|do [func* (apply-type func $var) @@ -851,11 +851,11 @@ (defn actual-type [type] (|case type - ("lux;AppT" ?all ?param) + (&/$AppT ?all ?param) (|do [type* (apply-type ?all ?param)] (actual-type type*)) - ("lux;VarT" ?id) + (&/$VarT ?id) (deref ?id) _ @@ -864,7 +864,7 @@ (defn variant-case [case type] (|case type - ("lux;VariantT" ?cases) + (&/$VariantT ?cases) (if-let [case-type (&/|get case ?cases)] (return case-type) (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) -- cgit v1.2.3 From ede9a0500ed00b5636d5eaf9a5b470f159c97edb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 17:57:07 -0400 Subject: More refactoring of tags, this time for reader, lexer & parser. --- src/lux/base.clj | 4 ++++ src/lux/lexer.clj | 53 ++++++++++++++++++++++++++++++++++++----------------- src/lux/parser.clj | 51 +++++++++++++++++++++++++++++++++++---------------- src/lux/reader.clj | 32 +++++++++++++++++++------------- 4 files changed, 94 insertions(+), 46 deletions(-) (limited to 'src') diff --git a/src/lux/base.clj b/src/lux/base.clj index 532f56695..66b972f94 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -12,6 +12,10 @@ clojure.core.match.array)) ;; [Tags] +(defmacro deftags [prefix & names] + `(do ~@(for [name names] + `(def ~(symbol (str "$" name)) ~name)))) + ;; List (def $Nil "lux;Nil") (def $Cons "lux;Cons") diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 22e1b3de1..e848cc3fd 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -8,10 +8,29 @@ (ns lux.lexer (:require [clojure.template :refer [do-template]] - (lux [base :as & :refer [|do return* return fail fail*]] + (lux [base :as & :refer [deftags |do return* return fail fail*]] [reader :as &reader]) [lux.analyser.module :as &module])) +;; [Tags] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" + ) + ;; [Utils] (defn ^:private escape-char [escaped] (cond (.equals ^Object escaped "\\t") (return "\t") @@ -39,12 +58,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V "White_Space" white-space)))))) + (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -63,7 +82,7 @@ (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V "Comment" comment)))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -74,9 +93,9 @@ (|do [[meta token] (&reader/read-regex )] (return (&/V &/$Meta (&/T meta (&/V token)))))) - ^:private lex-bool "Bool" #"^(true|false)" - ^:private lex-int "Int" #"^(-?0|-?[1-9][0-9]*)" - ^:private lex-real "Real" #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" + ^:private lex-bool $Bool #"^(true|false)" + ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" + ^:private lex-real $Real #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char @@ -86,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V "Char" token)))))) + (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V "Text" token)))))) + (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -118,24 +137,24 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V "Symbol" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V "Tag" ident)))))) + (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] (return (&/V &/$Meta (&/T meta (&/V nil)))))) - ^:private lex-open-paren "(" "Open_Paren" - ^:private lex-close-paren ")" "Close_Paren" - ^:private lex-open-bracket "[" "Open_Bracket" - ^:private lex-close-bracket "]" "Close_Bracket" - ^:private lex-open-brace "{" "Open_Brace" - ^:private lex-close-brace "}" "Close_Brace" + ^:private lex-open-paren "(" $Open_Paren + ^:private lex-close-paren ")" $Close_Paren + ^:private lex-open-bracket "[" $Open_Bracket + ^:private lex-close-bracket "]" $Close_Bracket + ^:private lex-open-brace "{" $Open_Brace + ^:private lex-close-brace "}" $Close_Brace ) (def ^:private lex-delimiter diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 762e2582f..a8b2cfc16 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -10,9 +10,28 @@ (:require [clojure.template :refer [do-template]] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |case]] + (lux [base :as & :refer [deftags |do return fail |case]] [lexer :as &lexer]))) +;; [Tags] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" + ) + ;; [Utils] (do-template [ ] (defn [parse] @@ -25,8 +44,8 @@ _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form "Close_Paren" "parantheses" &/$FormS - ^:private parse-tuple "Close_Bracket" "brackets" &/$TupleS + ^:private parse-form $Close_Paren "parantheses" &/$FormS + ^:private parse-tuple $Close_Bracket "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -34,7 +53,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ("Close_Brace" _)) + (&/$Meta meta ($Close_Brace _)) (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -47,42 +66,42 @@ (|do [token &lexer/lex :let [(&/$Meta meta token*) token]] (|case token* - ("White_Space" _) + ($White_Space _) (return (&/|list)) - ("Comment" _) + ($Comment _) (return (&/|list)) - ("Bool" ?value) + ($Bool ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) - ("Int" ?value) + ($Int ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) - ("Real" ?value) + ($Real ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) - ("Char" ^String ?value) + ($Char ^String ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) - ("Text" ?value) + ($Text ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) - ("Symbol" ?ident) + ($Symbol ?ident) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) - ("Tag" ?ident) + ($Tag ?ident) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) - ("Open_Paren" _) + ($Open_Paren _) (|do [syntax (parse-form parse)] (return (&/|list (&/V &/$Meta (&/T meta syntax))))) - ("Open_Bracket" _) + ($Open_Bracket _) (|do [syntax (parse-tuple parse)] (return (&/|list (&/V &/$Meta (&/T meta syntax))))) - ("Open_Brace" _) + ($Open_Brace _) (|do [syntax (parse-record parse)] (return (&/|list (&/V &/$Meta (&/T meta syntax))))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 7cdf9efdf..6aa8cca6d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,7 +10,13 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* |let |case]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + +;; [Tags] +(deftags "" + "No" + "Done" + "Yes") ;; [Utils] (defn ^:private with-line [body] @@ -22,14 +28,14 @@ (&/$Cons [[file-name line-num column-num] line] more) (|case (body file-name line-num column-num line) - ("No" msg) + ($No msg) (fail* msg) - ("Done" output) + ($Done output) (return* (&/set$ &/$SOURCE more state) output) - ("Yes" output line*) + ($Yes output line*) (return* (&/set$ &/$SOURCE (&/|cons line* more) state) output)) ))) @@ -79,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) match)) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) match) + (&/V $Done (&/T (&/T file-name line-num column-num) match)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -92,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -127,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V "Done" (&/T (&/T file-name line-num column-num) text)) - (&/V "Yes" (&/T (&/T (&/T file-name line-num column-num) text) + (&/V $Done (&/T (&/T file-name line-num column-num) text)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) (&/T (&/T file-name line-num column-num*) line))))) - (&/V "No" (str "[Reader Error] Text failed: " text)))))) + (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] -- cgit v1.2.3 From eb1290b70e26e7cf176e12873aca1593a70f2276 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 18:40:29 -0400 Subject: Refactored tags for pattern-matching and vars. --- src/lux/analyser/case.clj | 145 +++++++++++++++++++++++++++------------------- src/lux/analyser/env.clj | 2 +- src/lux/analyser/lux.clj | 10 ++-- src/lux/base.clj | 5 ++ src/lux/compiler.clj | 4 +- src/lux/compiler/case.clj | 19 +++--- 6 files changed, 108 insertions(+), 77 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index aaf11ff15..6cf070a52 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,12 +9,37 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return fail |let |case]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] [env :as &env]))) +;; [Tags] +(deftags "" + "DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "RecordTotal" + "VariantTotal" + ) + +(deftags "" + "StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "RecordTestAC" + "VariantTestAC" + ) + ;; [Utils] (def ^:private unit (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) @@ -119,7 +144,7 @@ (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T (&/V "StoreTestAC" idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) @@ -127,27 +152,27 @@ (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T (&/V "BoolTestAC" ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T (&/V "IntTestAC" ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T (&/V "RealTestAC" ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T (&/V "CharTestAC" ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T (&/V "TextTestAC" ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] @@ -164,7 +189,7 @@ (|do [=kont kont] (return (&/T (&/|list) =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V "TupleTestAC" =tests) =kont))))) + (return (&/T (&/V $TupleTestAC =tests) =kont))))) _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) @@ -194,7 +219,7 @@ (|do [=kont kont] (return (&/T (&/|table) =kont))) (&/|reverse ?slots))] - (return (&/T (&/V "RecordTestAC" =tests) =kont)))) + (return (&/T (&/V $RecordTestAC =tests) =kont)))) _ (fail "[Pattern-matching Error] Record requires record-type."))) @@ -204,7 +229,7 @@ value-type* (adjust-type value-type) case-type (&type/variant-case =tag value-type*) [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) @@ -216,7 +241,7 @@ 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))] - (return (&/T (&/V "VariantTestAC" (&/T =tag =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] @@ -228,68 +253,68 @@ (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] - [("DefaultTotal" total?) ("StoreTestAC" ?idx)] - (return (&/V "DefaultTotal" true)) + [($DefaultTotal total?) ($StoreTestAC ?idx)] + (return (&/V $DefaultTotal true)) - [[?tag [total? ?values]] ("StoreTestAC" ?idx)] + [[?tag [total? ?values]] ($StoreTestAC ?idx)] (return (&/V ?tag (&/T true ?values))) - [("DefaultTotal" total?) ("BoolTestAC" ?value)] - (return (&/V "BoolTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) - [("BoolTotal" total? ?values) ("BoolTestAC" ?value)] - (return (&/V "BoolTotal" (&/T total? (&/|cons ?value ?values)))) + [($BoolTotal total? ?values) ($BoolTestAC ?value)] + (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("IntTestAC" ?value)] - (return (&/V "IntTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) - [("IntTotal" total? ?values) ("IntTestAC" ?value)] - (return (&/V "IntTotal" (&/T total? (&/|cons ?value ?values)))) + [($IntTotal total? ?values) ($IntTestAC ?value)] + (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("RealTestAC" ?value)] - (return (&/V "RealTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) - [("RealTotal" total? ?values) ("RealTestAC" ?value)] - (return (&/V "RealTotal" (&/T total? (&/|cons ?value ?values)))) + [($RealTotal total? ?values) ($RealTestAC ?value)] + (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("CharTestAC" ?value)] - (return (&/V "CharTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) - [("CharTotal" total? ?values) ("CharTestAC" ?value)] - (return (&/V "CharTotal" (&/T total? (&/|cons ?value ?values)))) + [($CharTotal total? ?values) ($CharTestAC ?value)] + (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("TextTestAC" ?value)] - (return (&/V "TextTotal" (&/T total? (&/|list ?value)))) + [($DefaultTotal total?) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) - [("TextTotal" total? ?values) ("TextTestAC" ?value)] - (return (&/V "TextTotal" (&/T total? (&/|cons ?value ?values)))) + [($TextTotal total? ?values) ($TextTestAC ?value)] + (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) - [("DefaultTotal" total?) ("TupleTestAC" ?tests)] + [($DefaultTotal total?) ($TupleTestAC ?tests)] (|do [structs (&/map% (fn [t] - (merge-total (&/V "DefaultTotal" total?) (&/T t ?body))) + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) ?tests)] - (return (&/V "TupleTotal" (&/T total? structs)))) + (return (&/V $TupleTotal (&/T total? structs)))) - [("TupleTotal" total? ?values) ("TupleTestAC" ?tests)] + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [v t] (merge-total v (&/T t ?body))) ?values ?tests)] - (return (&/V "TupleTotal" (&/T total? structs)))) + (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [("DefaultTotal" total?) ("RecordTestAC" ?tests)] + [($DefaultTotal total?) ($RecordTestAC ?tests)] (|do [structs (&/map% (fn [t] (|let [[slot value] t] - (|do [struct* (merge-total (&/V "DefaultTotal" total?) (&/T value ?body))] + (|do [struct* (merge-total (&/V $DefaultTotal total?) (&/T value ?body))] (return (&/T slot struct*))))) (->> ?tests &/->seq (sort compare-kv) &/->list))] - (return (&/V "RecordTotal" (&/T total? structs)))) + (return (&/V $RecordTotal (&/T total? structs)))) - [("RecordTotal" total? ?values) ("RecordTestAC" ?tests)] + [($RecordTotal total? ?values) ($RecordTestAC ?tests)] (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) (|do [structs (&/map2% (fn [left right] (|let [[lslot sub-struct] left @@ -303,40 +328,40 @@ &/->seq (sort compare-kv) &/->list))] - (return (&/V "RecordTotal" (&/T total? structs)))) + (return (&/V $RecordTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent record-size.")) - [("DefaultTotal" total?) ("VariantTestAC" ?tag ?test)] - (|do [sub-struct (merge-total (&/V "DefaultTotal" total?) + [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) (&/T ?test ?body))] - (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct (&/|table)))))) + (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - [("VariantTotal" total? ?branches) ("VariantTestAC" ?tag ?test)] + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?test)] (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) - (&/V "DefaultTotal" total?)) + (&/V $DefaultTotal total?)) (&/T ?test ?body))] - (return (&/V "VariantTotal" (&/T total? (&/|put ?tag sub-struct ?branches))))) + (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct ?branches))))) )))) (defn ^:private check-totality [value-type struct] (|case struct - ("BoolTotal" ?total ?values) + ($BoolTotal ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) - ("IntTotal" ?total _) + ($IntTotal ?total _) (return ?total) - ("RealTotal" ?total _) + ($RealTotal ?total _) (return ?total) - ("CharTotal" ?total _) + ($CharTotal ?total _) (return ?total) - ("TextTotal" ?total _) + ($TextTotal ?total _) (return ?total) - ("TupleTotal" ?total ?structs) + ($TupleTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] @@ -350,7 +375,7 @@ _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ("RecordTotal" ?total ?structs) + ($RecordTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] @@ -367,7 +392,7 @@ _ (fail "[Pattern-maching Error] Record is not total.")))) - ("VariantTotal" ?total ?structs) + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] @@ -384,7 +409,7 @@ _ (fail "[Pattern-maching Error] Variant is not total.")))) - ("DefaultTotal" ?total) + ($DefaultTotal ?total) (return ?total) )) @@ -395,7 +420,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/V "DefaultTotal" false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 9a8a6a3d7..2f35218d8 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] - (let [bound-unit (&/V "lux;Local" (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] + (let [bound-unit (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER inc) (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6503fe2ea..843cfef96 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -157,7 +157,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] @@ -177,7 +177,7 @@ (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global - [("lux;Global" ?module* name*) _] + [(&/$Global ?module* name*) _] ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] endo-type (|case $def @@ -193,7 +193,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V "lux;Global" (&/T r-module r-name)) + (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) endo-type)))) state) @@ -272,7 +272,7 @@ (|do [loader &/loader] (|let [[=fn-form =fn-type] =fn] (|case =fn-form - ("lux;Global" ?module ?name) + (&/$Global ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (|case $def ("lux;MacroD" macro) @@ -387,7 +387,7 @@ (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] (|case =value - [("lux;Global" ?r-module ?r-name) _] + [(&/$Global ?r-module ?r-name) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 66b972f94..b496be449 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -82,6 +82,11 @@ (def $SOURCE 7) (def $TYPES 8) +;; Vars +(deftags "lux;" + "Local" + "Global") + ;; [Exports] (def +name-separator+ ";") diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 86359d26e..2565c3b20 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -61,13 +61,13 @@ ("record" ?elems) (&&lux/compile-record compile-expression ?type ?elems) - ("lux;Local" ?idx) + (&/$Local ?idx) (&&lux/compile-local compile-expression ?type ?idx) ("captured" ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - ("lux;Global" ?owner-class ?name) + (&/$Global ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) ("apply" ?fn ?args) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index d27577be1..e2cbe77a2 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -17,6 +17,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.analyser.case :as &a-case] [lux.compiler.base :as &&]) (:import (org.objectweb.asm Opcodes Label @@ -27,12 +28,12 @@ (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private compile-match [^MethodVisitor writer ?match $target $else] (|case ?match - ("StoreTestAC" ?idx) + (&a-case/$StoreTestAC ?idx) (doto writer (.visitVarInsn Opcodes/ASTORE ?idx) (.visitJumpInsn Opcodes/GOTO $target)) - ("BoolTestAC" ?value) + (&a-case/$BoolTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Boolean") (.visitInsn Opcodes/DUP) @@ -42,7 +43,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("IntTestAC" ?value) + (&a-case/$IntTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Long") (.visitInsn Opcodes/DUP) @@ -53,7 +54,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("RealTestAC" ?value) + (&a-case/$RealTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Double") (.visitInsn Opcodes/DUP) @@ -64,7 +65,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("CharTestAC" ?value) + (&a-case/$CharTestAC ?value) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "java/lang/Character") (.visitInsn Opcodes/DUP) @@ -74,7 +75,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("TextTestAC" ?value) + (&a-case/$TextTestAC ?value) (doto writer (.visitInsn Opcodes/DUP) (.visitLdcInsn ?value) @@ -83,7 +84,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("TupleTestAC" ?members) + (&a-case/$TupleTestAC ?members) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -101,7 +102,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("RecordTestAC" ?slots) + (&a-case/$RecordTestAC ?slots) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (-> (doto (.visitInsn Opcodes/DUP) @@ -124,7 +125,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - ("VariantTestAC" ?tag ?test) + (&a-case/$VariantTestAC ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) -- cgit v1.2.3 From 4b96f550165bcea089a78a6901d40850d06a4b05 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 18:54:09 -0400 Subject: Refactored the tags of definitions. --- src/lux/analyser/lux.clj | 15 ++++++++------- src/lux/analyser/module.clj | 24 ++++++++++++------------ src/lux/base.clj | 9 ++++++++- src/lux/compiler/cache.clj | 6 +++--- src/lux/compiler/lux.clj | 4 ++-- 5 files changed, 33 insertions(+), 25 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 843cfef96..e0f00a0a2 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -144,14 +144,15 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] + ;; :let [_ (prn 'analyse-global/$def (aget $def 0))] endo-type (|case $def - ("lux;ValueD" ?type _) + (&/$ValueD ?type _) (return ?type) - ("lux;MacroD" _) + (&/$MacroD _) (return &type/Macro) - ("lux;TypeD" _) + (&/$TypeD _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -181,13 +182,13 @@ ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] endo-type (|case $def - ("lux;ValueD" ?type _) + (&/$ValueD ?type _) (return ?type) - ("lux;MacroD" _) + (&/$MacroD _) (return &type/Macro) - ("lux;TypeD" _) + (&/$TypeD _) (return &type/Type)) _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) @@ -275,7 +276,7 @@ (&/$Global ?module ?name) (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] (|case $def - ("lux;MacroD" macro) + (&/$MacroD macro) (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 78f5c675d..35ae7e5b7 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -66,16 +66,16 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] (|case $def - [_ ("lux;TypeD" _)] + [_ (&/$TypeD _)] (return* state &type/Type) - [_ ("lux;MacroD" _)] + [_ (&/$MacroD _)] (return* state &type/Macro) - [_ ("lux;ValueD" _type _)] + [_ (&/$ValueD _type _)] (return* state _type) - [_ ("lux;AliasD" ?r-module ?r-name)] + [_ (&/$AliasD ?r-module ?r-name)] (&/run-state (def-type ?r-module ?r-name) state)) (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) @@ -92,7 +92,7 @@ (&/|update a-module (fn [m] (&/update$ $DEFS - #(&/|put a-name (&/T false (&/V "lux;AliasD" (&/T r-module r-name))) %) + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) m)) ms)))) nil) @@ -137,7 +137,7 @@ (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) (|case $$def - ("lux;AliasD" ?r-module ?r-name) + (&/$AliasD ?r-module ?r-name) (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) ((find-def ?r-module ?r-name) state)) @@ -158,7 +158,7 @@ (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] (if-let [$def (&/|get name $module)] (|case $def - [exported? ("lux;ValueD" ?type _)] + [exported? (&/$ValueD ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) @@ -170,14 +170,14 @@ (&/|update module (fn [m] (&/update$ $DEFS - #(&/|put name (&/T exported? (&/V "lux;MacroD" macro)) %) + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) m)) $modules)) state*) nil))) state) - [_ ("lux;MacroD" _)] + [_ (&/$MacroD _)] (fail* (str "[Analyser Error] Can't re-declare a macro: " (str module &/+name-separator+ name))) [_ _] @@ -216,13 +216,13 @@ (|let [[k [?exported? ?def]] kv] (do ;; (prn 'defs k ?exported?) (|case ?def - ("lux;AliasD" ?r-module ?r-name) + (&/$AliasD ?r-module ?r-name) (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) - ("lux;MacroD" _) + (&/$MacroD _) (&/T ?exported? k "M") - ("lux;TypeD" _) + (&/$TypeD _) (&/T ?exported? k "T") _ diff --git a/src/lux/base.clj b/src/lux/base.clj index b496be449..f690ef65f 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -14,7 +14,7 @@ ;; [Tags] (defmacro deftags [prefix & names] `(do ~@(for [name names] - `(def ~(symbol (str "$" name)) ~name)))) + `(def ~(symbol (str "$" name)) ~(str prefix name))))) ;; List (def $Nil "lux;Nil") @@ -87,6 +87,13 @@ "Local" "Global") +;; Definitions +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") + ;; [Exports] (def +name-separator+ ";") diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 2b6f2e919..742ac69d8 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -118,16 +118,16 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field "_datum" def-class)] - (&a-module/define module _name (&/V "lux;TypeD" def-value) &type/Type)) + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field "_datum" def-class)] - (|do [_ (&a-module/define module _name (&/V "lux;ValueD" (&/T &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) def-meta (get-field "_meta" def-class)] (|case def-meta - ("lux;ValueD" def-type _) + (&/$ValueD def-type _) (&a-module/define module _name def-meta def-type))) ;; else (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 9a3a7a6f2..2d28f8b3f 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -147,7 +147,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;TypeD") ;; VVIT + (.visitLdcInsn &/$TypeD) ;; VVIT (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -173,7 +173,7 @@ (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI - (.visitLdcInsn "lux;ValueD") ;; VVIT + (.visitLdcInsn &/$ValueD) ;; VVIT (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI -- cgit v1.2.3 From 4fabf7e4f01d1e617620e9bc361ed27ba3b8b5e0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 8 Aug 2015 19:34:10 -0400 Subject: Refactored the tags for the analyser. --- src/lux/analyser.clj | 10 +-- src/lux/analyser/base.clj | 118 ++++++++++++++++++++++++- src/lux/analyser/host.clj | 180 +++++++++++++++++++------------------- src/lux/analyser/lambda.clj | 6 +- src/lux/analyser/lux.clj | 24 ++--- src/lux/compiler.clj | 208 ++++++++++++++++++++++---------------------- src/lux/compiler/lambda.clj | 6 +- src/lux/compiler/lux.clj | 2 +- src/lux/compiler/type.clj | 9 +- 9 files changed, 340 insertions(+), 223 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index f8dd13bd6..0e58f530b 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -467,23 +467,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V "bool" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V "int" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V "real" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V "char" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V "text" ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index ed81aa9bc..3484e869d 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -9,9 +9,125 @@ (ns lux.analyser.base (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] + (lux [base :as & :refer [deftags |let |do return fail |case]] [type :as &type]))) +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "record" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + ;; [Exports] (defn expr-type [syntax+] (|let [[_ type] syntax+] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index ec8b8b5db..64f297994 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -62,45 +62,45 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) - analyse-jvm-iadd "jvm-iadd" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-isub "jvm-isub" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-imul "jvm-imul" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-idiv "jvm-idiv" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-irem "jvm-irem" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ieq "jvm-ieq" "java.lang.Integer" "java.lang.Boolean" - analyse-jvm-ilt "jvm-ilt" "java.lang.Integer" "java.lang.Boolean" - analyse-jvm-igt "jvm-igt" "java.lang.Integer" "java.lang.Boolean" - - analyse-jvm-ceq "jvm-ceq" "java.lang.Character" "java.lang.Boolean" - analyse-jvm-clt "jvm-clt" "java.lang.Character" "java.lang.Boolean" - analyse-jvm-cgt "jvm-cgt" "java.lang.Character" "java.lang.Boolean" - - analyse-jvm-ladd "jvm-ladd" "java.lang.Long" "java.lang.Long" - analyse-jvm-lsub "jvm-lsub" "java.lang.Long" "java.lang.Long" - analyse-jvm-lmul "jvm-lmul" "java.lang.Long" "java.lang.Long" - analyse-jvm-ldiv "jvm-ldiv" "java.lang.Long" "java.lang.Long" - analyse-jvm-lrem "jvm-lrem" "java.lang.Long" "java.lang.Long" - analyse-jvm-leq "jvm-leq" "java.lang.Long" "java.lang.Boolean" - analyse-jvm-llt "jvm-llt" "java.lang.Long" "java.lang.Boolean" - analyse-jvm-lgt "jvm-lgt" "java.lang.Long" "java.lang.Boolean" - - analyse-jvm-fadd "jvm-fadd" "java.lang.Float" "java.lang.Float" - analyse-jvm-fsub "jvm-fsub" "java.lang.Float" "java.lang.Float" - analyse-jvm-fmul "jvm-fmul" "java.lang.Float" "java.lang.Float" - analyse-jvm-fdiv "jvm-fdiv" "java.lang.Float" "java.lang.Float" - analyse-jvm-frem "jvm-frem" "java.lang.Float" "java.lang.Float" - analyse-jvm-feq "jvm-feq" "java.lang.Float" "java.lang.Boolean" - analyse-jvm-flt "jvm-flt" "java.lang.Float" "java.lang.Boolean" - analyse-jvm-fgt "jvm-fgt" "java.lang.Float" "java.lang.Boolean" - - analyse-jvm-dadd "jvm-dadd" "java.lang.Double" "java.lang.Double" - analyse-jvm-dsub "jvm-dsub" "java.lang.Double" "java.lang.Double" - analyse-jvm-dmul "jvm-dmul" "java.lang.Double" "java.lang.Double" - analyse-jvm-ddiv "jvm-ddiv" "java.lang.Double" "java.lang.Double" - analyse-jvm-drem "jvm-drem" "java.lang.Double" "java.lang.Double" - analyse-jvm-deq "jvm-deq" "java.lang.Double" "java.lang.Boolean" - analyse-jvm-dlt "jvm-dlt" "java.lang.Double" "java.lang.Boolean" - analyse-jvm-dgt "jvm-dgt" "java.lang.Double" "java.lang.Boolean" + analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" + analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" + analyse-jvm-imul &&/$jvm-imul "java.lang.Integer" "java.lang.Integer" + analyse-jvm-idiv &&/$jvm-idiv "java.lang.Integer" "java.lang.Integer" + analyse-jvm-irem &&/$jvm-irem "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ieq &&/$jvm-ieq "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-ilt &&/$jvm-ilt "java.lang.Integer" "java.lang.Boolean" + analyse-jvm-igt &&/$jvm-igt "java.lang.Integer" "java.lang.Boolean" + + analyse-jvm-ceq &&/$jvm-ceq "java.lang.Character" "java.lang.Boolean" + analyse-jvm-clt &&/$jvm-clt "java.lang.Character" "java.lang.Boolean" + analyse-jvm-cgt &&/$jvm-cgt "java.lang.Character" "java.lang.Boolean" + + analyse-jvm-ladd &&/$jvm-ladd "java.lang.Long" "java.lang.Long" + analyse-jvm-lsub &&/$jvm-lsub "java.lang.Long" "java.lang.Long" + analyse-jvm-lmul &&/$jvm-lmul "java.lang.Long" "java.lang.Long" + analyse-jvm-ldiv &&/$jvm-ldiv "java.lang.Long" "java.lang.Long" + analyse-jvm-lrem &&/$jvm-lrem "java.lang.Long" "java.lang.Long" + analyse-jvm-leq &&/$jvm-leq "java.lang.Long" "java.lang.Boolean" + analyse-jvm-llt &&/$jvm-llt "java.lang.Long" "java.lang.Boolean" + analyse-jvm-lgt &&/$jvm-lgt "java.lang.Long" "java.lang.Boolean" + + analyse-jvm-fadd &&/$jvm-fadd "java.lang.Float" "java.lang.Float" + analyse-jvm-fsub &&/$jvm-fsub "java.lang.Float" "java.lang.Float" + analyse-jvm-fmul &&/$jvm-fmul "java.lang.Float" "java.lang.Float" + analyse-jvm-fdiv &&/$jvm-fdiv "java.lang.Float" "java.lang.Float" + analyse-jvm-frem &&/$jvm-frem "java.lang.Float" "java.lang.Float" + analyse-jvm-feq &&/$jvm-feq "java.lang.Float" "java.lang.Boolean" + analyse-jvm-flt &&/$jvm-flt "java.lang.Float" "java.lang.Boolean" + analyse-jvm-fgt &&/$jvm-fgt "java.lang.Float" "java.lang.Boolean" + + analyse-jvm-dadd &&/$jvm-dadd "java.lang.Double" "java.lang.Double" + analyse-jvm-dsub &&/$jvm-dsub "java.lang.Double" "java.lang.Double" + analyse-jvm-dmul &&/$jvm-dmul "java.lang.Double" "java.lang.Double" + analyse-jvm-ddiv &&/$jvm-ddiv "java.lang.Double" "java.lang.Double" + analyse-jvm-drem &&/$jvm-drem "java.lang.Double" "java.lang.Double" + analyse-jvm-deq &&/$jvm-deq "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dlt &&/$jvm-dlt "java.lang.Double" "java.lang.Boolean" + analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) (defn analyse-jvm-getstatic [analyse exo-type ?class ?field] @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-getstatic" (&/T ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-getfield" (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-putstatic" (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-putfield" (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -148,14 +148,14 @@ ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-invokestatic" (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-instanceof" (&/T ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) (do-template [ ] (defn [analyse exo-type ?class ?method ?classes ?object ?args] @@ -169,8 +169,8 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) - analyse-jvm-invokevirtual "jvm-invokevirtual" - analyse-jvm-invokeinterface "jvm-invokeinterface" + analyse-jvm-invokevirtual &&/$jvm-invokevirtual + analyse-jvm-invokeinterface &&/$jvm-invokeinterface ) (defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] @@ -185,41 +185,41 @@ =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-invokespecial" (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-null?" =object) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-null" nil) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V "jvm-new" (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V "jvm-new-array" (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) - (&/V &/$Nil nil))))))) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V "jvm-aastore" (&/T =array ?idx =elem)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V "jvm-aaload" (&/T =array ?idx)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] @@ -327,7 +327,7 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/V "jvm-class" (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] @@ -349,7 +349,7 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/V "jvm-interface" (&/T ?name =supers =methods)))] + _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] @@ -365,13 +365,13 @@ (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V "jvm-try" (&/T =body =catches =finally)) exo-type))))) + (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] - (return (&/|list (&/T (&/V "jvm-throw" =ex) &type/$Void))))) + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] (defn [analyse exo-type ?monitor] @@ -381,8 +381,8 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =monitor) output-type))))) - analyse-jvm-monitorenter "jvm-monitorenter" - analyse-jvm-monitorexit "jvm-monitorexit" + analyse-jvm-monitorenter &&/$jvm-monitorenter + analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] @@ -392,24 +392,24 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) - analyse-jvm-d2f "jvm-d2f" "java.lang.Double" "java.lang.Float" - analyse-jvm-d2i "jvm-d2i" "java.lang.Double" "java.lang.Integer" - analyse-jvm-d2l "jvm-d2l" "java.lang.Double" "java.lang.Long" + analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" + analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" + analyse-jvm-d2l &&/$jvm-d2l "java.lang.Double" "java.lang.Long" - analyse-jvm-f2d "jvm-f2d" "java.lang.Float" "java.lang.Double" - analyse-jvm-f2i "jvm-f2i" "java.lang.Float" "java.lang.Integer" - analyse-jvm-f2l "jvm-f2l" "java.lang.Float" "java.lang.Long" + analyse-jvm-f2d &&/$jvm-f2d "java.lang.Float" "java.lang.Double" + analyse-jvm-f2i &&/$jvm-f2i "java.lang.Float" "java.lang.Integer" + analyse-jvm-f2l &&/$jvm-f2l "java.lang.Float" "java.lang.Long" - analyse-jvm-i2b "jvm-i2b" "java.lang.Integer" "java.lang.Byte" - analyse-jvm-i2c "jvm-i2c" "java.lang.Integer" "java.lang.Character" - analyse-jvm-i2d "jvm-i2d" "java.lang.Integer" "java.lang.Double" - analyse-jvm-i2f "jvm-i2f" "java.lang.Integer" "java.lang.Float" - analyse-jvm-i2l "jvm-i2l" "java.lang.Integer" "java.lang.Long" - analyse-jvm-i2s "jvm-i2s" "java.lang.Integer" "java.lang.Short" + analyse-jvm-i2b &&/$jvm-i2b "java.lang.Integer" "java.lang.Byte" + analyse-jvm-i2c &&/$jvm-i2c "java.lang.Integer" "java.lang.Character" + analyse-jvm-i2d &&/$jvm-i2d "java.lang.Integer" "java.lang.Double" + analyse-jvm-i2f &&/$jvm-i2f "java.lang.Integer" "java.lang.Float" + analyse-jvm-i2l &&/$jvm-i2l "java.lang.Integer" "java.lang.Long" + analyse-jvm-i2s &&/$jvm-i2s "java.lang.Integer" "java.lang.Short" - analyse-jvm-l2d "jvm-l2d" "java.lang.Long" "java.lang.Double" - analyse-jvm-l2f "jvm-l2f" "java.lang.Long" "java.lang.Float" - analyse-jvm-l2i "jvm-l2i" "java.lang.Long" "java.lang.Integer" + analyse-jvm-l2d &&/$jvm-l2d "java.lang.Long" "java.lang.Double" + analyse-jvm-l2f &&/$jvm-l2f "java.lang.Long" "java.lang.Float" + analyse-jvm-l2i &&/$jvm-l2i "java.lang.Long" "java.lang.Integer" ) (do-template [ ] @@ -419,24 +419,24 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) - analyse-jvm-iand "jvm-iand" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ior "jvm-ior" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ixor "jvm-ixor" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishl "jvm-ishl" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishr "jvm-ishr" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-iushr "jvm-iushr" "java.lang.Integer" "java.lang.Integer" - - analyse-jvm-land "jvm-land" "java.lang.Long" "java.lang.Long" - analyse-jvm-lor "jvm-lor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lxor "jvm-lxor" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "jvm-lshl" "java.lang.Long" "java.lang.Integer" - analyse-jvm-lshr "jvm-lshr" "java.lang.Long" "java.lang.Integer" - analyse-jvm-lushr "jvm-lushr" "java.lang.Long" "java.lang.Integer" + analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ixor &&/$jvm-ixor "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishl &&/$jvm-ishl "java.lang.Integer" "java.lang.Integer" + analyse-jvm-ishr &&/$jvm-ishr "java.lang.Integer" "java.lang.Integer" + analyse-jvm-iushr &&/$jvm-iushr "java.lang.Integer" "java.lang.Integer" + + analyse-jvm-land &&/$jvm-land "java.lang.Long" "java.lang.Long" + analyse-jvm-lor &&/$jvm-lor "java.lang.Long" "java.lang.Long" + analyse-jvm-lxor &&/$jvm-lxor "java.lang.Long" "java.lang.Long" + analyse-jvm-lshl &&/$jvm-lshl "java.lang.Long" "java.lang.Integer" + analyse-jvm-lshr &&/$jvm-lshr "java.lang.Long" "java.lang.Integer" + analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer" ) (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V "jvm-program" =body))] + _ (compile-token (&/V &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index a230c8642..91cf3443b 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -26,9 +26,9 @@ (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/T (&/V "captured" (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) - register)) + register* (&/T (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + register)) register-type)] (&/T register* (&/update$ &/$CLOSURE #(->> % (&/update$ &/$COUNTER inc) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e0f00a0a2..45177ce46 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -41,7 +41,7 @@ (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) ?members ?elems)] - (return (&/|list (&/T (&/V "tuple" =elems) + (return (&/|list (&/T (&/V &&/$tuple =elems) exo-type)))) (&/$AllT _) @@ -86,7 +86,7 @@ (|do [?tag (&&/resolved-ident ident)] (if-let [vtype (&/|get ?tag ?cases)] (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V "variant" (&/T ?tag =value)) + (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) exo-type)))) (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) @@ -139,7 +139,7 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) ?elems)] - (return (&/|list (&/T (&/V "record" =slots) (&/V &/$RecordT exo-type)))))) + (return (&/|list (&/T (&/V &&/$record =slots) (&/V &/$RecordT exo-type)))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -282,7 +282,7 @@ ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (or (= "<>" r-name) - ;; ;; (= "struct" r-name) + ;; ;; (= &&/$struct r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion*) ;; (&/|interpose "\n") @@ -293,12 +293,12 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V "apply" (&/T =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t))))) ))) @@ -309,7 +309,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V "case" (&/T =value =match)) + (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -328,7 +328,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V "lambda" (&/T =scope =captured =body)) exo-type*))) + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -397,13 +397,13 @@ _ (do (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V "def" (&/T ?name =value)))] + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] (|do [module-name &/get-module-name] - (|do [_ (compile-token (&/V "declare-macro" (&/T module-name ?name)))] + (|do [_ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] (return (&/|list))))) (defn analyse-import [analyse compile-module compile-token ?path] @@ -433,7 +433,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -441,5 +441,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V "ann" (&/T =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 2565c3b20..490491bd0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -40,333 +40,333 @@ (defn ^:private compile-expression [syntax] (|let [[?form ?type] syntax] (|case ?form - ("bool" ?value) + (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) - ("int" ?value) + (&a/$int ?value) (&&lux/compile-int compile-expression ?type ?value) - ("real" ?value) + (&a/$real ?value) (&&lux/compile-real compile-expression ?type ?value) - ("char" ?value) + (&a/$char ?value) (&&lux/compile-char compile-expression ?type ?value) - ("text" ?value) + (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - ("tuple" ?elems) + (&a/$tuple ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - ("record" ?elems) + (&a/$record ?elems) (&&lux/compile-record compile-expression ?type ?elems) (&/$Local ?idx) (&&lux/compile-local compile-expression ?type ?idx) - ("captured" ?scope ?captured-id ?source) + (&a/$captured ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) (&/$Global ?owner-class ?name) (&&lux/compile-global compile-expression ?type ?owner-class ?name) - ("apply" ?fn ?args) + (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - ("variant" ?tag ?members) + (&a/$variant ?tag ?members) (&&lux/compile-variant compile-expression ?type ?tag ?members) - ("case" ?value ?match) + (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) - ("lambda" ?scope ?env ?body) + (&a/$lambda ?scope ?env ?body) (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - ("ann" ?value-ex ?type-ex) + (&a/$ann ?value-ex ?type-ex) (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) ;; Characters - ("jvm-ceq" ?x ?y) + (&a/$jvm-ceq ?x ?y) (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - ("jvm-clt" ?x ?y) + (&a/$jvm-clt ?x ?y) (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - ("jvm-cgt" ?x ?y) + (&a/$jvm-cgt ?x ?y) (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) ;; Integer arithmetic - ("jvm-iadd" ?x ?y) + (&a/$jvm-iadd ?x ?y) (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - ("jvm-isub" ?x ?y) + (&a/$jvm-isub ?x ?y) (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - ("jvm-imul" ?x ?y) + (&a/$jvm-imul ?x ?y) (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - ("jvm-idiv" ?x ?y) + (&a/$jvm-idiv ?x ?y) (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - ("jvm-irem" ?x ?y) + (&a/$jvm-irem ?x ?y) (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - ("jvm-ieq" ?x ?y) + (&a/$jvm-ieq ?x ?y) (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - ("jvm-ilt" ?x ?y) + (&a/$jvm-ilt ?x ?y) (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - ("jvm-igt" ?x ?y) + (&a/$jvm-igt ?x ?y) (&&host/compile-jvm-igt compile-expression ?type ?x ?y) ;; Long arithmetic - ("jvm-ladd" ?x ?y) + (&a/$jvm-ladd ?x ?y) (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - ("jvm-lsub" ?x ?y) + (&a/$jvm-lsub ?x ?y) (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - ("jvm-lmul" ?x ?y) + (&a/$jvm-lmul ?x ?y) (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - ("jvm-ldiv" ?x ?y) + (&a/$jvm-ldiv ?x ?y) (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - ("jvm-lrem" ?x ?y) + (&a/$jvm-lrem ?x ?y) (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - ("jvm-leq" ?x ?y) + (&a/$jvm-leq ?x ?y) (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - ("jvm-llt" ?x ?y) + (&a/$jvm-llt ?x ?y) (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - ("jvm-lgt" ?x ?y) + (&a/$jvm-lgt ?x ?y) (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) ;; Float arithmetic - ("jvm-fadd" ?x ?y) + (&a/$jvm-fadd ?x ?y) (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - ("jvm-fsub" ?x ?y) + (&a/$jvm-fsub ?x ?y) (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - ("jvm-fmul" ?x ?y) + (&a/$jvm-fmul ?x ?y) (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - ("jvm-fdiv" ?x ?y) + (&a/$jvm-fdiv ?x ?y) (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - ("jvm-frem" ?x ?y) + (&a/$jvm-frem ?x ?y) (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - ("jvm-feq" ?x ?y) + (&a/$jvm-feq ?x ?y) (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - ("jvm-flt" ?x ?y) + (&a/$jvm-flt ?x ?y) (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - ("jvm-fgt" ?x ?y) + (&a/$jvm-fgt ?x ?y) (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) ;; Double arithmetic - ("jvm-dadd" ?x ?y) + (&a/$jvm-dadd ?x ?y) (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - ("jvm-dsub" ?x ?y) + (&a/$jvm-dsub ?x ?y) (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - ("jvm-dmul" ?x ?y) + (&a/$jvm-dmul ?x ?y) (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - ("jvm-ddiv" ?x ?y) + (&a/$jvm-ddiv ?x ?y) (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - ("jvm-drem" ?x ?y) + (&a/$jvm-drem ?x ?y) (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - ("jvm-deq" ?x ?y) + (&a/$jvm-deq ?x ?y) (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - ("jvm-dlt" ?x ?y) + (&a/$jvm-dlt ?x ?y) (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - ("jvm-dgt" ?x ?y) + (&a/$jvm-dgt ?x ?y) (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - ("jvm-null" _) + (&a/$jvm-null _) (&&host/compile-jvm-null compile-expression ?type) - ("jvm-null?" ?object) + (&a/$jvm-null? ?object) (&&host/compile-jvm-null? compile-expression ?type ?object) - ("jvm-new" ?class ?classes ?args) + (&a/$jvm-new ?class ?classes ?args) (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - ("jvm-getstatic" ?class ?field) + (&a/$jvm-getstatic ?class ?field) (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) - ("jvm-getfield" ?class ?field ?object) + (&a/$jvm-getfield ?class ?field ?object) (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) - ("jvm-putstatic" ?class ?field ?value) + (&a/$jvm-putstatic ?class ?field ?value) (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) - ("jvm-putfield" ?class ?field ?object ?value) + (&a/$jvm-putfield ?class ?field ?object ?value) (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) - ("jvm-invokestatic" ?class ?method ?classes ?args) + (&a/$jvm-invokestatic ?class ?method ?classes ?args) (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) - ("jvm-invokevirtual" ?class ?method ?classes ?object ?args) + (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) - ("jvm-invokeinterface" ?class ?method ?classes ?object ?args) + (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) - ("jvm-invokespecial" ?class ?method ?classes ?object ?args) + (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - ("jvm-new-array" ?class ?length) + (&a/$jvm-new-array ?class ?length) (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) - ("jvm-aastore" ?array ?idx ?elem) + (&a/$jvm-aastore ?array ?idx ?elem) (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) - ("jvm-aaload" ?array ?idx) + (&a/$jvm-aaload ?array ?idx) (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) - ("jvm-try" ?body ?catches ?finally) + (&a/$jvm-try ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) - ("jvm-throw" ?ex) + (&a/$jvm-throw ?ex) (&&host/compile-jvm-throw compile-expression ?type ?ex) - ("jvm-monitorenter" ?monitor) + (&a/$jvm-monitorenter ?monitor) (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) - ("jvm-monitorexit" ?monitor) + (&a/$jvm-monitorexit ?monitor) (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) - ("jvm-d2f" ?value) + (&a/$jvm-d2f ?value) (&&host/compile-jvm-d2f compile-expression ?type ?value) - ("jvm-d2i" ?value) + (&a/$jvm-d2i ?value) (&&host/compile-jvm-d2i compile-expression ?type ?value) - ("jvm-d2l" ?value) + (&a/$jvm-d2l ?value) (&&host/compile-jvm-d2l compile-expression ?type ?value) - ("jvm-f2d" ?value) + (&a/$jvm-f2d ?value) (&&host/compile-jvm-f2d compile-expression ?type ?value) - ("jvm-f2i" ?value) + (&a/$jvm-f2i ?value) (&&host/compile-jvm-f2i compile-expression ?type ?value) - ("jvm-f2l" ?value) + (&a/$jvm-f2l ?value) (&&host/compile-jvm-f2l compile-expression ?type ?value) - ("jvm-i2b" ?value) + (&a/$jvm-i2b ?value) (&&host/compile-jvm-i2b compile-expression ?type ?value) - ("jvm-i2c" ?value) + (&a/$jvm-i2c ?value) (&&host/compile-jvm-i2c compile-expression ?type ?value) - ("jvm-i2d" ?value) + (&a/$jvm-i2d ?value) (&&host/compile-jvm-i2d compile-expression ?type ?value) - ("jvm-i2f" ?value) + (&a/$jvm-i2f ?value) (&&host/compile-jvm-i2f compile-expression ?type ?value) - ("jvm-i2l" ?value) + (&a/$jvm-i2l ?value) (&&host/compile-jvm-i2l compile-expression ?type ?value) - ("jvm-i2s" ?value) + (&a/$jvm-i2s ?value) (&&host/compile-jvm-i2s compile-expression ?type ?value) - ("jvm-l2d" ?value) + (&a/$jvm-l2d ?value) (&&host/compile-jvm-l2d compile-expression ?type ?value) - ("jvm-l2f" ?value) + (&a/$jvm-l2f ?value) (&&host/compile-jvm-l2f compile-expression ?type ?value) - ("jvm-l2i" ?value) + (&a/$jvm-l2i ?value) (&&host/compile-jvm-l2i compile-expression ?type ?value) - ("jvm-iand" ?x ?y) + (&a/$jvm-iand ?x ?y) (&&host/compile-jvm-iand compile-expression ?type ?x ?y) - ("jvm-ior" ?x ?y) + (&a/$jvm-ior ?x ?y) (&&host/compile-jvm-ior compile-expression ?type ?x ?y) - ("jvm-ixor" ?x ?y) + (&a/$jvm-ixor ?x ?y) (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) - ("jvm-ishl" ?x ?y) + (&a/$jvm-ishl ?x ?y) (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) - ("jvm-ishr" ?x ?y) + (&a/$jvm-ishr ?x ?y) (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) - ("jvm-iushr" ?x ?y) + (&a/$jvm-iushr ?x ?y) (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) - ("jvm-land" ?x ?y) + (&a/$jvm-land ?x ?y) (&&host/compile-jvm-land compile-expression ?type ?x ?y) - ("jvm-lor" ?x ?y) + (&a/$jvm-lor ?x ?y) (&&host/compile-jvm-lor compile-expression ?type ?x ?y) - ("jvm-lxor" ?x ?y) + (&a/$jvm-lxor ?x ?y) (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) - ("jvm-lshl" ?x ?y) + (&a/$jvm-lshl ?x ?y) (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) - ("jvm-lshr" ?x ?y) + (&a/$jvm-lshr ?x ?y) (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) - ("jvm-lushr" ?x ?y) + (&a/$jvm-lushr ?x ?y) (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) - ("jvm-instanceof" ?class ?object) + (&a/$jvm-instanceof ?class ?object) (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) ) )) (defn ^:private compile-statement [syntax] (|case syntax - ("def" ?name ?body) + (&a/$def ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - ("declare-macro" ?module ?name) + (&a/$declare-macro ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - ("jvm-program" ?body) + (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - ("jvm-interface" ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) (defn ^:private compile-token [syntax] (|case syntax - ("def" ?name ?body) + (&a/$def ?name ?body) (&&lux/compile-def compile-expression ?name ?body) - ("declare-macro" ?module ?name) + (&a/$declare-macro ?module ?name) (&&lux/compile-declare-macro compile-expression ?module ?name) - ("jvm-program" ?body) + (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - ("jvm-interface" ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - ("jvm-class" ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) _ diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 0d1ea4844..136ec0cfc 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -47,7 +47,7 @@ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [("captured" _ ?captured-id ?source) _]]) + [?name [(&a/$captured _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -84,7 +84,7 @@ (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] (|case ?name+?captured - [?name [("captured" _ _ ?source) _]] + [?name [(&a/$captured _ _ ?source) _]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -102,7 +102,7 @@ (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [("captured" _ ?captured-id ?source) _]]) + [?name [(&a/$captured _ ?captured-id ?source) _]]) (doseq [?name+?captured (&/->seq ?env)]))) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 2d28f8b3f..87327311c 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -163,7 +163,7 @@ "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) ?def-type (|case ?body - [("ann" ?def-value ?type-expr) ?def-type] + [(&a/$ann ?def-value ?type-expr) ?def-type] ?type-expr [?def-value ?def-type] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 46e6ec2d9..e9d3014db 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -10,22 +10,23 @@ (:require clojure.core.match clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type]))) + [type :as &type]) + [lux.analyser.base :as &a])) ;; [Utils] (defn ^:private variant$ [tag body] "(-> Text Analysis Analysis)" - (&/T (&/V "variant" (&/T tag body)) + (&/T (&/V &a/$variant (&/T tag body)) &type/$Void)) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" - (&/T (&/V "tuple" members) + (&/T (&/V &a/$tuple members) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V "text" text) + (&/T (&/V &a/$text text) &type/$Void)) (def ^:private $Nil -- cgit v1.2.3 From 4134c811399abfce64b54a821e427d2b153f3e57 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 18:25:39 -0400 Subject: - Changing tags so they're actually indices (part 1). - Fixed a bug regarding type coercion (type-checking was ocurring unnecessarily). - Fixed another bug regarding Local/Global variables. --- src/lux/analyser.clj | 38 +++- src/lux/analyser/base.clj | 1 + src/lux/analyser/env.clj | 2 +- src/lux/analyser/lux.clj | 84 +++++++-- src/lux/analyser/module.clj | 47 ++++- src/lux/base.clj | 98 +++++++---- src/lux/compiler.clj | 4 +- src/lux/compiler/lux.clj | 15 +- src/lux/type.clj | 409 +++++++++++++++++++++++++------------------- 9 files changed, 462 insertions(+), 236 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0e58f530b..7810c415b 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -17,7 +17,8 @@ [host :as &host]) (lux.analyser [base :as &&] [lux :as &&lux] - [host :as &&host]))) + [host :as &&host] + [module :as &&module]))) ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] @@ -37,6 +38,14 @@ _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) +(defn ^:private parse-tag [ast] + (|case ast + (&/$Meta _ (&/$TagS "" name)) + (return name) + + _ + (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) + (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -431,6 +440,12 @@ (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Nil)))) + (|do [tags* (&/map% parse-tag tags)] + (&&lux/analyse-declare-tags tags*)) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) @@ -492,7 +507,9 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (&&lux/analyse-variant analyse exo-type ?ident (&/|list)) + (|do [[module tag-name] (&/normalize ?ident) + idx (&&module/tag-index module tag-name)] + (&&lux/analyse-variant analyse exo-type idx (&/|list))) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) @@ -512,7 +529,10 @@ (|case token (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token))))) (&/$Right state* output) (return* state* output) @@ -540,11 +560,21 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] + ;; (prn 'analyse-ast (&/show-ast token)) (&/with-cursor (aget token 1 0) (&/with-expected-type exo-type (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) (fn [state] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 3484e869d..218fc6dd9 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -28,6 +28,7 @@ "ann" "def" "declare-macro" + "var" "captured" "jvm-getstatic" diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 2f35218d8..614b38799 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) =return (body (&/update$ &/$ENVS (fn [stack] - (let [bound-unit (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER)))] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))] (&/|cons (&/update$ &/$LOCALS #(->> % (&/update$ &/$COUNTER inc) (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 45177ce46..ba4a173f0 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -71,7 +71,7 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse exo-type ident ?values] +(defn analyse-variant [analyse exo-type idx ?values] (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -83,21 +83,50 @@ (&type/actual-type exo-type))] (|case exo-type* (&/$VariantT ?cases) - (|do [?tag (&&/resolved-ident ident)] - (if-let [vtype (&/|get ?tag ?cases)] - (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) - exo-type)))) - (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** ident ?values)))) + (analyse-variant analyse exo-type** idx ?values)))) _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] (|do [exo-type* (|case exo-type @@ -158,7 +187,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] @@ -194,7 +223,7 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &/$Global (&/T r-module r-name)) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) @@ -397,14 +426,39 @@ _ (do (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value)))] + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [module-name &/get-module-name] - (|do [_ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] - (return (&/|list))))) + (|do [module-name &/get-module-name + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] + (return (&/|list)))) + +(defn ensure-undeclared-tags [module tags] + (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)] + tags-table (&&module/tags-by-module module) + ;; :let [_ (prn 'ensure-undeclared-tags/_1)] + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags) + ;; :let [_ (prn 'ensure-undeclared-tags/_2)] + ] + (return nil))) + +(defn analyse-declare-tags [tags] + (|do [;; :let [_ (prn 'analyse-declare-tags/_0)] + module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-tags/_1)] + _ (ensure-undeclared-tags module-name tags) + ;; :let [_ (prn 'analyse-declare-tags/_2)] + _ (&&module/declare-tags module-name tags) + ;; :let [_ (prn 'analyse-declare-tags/_3)] + ] + (return (&/|list)))) (defn analyse-import [analyse compile-module compile-token ?path] (|do [module-name &/get-module-name @@ -440,6 +494,6 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] + =value (analyse-1+ analyse ?value)] (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 35ae7e5b7..68554a019 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -18,14 +18,17 @@ ;; [Utils] (def ^:private $DEFS 0) -(def ^:private $ALIASES 1) -(def ^:private $IMPORTS 2) +(def ^:private $IMPORTS 1) +(def ^:private $ALIASES 2) +(def ^:private $tags 3) (def ^:private +init+ (&/R ;; "lux;defs" (&/|table) + ;; "lux;imports" + (&/|list) ;; "lux;module-aliases" (&/|table) - ;; "lux;imports" + ;; "lux;tags" (&/|list) )) @@ -235,12 +238,50 @@ (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) (defn create-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) (defn enter-module [name] + "(-> Text (Lux (,)))" (fn [state] (return* (->> state (&/update$ &/$MODULES #(&/|put name +init+ %)) (&/set$ &/$ENVS (&/|list (&/env name)))) nil))) + +(defn tags-by-module [module] + "(-> Text (Lux (List (, Text (, Int (List Text))))))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (return* state (&/get$ $tags =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) + +(defn declare-tags [module tag-names] + "(-> Text (List Text) (Lux (,)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$MODULES + (fn [=modules] + (&/|update module + #(&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags) table))) + (&/get$ $tags %) + (&/enumerate tag-names)) + %) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module))))) + +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Lux Error] Unknown module: " module))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index f690ef65f..73b2bb684 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -13,47 +13,53 @@ ;; [Tags] (defmacro deftags [prefix & names] - `(do ~@(for [name names] - `(def ~(symbol (str "$" name)) ~(str prefix name))))) + `(do ~@(for [[name idx] (map vector names (range (count names)))] + `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(def $Nil "lux;Nil") -(def $Cons "lux;Cons") +(deftags "" + "Nil" + "Cons") ;; Maybe -(def $None "lux;None") -(def $Some "lux;Some") +(deftags "" + "None" + "Some") ;; Meta -(def $Meta "lux;Meta") +(deftags "" + "Meta") ;; Either -(def $Left "lux;Left") -(def $Right "lux;Right") +(deftags "" + "Left" + "Right") ;; AST -(def $BoolS "lux;BoolS") -(def $IntS "lux;IntS") -(def $RealS "lux;RealS") -(def $CharS "lux;CharS") -(def $TextS "lux;TextS") -(def $SymbolS "lux;SymbolS") -(def $TagS "lux;TagS") -(def $FormS "lux;FormS") -(def $TupleS "lux;TupleS") -(def $RecordS "lux;RecordS") +(deftags "" + "BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS") ;; Type -(def $DataT "lux;DataT") -(def $TupleT "lux;TupleT") -(def $VariantT "lux;VariantT") -(def $RecordT "lux;RecordT") -(def $LambdaT "lux;LambdaT") -(def $VarT "lux;VarT") -(def $ExT "lux;ExT") -(def $BoundT "lux;BoundT") -(def $AppT "lux;AppT") -(def $AllT "lux;AllT") +(deftags "" + "DataT" + "TupleT" + "VariantT" + "RecordT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT") ;; [Fields] ;; Binding @@ -100,7 +106,7 @@ (defn T [& elems] (to-array elems)) -(defn V [tag value] +(defn V [^Long tag value] (to-array [tag value])) (defn R [& kvs] @@ -726,6 +732,7 @@ output))))) (defn show-ast [ast] + ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast ($Meta _ ($BoolS ?value)) (pr-str ?value) @@ -762,6 +769,10 @@ ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") + + _ + (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) + ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) )) (defn ident->text [ident] @@ -814,6 +825,7 @@ false)) (defn ^:private enumerate* [idx xs] + "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) (V $Cons (T (T idx x) @@ -824,6 +836,7 @@ )) (defn enumerate [xs] + "(All [a] (-> (List a) (List (, Int a))))" (enumerate* 0 xs)) (def modules @@ -836,3 +849,28 @@ (if test body (return nil))) + +(defn |at [idx xs] + "(All [a] (-> Int (List a) (Maybe a)))" + ;; (prn '|at idx (aget idx 0)) + (|case xs + ($Cons x xs*) + (cond (< idx 0) + (V $None nil) + + (= idx 0) + (V $Some x) + + :else ;; > 1 + (|at (dec idx) xs*)) + + ($Nil) + (V $None nil) + )) + +(defn normalize [ident] + "(-> Ident (Lux Ident))" + (|case ident + ["" name] (|do [module get-module-name] + (return (T module name))) + _ (return ident))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 490491bd0..7622e3002 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -61,13 +61,13 @@ (&a/$record ?elems) (&&lux/compile-record compile-expression ?type ?elems) - (&/$Local ?idx) + (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) (&a/$captured ?scope ?captured-id ?source) (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - (&/$Global ?owner-class ?name) + (&a/$var (&/$Global ?owner-class ?name)) (&&lux/compile-global compile-expression ?type ?owner-class ?name) (&a/$apply ?fn ?args) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 87327311c..9baefa21c 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -37,11 +37,13 @@ (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW ) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] + :let [_ (try (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) + (catch Exception e + (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] (return nil))) compile-int "java/lang/Long" "(J)V" long @@ -99,6 +101,7 @@ (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)))] @@ -148,6 +151,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -174,6 +178,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/type.clj b/src/lux/type.clj index 0a80d4fbc..553318daf 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,39 +23,73 @@ (def Unit (&/V &/$TupleT (&/|list))) (def $Void (&/V &/$VariantT (&/|list))) +(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) +(defn ^:private Bound$ [name] + (&/V &/$BoundT name)) +(defn ^:private Lambda$ [in out] + (&/V &/$LambdaT (&/T in out))) +(defn ^:private App$ [fun arg] + (&/V &/$AppT (&/T fun arg))) +(defn ^:private Tuple$ [members] + (&/V &/$TupleT members)) +(defn ^:private Variant$ [members] + (&/V &/$VariantT members)) +(defn ^:private Record$ [members] + (&/V &/$RecordT members)) + (def IO - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "IO" "a" - (&/V &/$LambdaT (&/T Unit (&/V &/$BoundT "a")))))) + (&/V &/$AllT (&/T empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a"))))) (def List - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;List" "a" - (&/V &/$VariantT (&/|list (&/T &/$Nil Unit) - (&/T &/$Cons (&/V &/$TupleT (&/|list (&/V &/$BoundT "a") - (&/V &/$AppT (&/T (&/V &/$BoundT "lux;List") - (&/V &/$BoundT "a"))))))))))) + (&/V &/$AllT (&/T empty-env "lux;List" "a" + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "lux;Maybe" "a" - (&/V &/$VariantT (&/|list (&/T &/$None Unit) - (&/T &/$Some (&/V &/$BoundT "a"))))))) + (&/V &/$AllT (&/T empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (let [Type (&/V &/$AppT (&/T (&/V &/$BoundT "Type") (&/V &/$BoundT "_"))) - TypeEnv (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Type)))) - TypePair (&/V &/$TupleT (&/|list Type Type))] - (&/V &/$AppT (&/T (&/V &/$AllT (&/T (&/V &/$Some (&/V &/$Nil nil)) "Type" "_" - (&/V &/$VariantT (&/|list (&/T &/$DataT Text) - (&/T &/$TupleT (&/V &/$AppT (&/T List Type))) - (&/T &/$VariantT TypeEnv) - (&/T &/$RecordT TypeEnv) - (&/T &/$LambdaT TypePair) - (&/T &/$BoundT Text) - (&/T &/$VarT Int) - (&/T &/$AllT (&/V &/$TupleT (&/|list (&/V &/$AppT (&/T Maybe TypeEnv)) Text Text Type))) - (&/T &/$AppT TypePair) - (&/T &/$ExT Int) - )))) - $Void)))) + (let [Type (App$ (Bound$ "Type") (Bound$ "_")) + TypeList (App$ List Type) + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] + (App$ (&/V &/$AllT (&/T empty-env "Type" "_" + (Variant$ (&/|list + ;; DataT + Text + ;; TupleT + (App$ List Type) + ;; VariantT + TypeList + ;; RecordT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + )))) + $Void))) (defn fAll [name arg body] (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) @@ -63,130 +97,187 @@ (def Bindings (fAll "lux;Bindings" "k" (fAll "" "v" - (&/V &/$RecordT (&/|list (&/T "lux;counter" Int) - (&/T "lux;mappings" (&/V &/$AppT (&/T List - (&/V &/$TupleT (&/|list (&/V &/$BoundT "k") - (&/V &/$BoundT "v"))))))))))) + (Record$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v"))))))))) (def Env - (let [bindings (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings (&/V &/$BoundT "k"))) - (&/V &/$BoundT "v")))] + (let [bindings (App$ (App$ Bindings (Bound$ "k")) + (Bound$ "v"))] (fAll "lux;Env" "k" (fAll "" "v" - (&/V &/$RecordT - (&/|list (&/T "lux;name" Text) - (&/T "lux;inner-closures" Int) - (&/T "lux;locals" bindings) - (&/T "lux;closure" bindings) - )))))) + (Record$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + )))))) (def Cursor - (&/V &/$TupleT (&/|list Text Int Int))) + (Tuple$ (&/|list Text Int Int))) (def Meta (fAll &/$Meta "m" (fAll "" "v" - (&/V &/$VariantT (&/|list (&/T &/$Meta (&/V &/$TupleT (&/|list (&/V &/$BoundT "m") - (&/V &/$BoundT "v"))))))))) + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v")))))))) -(def Ident (&/V &/$TupleT (&/|list Text Text))) +(def Ident (Tuple$ (&/|list Text Text))) (def AST* - (let [AST* (&/V &/$AppT (&/T (&/V &/$BoundT "w") - (&/V &/$AppT (&/T (&/V &/$BoundT "lux;AST'") - (&/V &/$BoundT "w"))))) - AST*List (&/V &/$AppT (&/T List AST*))] + (let [AST* (App$ (Bound$ "w") + (App$ (Bound$ "lux;AST'") + (Bound$ "w"))) + AST*List (App$ List AST*)] (fAll "lux;AST'" "w" - (&/V &/$VariantT (&/|list (&/T &/$BoolS Bool) - (&/T &/$IntS Int) - (&/T &/$RealS Real) - (&/T &/$CharS Char) - (&/T &/$TextS Text) - (&/T &/$SymbolS Ident) - (&/T &/$TagS Ident) - (&/T &/$FormS AST*List) - (&/T &/$TupleS AST*List) - (&/T &/$RecordS (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list AST* AST*)))))) - )))) + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + )))) (def AST - (let [w (&/V &/$AppT (&/T Meta Cursor))] - (&/V &/$AppT (&/T w (&/V &/$AppT (&/T AST* w)))))) + (let [w (App$ Meta Cursor)] + (App$ w (App$ AST* w)))) -(def ^:private ASTList (&/V &/$AppT (&/T List AST))) +(def ^:private ASTList (App$ List AST)) (def Either (fAll "lux;Either" "l" (fAll "" "r" - (&/V &/$VariantT (&/|list (&/T &/$Left (&/V &/$BoundT "l")) - (&/T &/$Right (&/V &/$BoundT "r"))))))) + (Variant$ (&/|list (&/T &/$Left (Bound$ "l")) + (&/T &/$Right (Bound$ "r"))))))) (def StateE (fAll "lux;StateE" "s" (fAll "" "a" - (&/V &/$LambdaT (&/T (&/V &/$BoundT "s") - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Either Text)) - (&/V &/$TupleT (&/|list (&/V &/$BoundT "s") - (&/V &/$BoundT "a")))))))))) + (Lambda$ (Bound$ "s") + (App$ (App$ Either Text) + (Tuple$ (&/|list (Bound$ "s") + (Bound$ "a")))))))) (def Reader - (&/V &/$AppT (&/T List - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Meta Cursor)) - Text))))) + (App$ List + (App$ (App$ Meta Cursor) + Text))) (def HostState - (&/V &/$RecordT - (&/|list (&/T "lux;writer" (&/V &/$DataT "org.objectweb.asm.ClassWriter")) - (&/T "lux;loader" (&/V &/$DataT "java.lang.ClassLoader")) - (&/T "lux;classes" (&/V &/$DataT "clojure.lang.Atom"))))) + (Record$ + (&/|list + ;; "lux;writer" + (&/V &/$DataT "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (&/V &/$DataT "java.lang.ClassLoader") + ;; "lux;classes" + (&/V &/$DataT "clojure.lang.Atom")))) (def DefData* (fAll "lux;DefData'" "" - (&/V &/$VariantT (&/|list (&/T "lux;TypeD" Type) - (&/T "lux;ValueD" (&/V &/$TupleT (&/|list Type Unit))) - (&/T "lux;MacroD" (&/V &/$BoundT "")) - (&/T "lux;AliasD" Ident))))) + (Variant$ (&/|list + ;; "lux;TypeD" + Type + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + )))) (def LuxVar - (&/V &/$VariantT (&/|list (&/T "lux;Local" Int) - (&/T "lux;Global" Ident)))) + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident))) (def $Module (fAll "lux;$Module" "Compiler" - (&/V &/$RecordT - (&/|list (&/T "lux;module-aliases" (&/V &/$AppT (&/T List (&/V &/$TupleT (&/|list Text Text))))) - (&/T "lux;defs" (&/V &/$AppT (&/T List (&/V &/$TupleT - (&/|list Text - (&/V &/$TupleT (&/|list Bool - (&/V &/$AppT (&/T DefData* - (&/V &/$LambdaT (&/T ASTList - (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE (&/V &/$BoundT "Compiler"))) - ASTList))))))))))))) - (&/T "lux;imports" (&/V &/$AppT (&/T List Text))))))) + (Record$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ + (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (List Ident))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List + Ident)))))) + )))) (def $Compiler - (&/V &/$AppT (&/T (fAll "lux;Compiler" "" - (&/V &/$RecordT - (&/|list (&/T "lux;source" Reader) - (&/T "lux;modules" (&/V &/$AppT (&/T List (&/V &/$TupleT - (&/|list Text - (&/V &/$AppT (&/T $Module (&/V &/$AppT (&/T (&/V &/$BoundT "lux;Compiler") (&/V &/$BoundT "")))))))))) - (&/T "lux;envs" (&/V &/$AppT (&/T List - (&/V &/$AppT (&/T (&/V &/$AppT (&/T Env Text)) - (&/V &/$TupleT (&/|list LuxVar Type))))))) - (&/T "lux;types" (&/V &/$AppT (&/T (&/V &/$AppT (&/T Bindings Int)) Type))) - (&/T "lux;host" HostState) - (&/T "lux;seed" Int) - (&/T "lux;eval?" Bool) - (&/T "lux;expected" Type) - (&/T "lux;cursor" Cursor) - ))) - $Void))) + (App$ (fAll "lux;Compiler" "" + (Record$ + (&/|list + ;; "lux;source" + Reader + ;; "lux;modules" + (App$ List (Tuple$ + (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;host" + HostState + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;expected" + Type + ;; "lux;cursor" + Cursor + ))) + $Void)) (def Macro - (&/V &/$LambdaT (&/T ASTList - (&/V &/$AppT (&/T (&/V &/$AppT (&/T StateE $Compiler)) - ASTList))))) + (Lambda$ ASTList + (App$ (App$ StateE $Compiler) + ASTList))) (defn bound? [id] (fn [state] @@ -297,30 +388,24 @@ (&/$LambdaT ?arg ?return) (|do [=arg (clean* ?tid ?arg) =return (clean* ?tid ?return)] - (return (&/V &/$LambdaT (&/T =arg =return)))) + (return (Lambda$ =arg =return))) (&/$AppT ?lambda ?param) (|do [=lambda (clean* ?tid ?lambda) =param (clean* ?tid ?param)] - (return (&/V &/$AppT (&/T =lambda =param)))) + (return (App$ =lambda =param))) (&/$TupleT ?members) (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (&/V &/$TupleT =members))) + (return (Tuple$ =members))) (&/$VariantT ?members) - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V &/$VariantT =members))) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) (&/$RecordT ?members) - (|do [=members (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?members)] - (return (&/V &/$RecordT =members))) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Record$ =members))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -380,23 +465,14 @@ (if (&/|empty? cases) "(|)" (str "(| " (->> cases - (&/|map (fn [kv] - (|case kv - [k (&/$TupleT (&/$Nil))] - (str "#" k) - - [k v] - (str "(#" k " " (show-type v) ")")))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) (&/$RecordT fields) (str "(& " (->> fields - (&/|map (fn [kv] - (|case kv - [k v] - (str "#" k " " (show-type v))))) + (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") @@ -429,7 +505,9 @@ [args body*]))] (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) - )) + + _ + (assert false (prn-str 'show-type (aget type 0))))) (defn type= [x y] (or (clojure.lang.Util/identical x y) @@ -438,24 +516,17 @@ (.equals ^Object xname yname) [(&/$TupleT xelems) (&/$TupleT yelems)] - (&/fold2 (fn [old x y] - (and old (type= x y))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xelems yelems) [(&/$VariantT xcases) (&/$VariantT ycases)] - (&/fold2 (fn [old xcase ycase] - (|let [[xname xtype] xcase - [yname ytype] ycase] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xcases ycases) [(&/$RecordT xslots) (&/$RecordT yslots)] - (&/fold2 (fn [old xslot yslot] - (|let [[xname xtype] xslot - [yname ytype] yslot] - (and old (.equals ^Object xname yname) (type= xtype ytype)))) + (&/fold2 (fn [old x y] (and old (type= x y))) true xslots yslots) @@ -522,23 +593,17 @@ (defn beta-reduce [env type] (|case type - (&/$VariantT ?cases) - (&/V &/$VariantT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?cases)) + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$RecordT ?fields) - (&/V &/$RecordT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (beta-reduce env v)))) - ?fields)) + (&/$RecordT ?members) + (Record$ (&/|map (partial beta-reduce env) ?members)) (&/$TupleT ?members) - (&/V &/$TupleT (&/|map (partial beta-reduce env) ?members)) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) (&/$AppT ?type-fn ?type-arg) - (&/V &/$AppT (&/T (beta-reduce env ?type-fn) (beta-reduce env ?type-arg))) + (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env @@ -549,7 +614,7 @@ type) (&/$LambdaT ?input ?output) - (&/V &/$LambdaT (&/T (beta-reduce env ?input) (beta-reduce env ?output))) + (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) (&/$BoundT ?name) (if-let [bound (&/|get ?name env)] @@ -660,13 +725,13 @@ (|case ((|do [F1 (deref ?eid)] (fn [state] (|case [((|do [F2 (deref ?aid)] - (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) state)] (&/$Right state* output) (return* state* output) (&/$Left _) - ((check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual) + ((check* class-loader fixpoints (App$ F1 A1) actual) state)))) state) (&/$Right state* output) @@ -674,7 +739,7 @@ (&/$Left _) (|case ((|do [F2 (deref ?aid)] - (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) @@ -691,7 +756,7 @@ [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (&/V &/$AppT (&/T F1 A1)) actual)) + (check* class-loader fixpoints (App$ F1 A1) actual)) state) (&/$Right state* output) (return* state* output) @@ -713,7 +778,7 @@ [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (&/V &/$AppT (&/T F2 A2)))) + (check* class-loader fixpoints expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) @@ -795,25 +860,17 @@ (return (&/T fixpoints* nil))) [(&/$VariantT e!cases) (&/$VariantT a!cases)] - (|do [fixpoints* (&/fold2% (fn [fp e!case a!case] - (|let [[e!name e!type] e!case - [a!name a!type] a!case] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) fixpoints e!cases a!cases)] (return (&/T fixpoints* nil))) [(&/$RecordT e!slots) (&/$RecordT a!slots)] - (|do [fixpoints* (&/fold2% (fn [fp e!slot a!slot] - (|let [[e!name e!type] e!slot - [a!name a!type] a!slot] - (if (.equals ^Object e!name a!name) - (|do [[fp* _] (check* class-loader fp e!type a!type)] - (return fp*)) - (fail (check-error expected actual))))) + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) fixpoints e!slots a!slots)] (return (&/T fixpoints* nil))) -- cgit v1.2.3 From 72a9ed29ca5518ca98658873f4616d5637db80af Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 10 Aug 2015 23:55:56 -0400 Subject: - Changing tags so they're actually indices (part 2). - Fixed some bugs. - Now pattern-matching on variants works with indices, rather than text tags. --- src/lux/analyser/base.clj | 2 +- src/lux/analyser/case.clj | 137 ++++++++++++++++-------------- src/lux/analyser/lux.clj | 15 ++-- src/lux/base.clj | 16 +++- src/lux/compiler/case.clj | 1 + src/lux/compiler/type.clj | 16 ++-- src/lux/type.clj | 212 ++++++++++++++++++++++++++-------------------- 7 files changed, 222 insertions(+), 177 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 218fc6dd9..58c01e642 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -148,4 +148,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/ident->text (&/T module* ?name)))))) + (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6cf070a52..6992c11a3 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -13,7 +13,8 @@ [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] - [env :as &env]))) + [env :as &env] + [module :as &module]))) ;; [Tags] (deftags "" @@ -66,6 +67,7 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) (|case type (&/$AllT _aenv _aname _aarg _abody) (&type/with-var @@ -80,45 +82,43 @@ (&type/clean* _avar _abody)))) type up)] - (return (&/V &/$TupleT (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - (&/$RecordT ?fields) - (|do [(&/$RecordT ?fields*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$RecordT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?fields*)))) - - (&/$VariantT ?cases) - (|do [(&/$VariantT ?cases*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$VariantT (&/|map (fn [kv] - (|let [[k v] kv] - (&/T k (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)))) - ?cases*)))) + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$RecordT ?members) + (|do [(&/$RecordT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$RecordT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) (&/$AppT ?tfun ?targ) (|do [=type (&type/apply-type ?tfun ?targ)] @@ -208,7 +208,8 @@ (|let [[sn sv] slot] (|case sn (&/$Meta _ (&/$TagS ?ident)) - (|do [=tag (&&/resolved-ident ?ident)] + (|do [=ident (&&/resolved-ident ?ident) + :let [=tag (&/ident->text =ident)]] (if-let [=slot-type (&/|get =tag ?slot-types)] (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] (return (&/T (&/|put =tag =test =tests) =kont))) @@ -225,23 +226,39 @@ (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [=tag (&&/resolved-ident ?ident) + (|do [;; :let [_ (println "#00")] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#01")] value-type* (adjust-type value-type) - case-type (&type/variant-case =tag value-type*) - [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) + ;; :let [_ (println "#02")] + idx (&module/tag-index =module =name) + ;; :let [_ (println "#03")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#04")] + [=test =kont] (analyse-pattern case-type unit kont) + ;; :let [_ (println "#05")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) - (|do [=tag (&&/resolved-ident ?ident) + (|do [;; :let [_ (println "#10" ?ident)] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#11")] value-type* (adjust-type value-type) - case-type (&type/variant-case =tag value-type*) + ;; :let [_ (println "#12" (&type/show-type value-type*))] + idx (&module/tag-index =module =name) + ;; :let [_ (println "#13")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont))] - (return (&/T (&/V $VariantTestAC (&/T =tag =test)) =kont))) + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + ;; :let [_ (println "#15")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] @@ -380,13 +397,10 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$RecordT ?fields) - (|do [totals (&/map% (fn [field] - (|let [[?tk ?tv] field] - (if-let [sub-struct (&/|get ?tk ?structs)] - (check-totality ?tv sub-struct) - (return false)))) - ?fields)] + (&/$RecordT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) _ @@ -397,13 +411,10 @@ (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$VariantT ?cases) - (|do [totals (&/map% (fn [case] - (|let [[?tk ?tv] case] - (if-let [sub-struct (&/|get ?tk ?structs)] - (check-totality ?tv sub-struct) - (return false)))) - ?cases)] + (&/$VariantT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) _ diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index ba4a173f0..e55d5fec8 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -158,7 +158,8 @@ =slots (&/map% (fn [kv] (|case kv [(&/$Meta _ (&/$TagS ?ident)) ?value] - (|do [?tag (&&/resolved-ident ?ident) + (|do [=ident (&&/resolved-ident ?ident) + :let [?tag (&/ident->text =ident)] slot-type (if-let [slot-type (&/|get ?tag types)] (return slot-type) (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) @@ -302,14 +303,14 @@ (|do [loader &/loader] (|let [[=fn-form =fn-type] =fn] (|case =fn-form - (&/$Global ?module ?name) - (|do [[[r-module r-name] $def] (&&module/find-def ?module ?name)] + (&&/$var (&/$Global ?module ?name)) + (|do [[real-name $def] (&&module/find-def ?module ?name)] (|case $def (&/$MacroD macro) - (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (str r-module ";" r-name))] + (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (prn 'MACRO-EXPAND|POST (str r-module ";" r-name))] - :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] + ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] + ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (or (= "<>" r-name) ;; ;; (= &&/$struct r-name) ;; ) @@ -318,7 +319,7 @@ ;; (&/fold str "") ;; (prn (str r-module ";" r-name))))] ] - (&/flat-map% (partial analyse exo-type) macro-expansion*)) + (&/flat-map% (partial analyse exo-type) macro-expansion)) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 73b2bb684..a700a30c8 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -281,13 +281,23 @@ ($Cons x xs*) (V $Cons (T x (|++ xs* ys))))) +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + (defn |map [f xs] (|case xs ($Nil) xs ($Cons x xs*) - (V $Cons (T (f x) (|map f xs*))))) + (V $Cons (T (f x) (|map f xs*))) + + _ + (assert false (prn-str '|map f (adt->text xs))) + )) (defn |empty? [xs] (|case xs @@ -770,8 +780,8 @@ ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") - _ - (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) + ;; _ + ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) )) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index e2cbe77a2..b108d463c 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -132,6 +132,7 @@ (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) (.visitLdcInsn ?tag) + (&&/wrap-long) (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") (.visitJumpInsn Opcodes/IFEQ $else) (.visitInsn Opcodes/DUP) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index e9d3014db..3d2ef5070 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -51,23 +51,19 @@ $Nil (&/|reverse ?members))) - (&/$VariantT ?cases) + (&/$VariantT ?members) (variant$ &/$VariantT (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) + (Cons$ (->analysis head) tail)) $Nil - (&/|reverse ?cases))) + (&/|reverse ?members))) - (&/$RecordT ?slots) + (&/$RecordT ?members) (variant$ &/$RecordT (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) + (Cons$ (->analysis head) tail)) $Nil - (&/|reverse ?slots))) + (&/|reverse ?members))) (&/$LambdaT ?input ?output) (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 553318daf..94b0fbc5e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -14,7 +14,18 @@ (declare show-type) -;; [Util] +;; [Utils] +(defn |list? [xs] + (|case xs + (&/$Nil) + true + + (&/$Cons x xs*) + (|list? xs*) + + _ + false)) + (def Bool (&/V &/$DataT "java.lang.Boolean")) (def Int (&/V &/$DataT "java.lang.Long")) (def Real (&/V &/$DataT "java.lang.Double")) @@ -24,79 +35,90 @@ (def $Void (&/V &/$VariantT (&/|list))) (def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(defn ^:private Bound$ [name] +(def ^:private no-env (&/V &/$None nil)) +(defn Data$ [name] + (&/V &/$DataT name)) +(defn Bound$ [name] (&/V &/$BoundT name)) -(defn ^:private Lambda$ [in out] +(defn Var$ [id] + (&/V &/$VarT id)) +(defn Lambda$ [in out] (&/V &/$LambdaT (&/T in out))) -(defn ^:private App$ [fun arg] +(defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) -(defn ^:private Tuple$ [members] + +(defn Tuple$ [members] + ;; (assert (|list? members)) (&/V &/$TupleT members)) -(defn ^:private Variant$ [members] + +(defn Variant$ [members] + ;; (assert (|list? members)) (&/V &/$VariantT members)) -(defn ^:private Record$ [members] + +(defn Record$ [members] + ;; (assert (|list? members)) (&/V &/$RecordT members)) +(defn All$ [env name arg body] + (&/V &/$AllT (&/T env name arg body))) + (def IO - (&/V &/$AllT (&/T empty-env "IO" "a" - (Lambda$ Unit (Bound$ "a"))))) + (All$ empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a")))) (def List - (&/V &/$AllT (&/T empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (All$ empty-env "lux;List" "a" + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + )))) (def Maybe - (&/V &/$AllT (&/T empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (All$ empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + )))) (def Type (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) TypeEnv (App$ List (Tuple$ (&/|list Text Type))) TypePair (Tuple$ (&/|list Type Type))] - (App$ (&/V &/$AllT (&/T empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; TupleT - (App$ List Type) - ;; VariantT - TypeList - ;; RecordT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - )))) + (App$ (All$ empty-env "Type" "_" + (Variant$ (&/|list + ;; DataT + Text + ;; TupleT + (App$ List Type) + ;; VariantT + TypeList + ;; RecordT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ))) $Void))) -(defn fAll [name arg body] - (&/V &/$AllT (&/T (&/V &/$None nil) name arg body))) - (def Bindings - (fAll "lux;Bindings" "k" - (fAll "" "v" + (All$ empty-env "lux;Bindings" "k" + (All$ no-env "" "v" (Record$ (&/|list ;; "lux;counter" Int @@ -108,8 +130,8 @@ (def Env (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] - (fAll "lux;Env" "k" - (fAll "" "v" + (All$ empty-env "lux;Env" "k" + (All$ no-env "" "v" (Record$ (&/|list ;; "lux;name" @@ -126,8 +148,8 @@ (Tuple$ (&/|list Text Int Int))) (def Meta - (fAll &/$Meta "m" - (fAll "" "v" + (All$ empty-env "lux;Meta" "m" + (All$ no-env "" "v" (Variant$ (&/|list ;; &/$Meta (Tuple$ (&/|list (Bound$ "m") @@ -140,7 +162,7 @@ (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] - (fAll "lux;AST'" "w" + (All$ empty-env "lux;AST'" "w" (Variant$ (&/|list ;; &/$BoolS Bool @@ -171,14 +193,17 @@ (def ^:private ASTList (App$ List AST)) (def Either - (fAll "lux;Either" "l" - (fAll "" "r" - (Variant$ (&/|list (&/T &/$Left (Bound$ "l")) - (&/T &/$Right (Bound$ "r"))))))) + (All$ empty-env "lux;Either" "l" + (All$ no-env "" "r" + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r")))))) (def StateE - (fAll "lux;StateE" "s" - (fAll "" "a" + (All$ empty-env "lux;StateE" "s" + (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) (Tuple$ (&/|list (Bound$ "s") @@ -193,14 +218,14 @@ (Record$ (&/|list ;; "lux;writer" - (&/V &/$DataT "org.objectweb.asm.ClassWriter") + (Data$ "org.objectweb.asm.ClassWriter") ;; "lux;loader" - (&/V &/$DataT "java.lang.ClassLoader") + (Data$ "java.lang.ClassLoader") ;; "lux;classes" - (&/V &/$DataT "clojure.lang.Atom")))) + (Data$ "clojure.lang.Atom")))) (def DefData* - (fAll "lux;DefData'" "" + (All$ empty-env "lux;DefData'" "" (Variant$ (&/|list ;; "lux;TypeD" Type @@ -220,20 +245,19 @@ Ident))) (def $Module - (fAll "lux;$Module" "Compiler" + (All$ empty-env "lux;$Module" "Compiler" (Record$ (&/|list ;; "lux;module-aliases" (App$ List (Tuple$ (&/|list Text Text))) ;; "lux;defs" (App$ List - (Tuple$ - (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) ;; "lux;imports" (App$ List Text) ;; "lux;tags" @@ -246,15 +270,14 @@ )))) (def $Compiler - (App$ (fAll "lux;Compiler" "" + (App$ (All$ empty-env "lux;Compiler" "" (Record$ (&/|list ;; "lux;source" Reader ;; "lux;modules" - (App$ List (Tuple$ - (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) ;; "lux;envs" (App$ List (App$ (App$ Env Text) @@ -368,13 +391,13 @@ (defn with-var [k] (|do [id create-var - output (k (&/V &/$VarT id)) + output (k (Var$ id)) _ (delete-var id)] (return output))) (defn with-vars [amount k] (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(&/V &/$VarT %) =vars)) + output (k (&/|map #(Var$ %) =vars)) _ (&/map% delete-var (&/|reverse =vars))] (return output))) @@ -419,7 +442,7 @@ ?env*)] (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] - (return (&/V &/$AllT (&/T =env ?name ?arg body*)))) + (return (All$ =env ?name ?arg body*))) _ (return type) @@ -608,7 +631,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (&/V &/$AllT (&/T (&/V &/$Some env) ?local-name ?local-arg ?local-def)) + (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -745,11 +768,11 @@ (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) + ((|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 (&/V &/$VarT ?eid) (&/V &/$VarT ?aid)) + ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] ;; (return (&/T fixpoints nil))) @@ -762,14 +785,14 @@ (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (&/V &/$VarT ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) [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 (&/V &/$VarT ?id) F2) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] @@ -784,14 +807,14 @@ (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (&/V &/$VarT ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) [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 (&/V &/$VarT ?id)) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] @@ -919,12 +942,15 @@ (return type) )) -(defn variant-case [case type] +(defn variant-case [tag type] (|case type (&/$VariantT ?cases) - (if-let [case-type (&/|get case ?cases)] + (|case (&/|at tag ?cases) + (&/$Some case-type) (return case-type) - (fail (str "[Type Error] Variant lacks case: " case " | " (show-type type)))) + + (&/$None) + (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) -- cgit v1.2.3 From 95e7125c36dfa04a29ac363f1fc7e4c59b505415 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 12 Aug 2015 00:14:53 -0400 Subject: - Changing tags so they're actually indices (part 3). - Added several bug fixes - Changed "Reader" to "Source" and "HostState" to "Host" in lux.lux - Set up indexing of records via tags. - Added lux.analyser.record namespace. - Removed some (now) unnecessary code for working with records. - Added the license (can't believe I missed it for so long.) --- src/lux/analyser/base.clj | 1 - src/lux/analyser/case.clj | 82 ++++++----------------- src/lux/analyser/env.clj | 24 +++---- src/lux/analyser/lambda.clj | 8 +-- src/lux/analyser/lux.clj | 56 +++++++--------- src/lux/analyser/module.clj | 97 +++++++++++++++------------ src/lux/analyser/record.clj | 158 ++++++++++++++++++++++++++++++++++++++++++++ src/lux/base.clj | 130 +++++++++++++++++++----------------- src/lux/compiler.clj | 5 +- src/lux/compiler/cache.clj | 2 +- src/lux/compiler/case.clj | 23 ------- src/lux/compiler/lux.clj | 21 ------ src/lux/reader.clj | 10 +-- src/lux/type.clj | 44 ++++++------ 14 files changed, 370 insertions(+), 291 deletions(-) create mode 100644 src/lux/analyser/record.clj (limited to 'src') diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 58c01e642..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -21,7 +21,6 @@ "text" "variant" "tuple" - "record" "apply" "case" "lambda" diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6992c11a3..34cbf8b48 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -14,7 +14,8 @@ [type :as &type]) (lux.analyser [base :as &&] [env :as &env] - [module :as &module]))) + [module :as &module] + [record :as &&record]))) ;; [Tags] (deftags "" @@ -25,7 +26,6 @@ "CharTotal" "TextTotal" "TupleTotal" - "RecordTotal" "VariantTotal" ) @@ -37,7 +37,6 @@ "CharTestAC" "TextTestAC" "TupleTestAC" - "RecordTestAC" "VariantTestAC" ) @@ -194,33 +193,25 @@ _ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - (&/$RecordS ?slots) - (|do [;; :let [_ (prn 'PRE (&type/show-type value-type))] + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] value-type* (adjust-type value-type) ;; :let [_ (prn 'POST (&type/show-type value-type*))] ;; value-type* (resolve-type value-type) ] (|case value-type* - (&/$RecordT ?slot-types) - (if (not (.equals ^Object (&/|length ?slot-types) (&/|length ?slots))) - (fail (str "[Analyser Error] Pattern-matching mismatch. Require record[" (&/|length ?slot-types) "]. Given record[" (&/|length ?slots) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* slot] - (|let [[sn sv] slot] - (|case sn - (&/$Meta _ (&/$TagS ?ident)) - (|do [=ident (&&/resolved-ident ?ident) - :let [=tag (&/ident->text =ident)]] - (if-let [=slot-type (&/|get =tag ?slot-types)] - (|do [[=test [=tests =kont]] (analyse-pattern =slot-type sv kont*)] - (return (&/T (&/|put =tag =test =tests) =kont))) - (fail (str "[Pattern-matching Error] Record-type lacks slot: " =tag)))) - - _ - (fail (str "[Pattern-matching Error] Record must use tags as slot-names: " (&/show-ast sn)))))) + (&/$RecordT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) (|do [=kont kont] - (return (&/T (&/|table) =kont))) - (&/|reverse ?slots))] - (return (&/T (&/V $RecordTestAC =tests) =kont)))) + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ (fail "[Pattern-matching Error] Record requires record-type."))) @@ -320,34 +311,6 @@ (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [($DefaultTotal total?) ($RecordTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (|let [[slot value] t] - (|do [struct* (merge-total (&/V $DefaultTotal total?) (&/T value ?body))] - (return (&/T slot struct*))))) - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V $RecordTotal (&/T total? structs)))) - - [($RecordTotal total? ?values) ($RecordTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [left right] - (|let [[lslot sub-struct] left - [rslot value]right] - (if (.equals ^Object lslot rslot) - (|do [sub-struct* (merge-total sub-struct (&/T value ?body))] - (return (&/T lslot sub-struct*))) - (fail "[Pattern-matching Error] Record slots mismatch.")))) - ?values - (->> ?tests - &/->seq - (sort compare-kv) - &/->list))] - (return (&/V $RecordTotal (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent record-size.")) - [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] (|do [sub-struct (merge-total (&/V $DefaultTotal total?) (&/T ?test ?body))] @@ -361,6 +324,7 @@ )))) (defn ^:private check-totality [value-type struct] + ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct ($BoolTotal ?total ?values) (return (or ?total @@ -389,14 +353,6 @@ ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - _ - (fail "[Pattern-maching Error] Tuple is not total.")))) - - ($RecordTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* (&/$RecordT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] (check-totality ?member sub-struct)) @@ -404,7 +360,7 @@ (return (&/fold #(and %1 %2) true totals))) _ - (fail "[Pattern-maching Error] Record is not total.")))) + (fail "[Pattern-maching Error] Tuple is not total.")))) ($VariantTotal ?total ?structs) (if ?total @@ -422,6 +378,10 @@ ($DefaultTotal ?total) (return ?total) + + ;; _ + ;; (assert false (prn-str 'check-totality (&type/show-type value-type) + ;; (&/adt->text struct))) )) ;; [Exports] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 614b38799..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,28 +15,28 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS)) - =return (body (&/update$ &/$ENVS + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs (fn [stack] - (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$LOCALS) (&/get$ &/$COUNTER))))] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [m] (&/|put name (&/T bound-unit type) m)))) + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) (&/|head stack)) (&/|tail stack)))) state))] (|case =return (&/$Right ?state ?value) - (return* (&/update$ &/$ENVS (fn [stack*] - (&/|cons (&/update$ &/$LOCALS #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS old-mappings)) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) (&/|head stack*)) (&/|tail stack*))) ?state) @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/get$ &/$ENVS) &/|head (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 91cf3443b..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -27,10 +27,10 @@ (defn close-over [scope name register frame] (|let [[_ register-type] register register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$CLOSURE) (&/get$ &/$COUNTER)) + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) register)) register-type)] - (&/T register* (&/update$ &/$CLOSURE #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [mps] (&/|put name register* mps)))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index e55d5fec8..449ef59c1 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,7 +18,8 @@ [lambda :as &&lambda] [case :as &&case] [env :as &&env] - [module :as &&module]))) + [module :as &&module] + [record :as &&record]))) (defn ^:private analyse-1+ [analyse ?token] (&type/with-var @@ -124,7 +125,7 @@ ;; (fn [$var] ;; (|do [exo-type** (&type/apply-type exo-type* $var)] ;; (analyse-variant analyse exo-type** ident ?values)))) - + ;; _ ;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) @@ -150,26 +151,14 @@ (return ?table) _ - (fail (str "[Analyser Error] The type of a record must be a record type:\n" - (&type/show-type exo-type*) - "\n"))) + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - =slots (&/map% (fn [kv] - (|case kv - [(&/$Meta _ (&/$TagS ?ident)) ?value] - (|do [=ident (&&/resolved-ident ?ident) - :let [?tag (&/ident->text =ident)] - slot-type (if-let [slot-type (&/|get ?tag types)] - (return slot-type) - (fail (str "[Analyser Error] Record type does not have slot: " ?tag))) - =value (&&/analyse-1 analyse slot-type ?value)] - (return (&/T ?tag =value))) - - _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - ?elems)] - (return (&/|list (&/T (&/V &&/$record =slots) (&/V &/$RecordT exo-type)))))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -193,9 +182,9 @@ (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/get$ &/$ENVS state) - no-binding? #(and (->> % (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|contains? name) not) - (->> % (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|contains? name) not)) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -204,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -235,21 +224,21 @@ (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$NAME %2) %1) - (&/|map #(&/get$ &/$NAME %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$LOCALS) (&/get$ &/$MAPPINGS) (&/|get name)) - (->> top-outer (&/get$ &/$CLOSURE) (&/get$ &/$MAPPINGS) (&/|get name))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/set$ &/$ENVS (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -311,13 +300,14 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "<>" r-name) + ;; :let [_ (when (or (= ":" (aget real-name 1)) + ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) ;; ) - ;; (->> (&/|map &/show-ast macro-expansion*) + ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") ;; (&/fold str "") - ;; (prn (str r-module ";" r-name))))] + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 68554a019..6cf25b738 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -11,23 +11,23 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return return* fail fail* |case]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] - [host :as &host]) - [lux.analyser.base :as &&])) + [host :as &host]))) ;; [Utils] -(def ^:private $DEFS 0) -(def ^:private $IMPORTS 1) -(def ^:private $ALIASES 2) -(def ^:private $tags 3) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags") (def ^:private +init+ - (&/R ;; "lux;defs" + (&/R ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" (&/|table) ;; "lux;imports" (&/|list) - ;; "lux;module-aliases" - (&/|table) ;; "lux;tags" (&/|list) )) @@ -37,24 +37,24 @@ "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $IMPORTS (partial &/|cons module) m)) + (fn [m] (&/update$ $imports (partial &/|cons module) m)) ms)) state) nil)))) (defn define [module name def-data type] (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T false def-data) %) m)) ms)))) @@ -66,8 +66,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -87,14 +87,14 @@ (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update a-module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) m)) ms)))) @@ -107,15 +107,15 @@ "(-> Text (Lux Bool))" (fn [state] (return* state - (->> state (&/get$ &/$MODULES) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/update$ &/$MODULES + (&/update$ &/$modules (fn [ms] (&/|update module - #(&/update$ $ALIASES + #(&/update$ $module-aliases (fn [aliases] (&/|put alias reference aliases)) %) @@ -125,7 +125,7 @@ (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/get$ &/$MODULES) (&/|get current-module) (&/get$ $ALIASES) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -133,9 +133,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $DEFS) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -158,7 +158,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -168,11 +168,11 @@ (.getField "_datum") (.get nil))]] (fn [state*] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [$modules] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) m)) $modules)) @@ -190,18 +190,18 @@ (defn export [module name] (fn [state] - (|case (&/get$ &/$ENVS state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/update$ &/$MODULES (fn [ms] + (&/update$ &/$modules (fn [ms] (&/|update module (fn [m] - (&/update$ $DEFS + (&/update$ $defs #(&/|put name (&/T true ?data) %) m)) ms)))) @@ -230,30 +230,30 @@ _ (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $DEFS))))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/get$ &/$MODULES) (&/|get module) (&/get$ $IMPORTS)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/update$ &/$MODULES #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/update$ &/$MODULES #(&/|put name +init+ %)) - (&/set$ &/$ENVS (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) (defn tags-by-module [module] "(-> Text (Lux (List (, Text (, Int (List Text))))))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (return* state (&/get$ $tags =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) @@ -261,9 +261,9 @@ (defn declare-tags [module tag-names] "(-> Text (List Text) (Lux (,)))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$MODULES + (return* (&/update$ &/$modules (fn [=modules] (&/|update module #(&/set$ $tags (&/fold (fn [table idx+tag-name] @@ -280,8 +280,17 @@ (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" (fn [state] - (if-let [=module (->> state (&/get$ &/$MODULES) (&/|get module))] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] (return* state (aget idx+tags 0)) - (fail* (str "[Lux Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Lux Error] Unknown module: " module))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj new file mode 100644 index 000000000..2b4b7e095 --- /dev/null +++ b/src/lux/analyser/record.clj @@ -0,0 +1,158 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.analyser.record + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [deftags |let |do return fail |case]]) + (lux.analyser [base :as &&] + [module :as &&module]))) + +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + +;; [Exports] +(defn order-record [pairs] + "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" + (|do [tag-group (|case pairs + (&/$Nil) + (return (&/|list)) + + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (|do [[module name] (&&/resolved-ident tag1)] + (&&module/tag-group module name)) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + =pairs (&/map% (fn [kv] + (|case kv + [(&/$Meta _ (&/$TagS k)) v] + (|do [=k (&&/resolved-ident k)] + (return (&/T (&/ident->text =k) v))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) + pairs)] + (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index a700a30c8..b8b7118f4 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -63,30 +63,34 @@ ;; [Fields] ;; Binding -(def $COUNTER 0) -(def $MAPPINGS 1) +(deftags "" + "counter" + "mappings") ;; Env -(def $CLOSURE 0) -(def $INNER-CLOSURES 1) -(def $LOCALS 2) -(def $NAME 3) +(deftags "" + "name" + "inner-closures" + "locals" + "closure") ;; Host -(def $CLASSES 0) -(def $LOADER 1) -(def $WRITER 2) +(deftags "" + "writer" + "loader" + "classes") ;; Compiler -(def $cursor 0) -(def $ENVS 1) -(def $EVAL? 2) -(def $EXPECTED 3) -(def $HOST 4) -(def $MODULES 5) -(def $SEED 6) -(def $SOURCE 7) -(def $TYPES 8) +(deftags "" + "source" + "cursor" + "modules" + "envs" + "types" + "expected" + "seed" + "eval?" + "host") ;; Vars (deftags "lux;" @@ -533,11 +537,11 @@ (def loader (fn [state] - (return* state (->> state (get$ $HOST) (get$ $LOADER))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state (get$ $HOST) (get$ $CLASSES))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ (R ;; "lux;counter" @@ -546,14 +550,14 @@ (|table))) (defn env [name] - (R ;; "lux;closure" - +init-bindings+ + (R ;; "lux;name" + name ;; "lux;inner-closures" 0 ;; "lux;locals" +init-bindings+ - ;; "lux;name" - name + ;; "lux;closure" + +init-bindings+ )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String @@ -576,32 +580,32 @@ (defn host [_] (let [store (atom {})] - (R ;; "lux;classes" - store + (R ;; "lux;writer" + (V $None nil) ;; "lux;loader" (memory-class-loader store) - ;; "lux;writer" - (V $None nil)))) + ;; "lux;classes" + store))) (defn init-state [_] - (R ;; "lux;cursor" + (R ;; "lux;source" + (V $None nil) + ;; "lux;cursor" (T "" -1 -1) + ;; "lux;modules" + (|table) ;; "lux;envs" (|list) - ;; "lux;eval?" - false + ;; "lux;types" + +init-bindings+ ;; "lux;expected" (V $VariantT (|list)) - ;; "lux;host" - (host nil) - ;; "lux;modules" - (|table) ;; "lux;seed" 0 - ;; "lux;source" - (V $None nil) - ;; "lux;types" - +init-bindings+ + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) )) (defn save-module [body] @@ -609,8 +613,8 @@ (|case (body state) ($Right state* output) (return* (->> state* - (set$ $ENVS (get$ $ENVS state)) - (set$ $SOURCE (get$ $SOURCE state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) ($Left msg) @@ -618,20 +622,20 @@ (defn with-eval [body] (fn [state] - (|case (body (set$ $EVAL? true state)) + (|case (body (set$ $eval? true state)) ($Right state* output) - (return* (set$ $EVAL? (get$ $EVAL? state) state*) output) + (return* (set$ $eval? (get$ $eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $EVAL? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $HOST) (get$ $WRITER))] + (let [writer* (->> state (get$ $host) (get$ $writer))] (|case writer* ($Some datum) (return* state datum) @@ -641,15 +645,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $ENVS state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $SEED state)] - (return* (set$ $SEED (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -671,19 +675,19 @@ (def get-module-name (fn [state] - (|case (|reverse (get$ $ENVS state)) + (|case (|reverse (get$ $envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state (get$ $NAME ?global))))) + (return* state (get$ $name ?global))))) (defn with-scope [name body] (fn [state] - (let [output (body (update$ $ENVS #(|cons (env name) %) state))] + (let [output (body (update$ $envs #(|cons (env name) %) state))] (|case output ($Right state* datum) - (return* (update$ $ENVS |tail state*) datum) + (return* (update$ $envs |tail state*) datum) _ output)))) @@ -693,23 +697,23 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $INNER-CLOSURES) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $ENVS #(|cons (update$ $INNER-CLOSURES inc (|head %)) + (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $ENVS) (|map #(get$ $NAME %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $HOST #(set$ $WRITER (V $Some writer) %) state))] + (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $HOST #(set$ $WRITER (->> state (get$ $HOST) (get$ $WRITER)) %) ?state) + (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) ?value) _ @@ -718,10 +722,10 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - (let [output (body (set$ $EXPECTED type state))] + (let [output (body (set$ $expected type state))] (|case output ($Right ?state ?value) - (return* (set$ $EXPECTED (get$ $EXPECTED state) ?state) + (return* (set$ $expected (get$ $expected state) ?state) ?value) _ @@ -852,7 +856,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $MODULES state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -884,3 +888,9 @@ ["" name] (|do [module get-module-name] (return (T module name))) _ (return ident))) + +(defn ident= [x y] + (|let [[xmodule xname] x + [ymodule yname] y] + (and (= xmodule ymodule) + (= xname yname)))) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 7622e3002..1814a97c0 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -58,9 +58,6 @@ (&a/$tuple ?elems) (&&lux/compile-tuple compile-expression ?type ?elems) - (&a/$record ?elems) - (&&lux/compile-record compile-expression ?type ?elems) - (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -426,7 +423,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$SOURCE (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 742ac69d8..85488553c 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$MODULES) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index b108d463c..4d8ac2190 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -102,29 +102,6 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$RecordTestAC ?slots) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx [_ test]] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?slots - &/->seq - (sort compare-kv) - &/->list - &/enumerate - &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$VariantTestAC ?tag ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 9baefa21c..e2b9f0e89 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -72,27 +72,6 @@ (&/|range num-elems) ?elems)] (return nil))) -(defn compile-record [compile *type* ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [elems* (->> ?elems - &/->seq - (sort #(compare (&/|first %1) (&/|first %2))) - &/->list) - num-elems (&/|length elems*) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx kv] - (|let [[k v] kv] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile v) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret)))) - (&/|range num-elems) elems*)] - (return nil))) - (defn compile-variant [compile *type* ?tag ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 6aa8cca6d..e0195658f 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -21,7 +21,7 @@ ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/get$ &/$SOURCE state) + (|case (&/get$ &/$source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/set$ &/$SOURCE more state) + (return* (&/set$ &/$source more state) output) ($Yes output line*) - (return* (&/set$ &/$SOURCE (&/|cons line* more) state) + (return* (&/set$ &/$source (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/get$ &/$SOURCE state)) + (|case (body (&/get$ &/$source state)) (&/$Right reader* match) - (return* (&/set$ &/$SOURCE reader* state) + (return* (&/set$ &/$source reader* state) match) (&/$Left msg) diff --git a/src/lux/type.clj b/src/lux/type.clj index 94b0fbc5e..92c986985 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -209,12 +209,12 @@ (Tuple$ (&/|list (Bound$ "s") (Bound$ "a")))))))) -(def Reader +(def Source (App$ List (App$ (App$ Meta Cursor) Text))) -(def HostState +(def Host (Record$ (&/|list ;; "lux;writer" @@ -274,7 +274,9 @@ (Record$ (&/|list ;; "lux;source" - Reader + Source + ;; "lux;cursor" + Cursor ;; "lux;modules" (App$ List (Tuple$ (&/|list Text (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) @@ -284,16 +286,14 @@ (Tuple$ (&/|list LuxVar Type)))) ;; "lux;types" (App$ (App$ Bindings Int) Type) - ;; "lux;host" - HostState + ;; "lux;expected" + Type ;; "lux;seed" Int ;; "lux;eval?" Bool - ;; "lux;expected" - Type - ;; "lux;cursor" - Cursor + ;; "lux;host" + Host ))) $Void)) @@ -304,7 +304,7 @@ (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -315,7 +315,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -326,26 +326,26 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$TYPES (fn [ts] (&/update$ &/$MAPPINGS #(&/|put id (&/V &/$Some type) %) + (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) ts)) state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$TYPES) (&/get$ &/$COUNTER))] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER inc) - (&/update$ &/$MAPPINGS (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))] + (return* (&/update$ &/$types #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -380,11 +380,11 @@ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$TYPES) (&/get$ &/$MAPPINGS)))] + (->> state (&/get$ &/$types) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$TYPES #(->> % - (&/update$ &/$COUNTER dec) - (&/set$ &/$MAPPINGS (&/|remove id mappings*))) + (return* (&/update$ &/$types #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) state)))) -- cgit v1.2.3 From e60e9ef86b8653726ac8d99310640122c9242098 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 12 Aug 2015 00:15:51 -0400 Subject: - Changing tags so they're actually indices (part 4). - Bug fixes and adjustments. --- src/lux/analyser/case.clj | 49 +++++++++++++++++++++++++++++++++-------------- src/lux/base.clj | 33 +++++++++++++++++++++++++++++++ src/lux/compiler/case.clj | 2 +- 3 files changed, 69 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 34cbf8b48..148e2822a 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -223,13 +223,14 @@ value-type* (adjust-type value-type) ;; :let [_ (println "#02")] idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) ;; :let [_ (println "#03")] case-type (&type/variant-case idx value-type*) ;; :let [_ (println "#04")] [=test =kont] (analyse-pattern case-type unit kont) ;; :let [_ (println "#05")] ] - (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) @@ -239,6 +240,7 @@ value-type* (adjust-type value-type) ;; :let [_ (println "#12" (&type/show-type value-type*))] idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) ;; :let [_ (println "#13")] case-type (&type/variant-case idx value-type*) ;; :let [_ (println "#14" (&type/show-type case-type))] @@ -249,7 +251,7 @@ (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) ;; :let [_ (println "#15")] ] - (return (&/T (&/V $VariantTestAC (&/T idx =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] @@ -311,21 +313,40 @@ (return (&/V $TupleTotal (&/T total? structs)))) (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - [($DefaultTotal total?) ($VariantTestAC ?tag ?test)] + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (&/V $DefaultTotal total?) - (&/T ?test ?body))] - (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct (&/|table)))))) - - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?test)] - (|do [sub-struct (merge-total (or (&/|get ?tag ?branches) - (&/V $DefaultTotal total?)) - (&/T ?test ?body))] - (return (&/V $VariantTotal (&/T total? (&/|put ?tag sub-struct ?branches))))) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) + + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) + (&/$Some sub) + sub + + (&/$None) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct ?branches) + (&/$Some list) + (return list) + + (&/$None) + (fail "[Pattern-matching Error] YOLO"))] + (return (&/V $VariantTotal (&/T total? structs)))) )))) (defn ^:private check-totality [value-type struct] ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct + ($DefaultTotal ?total) + (return ?total) + ($BoolTotal ?total ?values) (return (or ?total (= #{true false} (set (&/->seq ?values))))) @@ -369,6 +390,9 @@ (|case value-type* (&/$VariantT ?members) (|do [totals (&/map2% (fn [sub-struct ?member] + ;; (prn '$VariantTotal + ;; (&/adt->text sub-struct) + ;; (&type/show-type ?member)) (check-totality ?member sub-struct)) ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) @@ -376,9 +400,6 @@ _ (fail "[Pattern-maching Error] Variant is not total.")))) - ($DefaultTotal ?total) - (return ?total) - ;; _ ;; (assert false (prn-str 'check-totality (&type/show-type value-type) ;; (&/adt->text struct))) diff --git a/src/lux/base.clj b/src/lux/base.clj index b8b7118f4..89620ce97 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -116,6 +116,13 @@ (defn R [& kvs] (to-array kvs)) +;; Constructors +(def None$ (V $None nil)) +(defn Some$ [x] (V $Some x)) + +(def Nil$ (V $Nil nil)) +(defn Cons$ [h t] (V $Cons (T h t))) + (defn get$ [slot ^objects record] (aget record slot)) @@ -894,3 +901,29 @@ [ymodule yname] y] (and (= xmodule ymodule) (= xname yname)))) + +;; (defn |list-put [idx val xs] +;; (|case [idx xs] +;; [_ ($Nil)] +;; (V $None nil) + +;; [0 ($Cons x xs*)] +;; (V $Some (V $Cons (T val xs*))) + +;; [_ ($Cons x xs*)] +;; (|case (|list-put idx val xs*) +;; ($None) (V $None nil) +;; ($Some xs**) (V $Some (V $Cons (T x xs**)))))) + +(defn |list-put [idx val xs] + (|case xs + ($Nil) + (V $None nil) + + ($Cons x xs*) + (if (= idx 0) + (V $Some (V $Cons (T val xs*))) + (|case (|list-put (dec idx) val xs*) + ($None) (V $None nil) + ($Some xs**) (V $Some (V $Cons (T x xs**)))) + ))) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 4d8ac2190..dd3258059 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -102,7 +102,7 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$VariantTestAC ?tag ?test) + (&a-case/$VariantTestAC ?tag ?count ?test) (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) -- cgit v1.2.3 From 3d18954a2307b48c955f5bdd3790a92ffeb7284c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 13:28:07 -0400 Subject: Unified tuples & records. --- src/lux/analyser/case.clj | 27 +++------------------ src/lux/analyser/lux.clj | 2 +- src/lux/analyser/module.clj | 2 +- src/lux/base.clj | 14 ++++------- src/lux/compiler/type.clj | 7 ------ src/lux/type.clj | 57 ++++++++++----------------------------------- 6 files changed, 22 insertions(+), 87 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 148e2822a..395ae6976 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -89,21 +89,6 @@ up)) ?members*)))) - (&/$RecordT ?members) - (|do [(&/$RecordT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$RecordT (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - (&/$VariantT ?members) (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] @@ -128,8 +113,8 @@ (fail "##9##")))] (adjust-type* up type*)) - ;; [_] - ;; (assert false (aget type 0)) + _ + (assert false (prn 'adjust-type* (&type/show-type type))) )) (defn adjust-type [type] @@ -201,7 +186,7 @@ ;; value-type* (resolve-type value-type) ] (|case value-type* - (&/$RecordT ?member-types) + (&/$TupleT ?member-types) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) (|do [[=tests =kont] (&/fold (fn [kont* vm] @@ -374,12 +359,6 @@ ?structs ?members)] (return (&/fold #(and %1 %2) true totals))) - (&/$RecordT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) - _ (fail "[Pattern-maching Error] Tuple is not total.")))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 449ef59c1..79b804088 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -147,7 +147,7 @@ _ (&type/actual-type exo-type)) types (|case exo-type* - (&/$RecordT ?table) + (&/$TupleT ?table) (return ?table) _ diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 6cf25b738..08ad0b9a5 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -22,7 +22,7 @@ "imports" "tags") (def ^:private +init+ - (&/R ;; "lux;module-aliases" + (&/T ;; "lux;module-aliases" (&/|table) ;; "lux;defs" (&/|table) diff --git a/src/lux/base.clj b/src/lux/base.clj index 89620ce97..e39f76409 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -51,9 +51,8 @@ ;; Type (deftags "" "DataT" - "TupleT" "VariantT" - "RecordT" + "TupleT" "LambdaT" "BoundT" "VarT" @@ -113,9 +112,6 @@ (defn V [^Long tag value] (to-array [tag value])) -(defn R [& kvs] - (to-array kvs)) - ;; Constructors (def None$ (V $None nil)) (defn Some$ [x] (V $Some x)) @@ -551,13 +547,13 @@ (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ - (R ;; "lux;counter" + (T ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - (R ;; "lux;name" + (T ;; "lux;name" name ;; "lux;inner-closures" 0 @@ -587,7 +583,7 @@ (defn host [_] (let [store (atom {})] - (R ;; "lux;writer" + (T ;; "lux;writer" (V $None nil) ;; "lux;loader" (memory-class-loader store) @@ -595,7 +591,7 @@ store))) (defn init-state [_] - (R ;; "lux;source" + (T ;; "lux;source" (V $None nil) ;; "lux;cursor" (T "" -1 -1) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 3d2ef5070..a7c5176ad 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -58,13 +58,6 @@ $Nil (&/|reverse ?members))) - (&/$RecordT ?members) - (variant$ &/$RecordT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - (&/$LambdaT ?input ?output) (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 92c986985..2516fbc1d 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -55,10 +55,6 @@ ;; (assert (|list? members)) (&/V &/$VariantT members)) -(defn Record$ [members] - ;; (assert (|list? members)) - (&/V &/$RecordT members)) - (defn All$ [env name arg body] (&/V &/$AllT (&/T env name arg body))) @@ -95,11 +91,9 @@ (Variant$ (&/|list ;; DataT Text - ;; TupleT - (App$ List Type) ;; VariantT TypeList - ;; RecordT + ;; TupleT TypeList ;; LambdaT TypePair @@ -119,20 +113,20 @@ (def Bindings (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Record$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v"))))))))) + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v"))))))))) (def Env (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - (Record$ + (Tuple$ (&/|list ;; "lux;name" Text @@ -215,7 +209,7 @@ Text))) (def Host - (Record$ + (Tuple$ (&/|list ;; "lux;writer" (Data$ "org.objectweb.asm.ClassWriter") @@ -246,7 +240,7 @@ (def $Module (All$ empty-env "lux;$Module" "Compiler" - (Record$ + (Tuple$ (&/|list ;; "lux;module-aliases" (App$ List (Tuple$ (&/|list Text Text))) @@ -271,7 +265,7 @@ (def $Compiler (App$ (All$ empty-env "lux;Compiler" "" - (Record$ + (Tuple$ (&/|list ;; "lux;source" Source @@ -426,10 +420,6 @@ (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (Variant$ =members))) - (&/$RecordT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Record$ =members))) - (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env (&/$None) @@ -492,13 +482,6 @@ (&/|interpose " ") (&/fold str "")) ")")) - - (&/$RecordT fields) - (str "(& " (->> fields - (&/|map show-type) - (&/|interpose " ") - (&/fold str "")) ")") - (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) @@ -548,11 +531,6 @@ true xcases ycases) - [(&/$RecordT xslots) (&/$RecordT yslots)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xslots yslots) - [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) (type= xoutput youtput)) @@ -619,9 +597,6 @@ (&/$VariantT ?members) (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$RecordT ?members) - (Record$ (&/|map (partial beta-reduce env) ?members)) - (&/$TupleT ?members) (Tuple$ (&/|map (partial beta-reduce env) ?members)) @@ -890,14 +865,6 @@ e!cases a!cases)] (return (&/T fixpoints* nil))) - [(&/$RecordT e!slots) (&/$RecordT a!slots)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!slots a!slots)] - (return (&/T fixpoints* nil))) - [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) (return (&/T fixpoints nil)) -- cgit v1.2.3 From df3e4ba2df6462812174e69ea5c334a7edbbd5c7 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 16 Aug 2015 15:37:46 -0400 Subject: Introduced named types (#NamedT Ident Type). --- src/lux/analyser.clj | 2 +- src/lux/analyser/case.clj | 7 +- src/lux/analyser/lux.clj | 14 +- src/lux/base.clj | 25 +-- src/lux/type.clj | 389 ++++++++++++++++++++++++++-------------------- 5 files changed, 239 insertions(+), 198 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7810c415b..3b6a93005 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -532,7 +532,7 @@ (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) (catch Error e (prn e) - (assert false (prn-str 'analyse-basic-ast (&/show-ast ?token))))) + (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 395ae6976..483002adc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -113,6 +113,9 @@ (fail "##9##")))] (adjust-type* up type*)) + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + _ (assert false (prn 'adjust-type* (&type/show-type type))) )) @@ -202,7 +205,7 @@ (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [;; :let [_ (println "#00")] + (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] [=module =name] (&&/resolved-ident ?ident) ;; :let [_ (println "#01")] value-type* (adjust-type value-type) @@ -219,7 +222,7 @@ (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values)) - (|do [;; :let [_ (println "#10" ?ident)] + (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] [=module =name] (&&/resolved-ident ?ident) ;; :let [_ (println "#11")] value-type* (adjust-type value-type) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 79b804088..8a79e0494 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -401,6 +401,7 @@ ;; (when (= "PList/Dict" ?name) ;; (prn 'DEF ?name (&/show-ast ?value))) (|do [module-name &/get-module-name + ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))] ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) @@ -416,15 +417,20 @@ (return (&/|list))) _ - (do (println 'DEF (str module-name ";" ?name)) + (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - :let [_ (println 'DEF/COMPILED (str module-name ";" ?name))]] + :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) + _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [module-name &/get-module-name - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] + (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] + module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-macro ?name "1")] + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) + ;; :let [_ (prn 'analyse-declare-macro ?name "2")] + ] (return (&/|list)))) (defn ensure-undeclared-tags [module tags] diff --git a/src/lux/base.clj b/src/lux/base.clj index e39f76409..44875d1df 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -58,7 +58,8 @@ "VarT" "ExT" "AllT" - "AppT") + "AppT" + "NamedT") ;; [Fields] ;; Binding @@ -229,7 +230,7 @@ (defn |head [xs] (|case xs ($Nil) - (assert false) + (assert false (prn-str '|head)) ($Cons x _) x)) @@ -237,7 +238,7 @@ (defn |tail [xs] (|case xs ($Nil) - (assert false) + (assert false (prn-str '|tail)) ($Cons _ xs*) xs*)) @@ -787,9 +788,8 @@ ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") - ;; _ - ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) - ;; (assert false (prn-str 'show-ast (aget ast 0) (aget ast 1 1 0))) + _ + (assert false (prn-str 'show-ast (adt->text ast))) )) (defn ident->text [ident] @@ -898,19 +898,6 @@ (and (= xmodule ymodule) (= xname yname)))) -;; (defn |list-put [idx val xs] -;; (|case [idx xs] -;; [_ ($Nil)] -;; (V $None nil) - -;; [0 ($Cons x xs*)] -;; (V $Some (V $Cons (T val xs*))) - -;; [_ ($Cons x xs*)] -;; (|case (|list-put idx val xs*) -;; ($None) (V $None nil) -;; ($Some xs**) (V $Some (V $Cons (T x xs**)))))) - (defn |list-put [idx val xs] (|case xs ($Nil) diff --git a/src/lux/type.clj b/src/lux/type.clj index 2516fbc1d..e78b5616a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -26,14 +26,6 @@ _ false)) -(def Bool (&/V &/$DataT "java.lang.Boolean")) -(def Int (&/V &/$DataT "java.lang.Long")) -(def Real (&/V &/$DataT "java.lang.Double")) -(def Char (&/V &/$DataT "java.lang.Character")) -(def Text (&/V &/$DataT "java.lang.String")) -(def Unit (&/V &/$TupleT (&/|list))) -(def $Void (&/V &/$VariantT (&/|list))) - (def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) (def ^:private no-env (&/V &/$None nil)) (defn Data$ [name] @@ -46,154 +38,174 @@ (&/V &/$LambdaT (&/T in out))) (defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) - (defn Tuple$ [members] ;; (assert (|list? members)) (&/V &/$TupleT members)) - (defn Variant$ [members] ;; (assert (|list? members)) (&/V &/$VariantT members)) - (defn All$ [env name arg body] (&/V &/$AllT (&/T env name arg body))) +(defn Named$ [name type] + (&/V &/$NamedT (&/T name type))) + + +(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) +(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) +(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) +(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) +(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) +(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO - (All$ empty-env "IO" "a" - (Lambda$ Unit (Bound$ "a")))) + (Named$ (&/T "lux/data" "IO") + (All$ empty-env "IO" "a" + (Lambda$ Unit (Bound$ "a"))))) (def List - (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - )))) + (Named$ (&/T "lux" "List") + (All$ empty-env "lux;List" "a" + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - )))) + (Named$ (&/T "lux" "Maybe") + (All$ empty-env "lux;Maybe" "a" + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (let [Type (App$ (Bound$ "Type") (Bound$ "_")) - TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) - TypePair (Tuple$ (&/|list Type Type))] - (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - ))) - $Void))) + (Named$ (&/T "lux" "Type") + (let [Type (App$ (Bound$ "Type") (Bound$ "_")) + TypeList (App$ List Type) + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] + (App$ (All$ empty-env "Type" "_" + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) + $Void)))) (def Bindings - (All$ empty-env "lux;Bindings" "k" - (All$ no-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v"))))))))) + (Named$ (&/T "lux" "Bindings") + (All$ empty-env "lux;Bindings" "k" + (All$ no-env "" "v" + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v")))))))))) (def Env - (let [bindings (App$ (App$ Bindings (Bound$ "k")) - (Bound$ "v"))] - (All$ empty-env "lux;Env" "k" - (All$ no-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - )))))) + (Named$ (&/T "lux" "Env") + (let [bindings (App$ (App$ Bindings (Bound$ "k")) + (Bound$ "v"))] + (All$ empty-env "lux;Env" "k" + (All$ no-env "" "v" + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor - (Tuple$ (&/|list Text Int Int))) + (Named$ (&/T "lux" "Cursor") + (Tuple$ (&/|list Text Int Int)))) (def Meta - (All$ empty-env "lux;Meta" "m" - (All$ no-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v")))))))) - -(def Ident (Tuple$ (&/|list Text Text))) + (Named$ (&/T "lux" "Meta") + (All$ empty-env "lux;Meta" "m" + (All$ no-env "" "v" + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v"))))))))) (def AST* - (let [AST* (App$ (Bound$ "w") - (App$ (Bound$ "lux;AST'") - (Bound$ "w"))) - AST*List (App$ List AST*)] - (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - )))) + (Named$ (&/T "lux" "AST'") + (let [AST* (App$ (Bound$ "w") + (App$ (Bound$ "lux;AST'") + (Bound$ "w"))) + AST*List (App$ List AST*)] + (All$ empty-env "lux;AST'" "w" + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST - (let [w (App$ Meta Cursor)] - (App$ w (App$ AST* w)))) + (Named$ (&/T "lux" "AST") + (let [w (App$ Meta Cursor)] + (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (All$ empty-env "lux;Either" "l" - (All$ no-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r")))))) + (Named$ (&/T "lux" "Either") + (All$ empty-env "lux;Either" "l" + (All$ no-env "" "r" + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r"))))))) (def StateE (All$ empty-env "lux;StateE" "s" @@ -204,19 +216,21 @@ (Bound$ "a")))))))) (def Source - (App$ List - (App$ (App$ Meta Cursor) - Text))) + (Named$ (&/T "lux" "Source") + (App$ List + (App$ (App$ Meta Cursor) + Text)))) (def Host - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom")))) + (Named$ (&/T "lux" "Host") + (Tuple$ + (&/|list + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom"))))) (def DefData* (All$ empty-env "lux;DefData'" "" @@ -232,11 +246,12 @@ )))) (def LuxVar - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident))) + (Named$ (&/T "lux" "LuxVar") + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident)))) (def $Module (All$ empty-env "lux;$Module" "Compiler" @@ -264,37 +279,39 @@ )))) (def $Compiler - (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) - $Void)) + (Named$ (&/T "lux" "Compiler") + (App$ (All$ empty-env "lux;Compiler" "" + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) + $Void))) (def Macro - (Lambda$ ASTList - (App$ (App$ StateE $Compiler) - ASTList))) + (Named$ (&/T "lux" "Macro") + (Lambda$ ASTList + (App$ (App$ StateE $Compiler) + ASTList)))) (defn bound? [id] (fn [state] @@ -512,8 +529,11 @@ (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) ?name) + (&/$NamedT ?name ?type) + (&/ident->text ?name) + _ - (assert false (prn-str 'show-type (aget type 0))))) + (assert false (prn-str 'show-type (&/adt->text type))))) (defn type= [x y] (or (clojure.lang.Util/identical x y) @@ -566,6 +586,12 @@ (type= xbody ybody) ) + [(&/$NamedT ?xname ?xtype) _] + (type= ?xtype y) + + [_ (&/$NamedT ?yname ?ytype)] + (type= x ?ytype) + [_ _] false )] @@ -640,9 +666,12 @@ (&/$AppT F A) (|do [type-fn* (apply-type F A)] (apply-type type-fn* param)) + + (&/$NamedT ?name ?type) + (apply-type ?type param) _ - (fail (str "[Type System] Not type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -805,7 +834,7 @@ (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) - (assert false))] + (assert false (prn-str 'check* '[(&/$AppT F A) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? @@ -870,6 +899,12 @@ (return (&/T fixpoints nil)) (fail (check-error expected actual))) + [(&/$NamedT ?ename ?etype) _] + (check* class-loader fixpoints ?etype actual) + + [_ (&/$NamedT ?aname ?atype)] + (check* class-loader fixpoints expected ?atype) + [_ _] (fail (check-error expected actual)) ))) @@ -892,11 +927,15 @@ =return (apply-lambda func* param)] (clean $var =return)))) + (&/$NamedT ?name ?type) + (apply-lambda ?type param) + _ (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] + "(-> Type (Lux Type))" (|case type (&/$AppT ?all ?param) (|do [type* (apply-type ?all ?param)] @@ -904,6 +943,9 @@ (&/$VarT ?id) (deref ?id) + + (&/$NamedT ?name ?type) + (actual-type ?type) _ (return type) @@ -911,6 +953,9 @@ (defn variant-case [tag type] (|case type + (&/$NamedT ?name ?type) + (variant-case tag ?type) + (&/$VariantT ?cases) (|case (&/|at tag ?cases) (&/$Some case-type) -- cgit v1.2.3 From 1b48e9e06cb90187b28381bcadbeeba60806964d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 17 Aug 2015 16:59:18 -0400 Subject: - Finished turning tags into indices. - As an unexpected bonus, the compiler has become 2.5x faster. - Fixed some minor bugs. - Tag declarations now include associated types. - Tag declarations info is now stored twice (one from the perspective of tags, the other from the perspective of types). - Changed the named of the "types" member of the Compiler type, to "type-vars" to avoid collision with the "types" member of the Module type. --- src/lux/analyser.clj | 5 ++- src/lux/analyser/lux.clj | 43 +++++++------------- src/lux/analyser/module.clj | 97 ++++++++++++++++++++++++++++++++------------- src/lux/base.clj | 2 +- src/lux/compiler/host.clj | 8 +++- src/lux/compiler/type.clj | 4 ++ src/lux/host.clj | 7 ++++ src/lux/parser.clj | 4 +- src/lux/reader.clj | 14 +++---- src/lux/type.clj | 54 ++++++++++++++++--------- 10 files changed, 149 insertions(+), 89 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3b6a93005..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -442,9 +442,10 @@ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Nil)))) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] - (&&lux/analyse-declare-tags tags*)) + (&&lux/analyse-declare-tags tags* type-name)) (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) (&/$Cons (&/$Meta _ (&/$TextS ?path)) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 8a79e0494..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -300,8 +300,8 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= ":" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) @@ -409,7 +409,7 @@ (analyse-1+ analyse ?value)) =value-type (&&/expr-type =value)] (|case =value - [(&/$Global ?r-module ?r-name) _] + [(&&/$var (&/$Global ?r-module ?r-name)) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] @@ -418,10 +418,10 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - _ (println 'DEF (str module-name ";" ?name))]] - (return (&/|list))))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) + _ (println 'DEF (str module-name ";" ?name))]] + (return (&/|list))))) )))) (defn analyse-declare-macro [analyse compile-token ?name] @@ -433,28 +433,13 @@ ] (return (&/|list)))) -(defn ensure-undeclared-tags [module tags] - (|do [;; :let [_ (prn 'ensure-undeclared-tags/_0)] - tags-table (&&module/tags-by-module module) - ;; :let [_ (prn 'ensure-undeclared-tags/_1)] - _ (&/map% (fn [tag] - (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) - (return nil))) - tags) - ;; :let [_ (prn 'ensure-undeclared-tags/_2)] - ] - (return nil))) - -(defn analyse-declare-tags [tags] - (|do [;; :let [_ (prn 'analyse-declare-tags/_0)] - module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags/_1)] - _ (ensure-undeclared-tags module-name tags) - ;; :let [_ (prn 'analyse-declare-tags/_2)] - _ (&&module/declare-tags module-name tags) - ;; :let [_ (prn 'analyse-declare-tags/_3)] - ] +(defn analyse-declare-tags [tags type-name] + (|do [module-name &/get-module-name + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] + [_ def-data] (&&module/find-def module-name type-name) + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + def-type (&&module/ensure-type-def def-data) + _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) (defn analyse-import [analyse compile-module compile-token ?path] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 08ad0b9a5..5190e2dcf 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -8,7 +8,8 @@ (ns lux.analyser.module (:refer-clojure :exclude [alias]) - (:require [clojure.string :as string] + (:require (clojure [string :as string] + [template :refer [do-template]]) clojure.core.match clojure.core.match.array (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] @@ -20,7 +21,8 @@ "module-aliases" "defs" "imports" - "tags") + "tags" + "types") (def ^:private +init+ (&/T ;; "lux;module-aliases" (&/|table) @@ -29,7 +31,9 @@ ;; "lux;imports" (&/|list) ;; "lux;tags" - (&/|list) + (&/|table) + ;; "lux;types" + (&/|table) )) ;; [Exports] @@ -46,6 +50,7 @@ nil)))) (defn define [module name def-data type] + ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) @@ -151,6 +156,15 @@ (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) +(defn ensure-type-def [def-data] + "(-> DefData (Lux Type))" + (|case def-data + (&/$TypeD type) + (return type) + + _ + (fail (str "[Analyser Error] Not a type definition: " (&/adt->text def-data))))) + (defn defined? [module name] (&/try-all% (&/|list (|do [_ (find-def module name)] (return true)) @@ -250,32 +264,59 @@ (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(defn tags-by-module [module] - "(-> Text (Lux (List (, Text (, Int (List Text))))))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ $tags =module)) - (fail* (str "[Lux Error] Unknown module: " module))) - )) +(do-template [ ] + (defn [module] + + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ =module)) + (fail* (str "[Lux Error] Unknown module: " module))) + )) -(defn declare-tags [module tag-names] - "(-> Text (List Text) (Lux (,)))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T idx tags) table))) - (&/get$ $tags %) - (&/enumerate tag-names)) - %) - =modules)) - state) - nil)) - (fail* (str "[Lux Error] Unknown module: " module))))) + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + ) + +(defn ensure-undeclared-tags [module tags] + (|do [tags-table (tags-by-module module) + _ (&/map% (fn [tag] + (if (&/|get tag tags-table) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (return nil))) + tags)] + (return nil))) + +(defn ensure-undeclared-type [module name] + (|do [types-table (types-by-module module) + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + (return nil))) + +(defn declare-tags [module tag-names type] + "(-> Text (List Text) Type (Lux (,)))" + (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))] + _ (ensure-undeclared-tags module tag-names) + type-name (&type/type-name type) + :let [[_module _name] type-name] + _ (&/assert! (= module _module) + (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) + _ (ensure-undeclared-type _module _name)] + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) + nil)) + (fail* (str "[Lux Error] Unknown module: " module)))))) (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" diff --git a/src/lux/base.clj b/src/lux/base.clj index 44875d1df..84b09bcac 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -86,7 +86,7 @@ "cursor" "modules" "envs" - "types" + "type-vars" "expected" "seed" "eval?" diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 78b9e72f6..0ae4ce2da 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -80,7 +80,13 @@ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) (&/$DataT _) - nil) + nil + + (&/$NamedT ?name ?type) + (prepare-return! *writer* ?type) + + _ + (assert false (str 'prepare-return! " " (&type/show-type *type*)))) *writer*)) ;; [Resources] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index a7c5176ad..7e2bc6961 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -84,4 +84,8 @@ (&/$AppT ?fun ?arg) (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + + (&/$NamedT [?module ?name] ?type) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) + (->analysis ?type)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 8ffe77b96..dfd4df23d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -68,6 +68,7 @@ )) (defn ->java-sig [^objects type] + "(-> Type Text)" (|case type (&/$DataT ?name) (->type-signature ?name) @@ -77,6 +78,12 @@ (&/$TupleT (&/$Nil)) "V" + + (&/$NamedT ?name ?type) + (->java-sig ?type) + + _ + (assert false (str '->java-sig " " (&type/show-type type))) )) (do-template [ ] diff --git a/src/lux/parser.clj b/src/lux/parser.clj index a8b2cfc16..eaa22db20 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -76,10 +76,10 @@ (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Integer/parseInt ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Float/parseFloat ?value)))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) ($Char ^String ?value) (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e0195658f..e3f95b5f9 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -26,7 +26,7 @@ (fail* "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] line] - more) + more) (|case (body file-name line-num column-num line) ($No msg) (fail* msg) @@ -87,7 +87,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) match)) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] @@ -100,7 +100,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] @@ -113,7 +113,7 @@ (&/V &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] - reader**) + reader**) (if-let [^String match (do ;; (prn 'read-regex+ regex line) (re-find1! regex column-num line))] (let [match-length (.length match) @@ -121,8 +121,8 @@ (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) - reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) + reader**) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] @@ -135,7 +135,7 @@ (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) text)) (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) + (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") diff --git a/src/lux/type.clj b/src/lux/type.clj index e78b5616a..9f3adb036 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -235,10 +235,10 @@ (def DefData* (All$ empty-env "lux;DefData'" "" (Variant$ (&/|list - ;; "lux;TypeD" - Type ;; "lux;ValueD" (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type ;; "lux;MacroD" (Bound$ "") ;; "lux;AliasD" @@ -270,12 +270,18 @@ ;; "lux;imports" (App$ List Text) ;; "lux;tags" - ;; (List (, Text (List Ident))) + ;; (List (, Text (, Int (List Ident) Type))) (App$ List (Tuple$ (&/|list Text (Tuple$ (&/|list Int - (App$ List - Ident)))))) + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) )))) (def $Compiler @@ -315,7 +321,7 @@ (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -326,7 +332,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -337,26 +343,26 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$types) (&/get$ &/$mappings) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$types (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) - ts)) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$types) (&/get$ &/$mappings) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$types) (&/get$ &/$counter))] - (return* (&/update$ &/$types #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) state) id)))) @@ -391,11 +397,11 @@ (|do [?type** (clean* id ?type*)] (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/get$ &/$types) (&/get$ &/$mappings)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$types #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) state)))) @@ -966,3 +972,13 @@ _ (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + +(defn type-name [type] + "(-> Type (Lux Ident))" + (|case type + (&/$NamedT name _) + (return name) + + _ + (fail (str "[Type Error] Type is not named: " (show-type type))) + )) -- cgit v1.2.3 From b059fa2a5efb4cab8b62d895e8c9adf1434bde2d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 18 Aug 2015 23:30:50 -0400 Subject: - Tags data is now stored in the cache. - Fixed a caching bug wherein imports data wasn't being installed when loading cached modules. - Fixed a compilation error regarding tags in compile-program. - Refactored the names of fields inside the generated classes, and also the named of the "module class". - Refactored some of the details of how module info is stored inside the fields of module classes. --- src/lux/analyser/module.clj | 30 ++++++++++++++++++++++++++-- src/lux/base.clj | 48 +++++++++++++++++++++++++++++++++------------ src/lux/compiler.clj | 37 +++++++++++++++++++++++----------- src/lux/compiler/base.clj | 10 ++++++++++ src/lux/compiler/cache.clj | 39 ++++++++++++++++++++++++++---------- src/lux/compiler/host.clj | 2 ++ src/lux/compiler/lux.clj | 19 +++++++++--------- src/lux/compiler/module.clj | 28 ++++++++++++++++++++++++++ 8 files changed, 168 insertions(+), 45 deletions(-) create mode 100644 src/lux/compiler/module.clj (limited to 'src') diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 5190e2dcf..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -49,6 +49,18 @@ state) nil)))) +(defn set-imports [imports] + "(-> (List Text) (Lux (,)))" + (|do [current-module &/get-module-name] + (fn [state] + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) + nil)))) + (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] @@ -89,6 +101,20 @@ (fail* (str "[Analyser Error] Unknown definition: " (str module ";" name)))) (fail* (str "[Analyser Error] Unknown module: " module))))) +(defn type-def [module name] + "(-> Text Text (Lux Type))" + (fn [state] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|case $def + [_ (&/$TypeD _type)] + (return* state _type) + + _ + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown module: " module))))) + (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] @@ -179,7 +205,7 @@ ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) - (.getField "_datum") + (.getField &/datum-field) (.get nil))]] (fn [state*] (return* (&/update$ &/$modules @@ -293,7 +319,7 @@ (defn declare-tags [module tag-names type] "(-> Text (List Text) Type (Lux (,)))" - (|do [;; :let [_ (prn 'declare-tags (&/->seq tag-names) (&/adt->text type))] + (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))] _ (ensure-undeclared-tags module tag-names) type-name (&type/type-name type) :let [[_module _name] type-name] diff --git a/src/lux/base.clj b/src/lux/base.clj index 84b09bcac..6247524af 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -61,7 +61,18 @@ "AppT" "NamedT") -;; [Fields] +;; Vars +(deftags "lux;" + "Local" + "Global") + +;; Definitions +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") + ;; Binding (deftags "" "counter" @@ -92,19 +103,18 @@ "eval?" "host") -;; Vars -(deftags "lux;" - "Local" - "Global") - -;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") - ;; [Exports] +(def datum-field "_datum") +(def meta-field "_meta") +(def name-field "_name") +(def hash-field "_hash") +(def compiler-field "_compiler") +(def imports-field "_imports") +(def defs-field "_defs") +(def eval-field "_eval") +(def tags-field "_tags") +(def module-class-name "_") + (def +name-separator+ ";") (defn T [& elems] @@ -686,6 +696,18 @@ ($Cons ?global _) (return* state (get$ $name ?global))))) +(defn find-module [name] + "(-> Text (Lux (Module Compiler)))" + (fn [state] + (if-let [module (|get name (get$ $modules state))] + (return* state module) + (fail* (str "Unknown module: " name))))) + +(def get-current-module + "(Lux (Module Compiler))" + (|do [module-name get-module-name] + (find-module module-name))) + (defn with-scope [name body] (fn [state] (let [output (body (update$ $envs #(|cons (env name) %) state))] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 1814a97c0..79d2c84f8 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -30,6 +30,7 @@ [case :as &&case] [lambda :as &&lambda] [package :as &&package] + [module :as &&module] [io :as &&io])) (:import (org.objectweb.asm Opcodes Label @@ -378,14 +379,14 @@ =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_eval" "Ljava/lang/Object;" nil nil) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) (doto (.visitEnd))))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] _ (compile-expression expr) :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name "_eval" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/PUTSTATIC class-name &/eval-field "Ljava/lang/Object;") (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) (.visitEnd))]] @@ -395,7 +396,7 @@ _ (&&/save-class! (str id) bytecode) loader &/loader] (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) - (.getField "_eval") + (.getField &/eval-field) (.get nil) return)))) @@ -414,9 +415,9 @@ :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_hash" "I" nil file-hash) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/hash-field "I" nil file-hash) .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_compiler" "Ljava/lang/String;" nil &&/version) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) .visitEnd)) ;; _ (prn 'compile-module name =class) ]] @@ -427,22 +428,36 @@ (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports + tag-groups &&module/tag-groups :let [_ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_defs" "Ljava/lang/String;" nil + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/defs-field "Ljava/lang/String;" nil (->> defs (&/|map (fn [_def] (|let [[?exported ?name ?ann] _def] - (str (if ?exported "1" "0") " " ?name " " ?ann)))) - (&/|interpose "\t") + (str (if ?exported &&/exported-true &&/exported-false) + &&/exported-separator + ?name + &&/exported-separator + ?ann)))) + (&/|interpose &&/def-separator) (&/fold str ""))) .visitEnd) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) "_imports" "Ljava/lang/String;" nil - (->> imports (&/|interpose "\t") (&/fold str ""))) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/imports-field "Ljava/lang/String;" nil + (->> imports (&/|interpose &&/import-separator) (&/fold str ""))) + .visitEnd) + (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/tags-field "Ljava/lang/String;" nil + (->> tag-groups + (&/|map (fn [group] + (|let [[type tags] group] + (->> tags (&/|interpose &&/tag-separator) (&/fold str "") + (str type &&/type-separator))))) + (&/|interpose &&/tag-group-separator) + (&/fold str ""))) .visitEnd) (.visitEnd)) ;; _ (prn 'CLOSED name =class) ]] - (&&/save-class! "_" (.toByteArray =class))) + (&&/save-class! &/module-class-name (.toByteArray =class))) ?state) (&/$Left ?message) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 03fae9fec..1e5f3a024 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -33,11 +33,21 @@ (def ^String output-package (str output-dir "/program.jar")) (def ^String function-class "lux/Function") +;; Formats (def ^String local-prefix "l") (def ^String partial-prefix "p") (def ^String closure-prefix "c") (def ^String apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;") +(def exported-true "1") +(def exported-false "0") +(def exported-separator " ") +(def def-separator "\t") +(def import-separator "\t") +(def tag-separator " ") +(def type-separator "\t") +(def tag-group-separator "\n") + ;; [Utils] (defn ^:private write-file [^String file ^bytes data] (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 85488553c..dc224f52e 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -12,7 +12,7 @@ [clojure.java.io :as io] clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |case]] + (lux [base :as & :refer [|do return* return fail fail* |case |let]] [type :as &type] [host :as &host]) (lux.analyser [base :as &a] @@ -88,9 +88,9 @@ class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field "_hash" module-meta)) - (= &&/version (get-field "_compiler" module-meta))) - (let [imports (string/split (-> module-meta (.getField "_imports") (.get nil)) #"\t") + (if (and (= module-hash (get-field &/hash-field module-meta)) + (= &&/version (get-field &/compiler-field module-meta))) + (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator))) ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] @@ -108,24 +108,38 @@ ;; _ (prn 'load module real-name) ] (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field "_defs" module-meta) #"\t")] + (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) + ;; _ (prn module '(get-field &/tags-field module-meta) + ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) + tag-groups (let [all-tags (get-field &/tags-field module-meta)] + (if (= "" all-tags) + (&/|list) + (-> all-tags + (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) + (->> (map (fn [_group] + ;; (prn '_group _group) + (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] + ;; (prn '[_type _tags] [_type _tags]) + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) + _ (&a-module/set-imports imports) _ (&/map% (fn [_def] (let [[_exported? _name _ann] (string/split _def #" ") ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) ] (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field "_datum" def-class)] + def-value (get-field &/datum-field def-class)] (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field "_datum" def-class)] + def-value (get-field &/datum-field def-class)] (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-meta (get-field "_meta" def-class)] + def-meta (get-field &/meta-field def-class)] (|case def-meta (&/$ValueD def-type _) (&a-module/define module _name def-meta def-type))) @@ -134,13 +148,18 @@ (|do [__type (&a-module/def-type __module __name)] (do ;; (prn '__type [__module __name] (&type/show-type __type)) (&a-module/def-alias module _name __module __name __type)))))] - (if (= "1" _exported?) + (if (= &&/exported-true _exported?) (&a-module/export module _name) (return nil))) )) (if (= [""] defs) (&/|list) - (&/->list defs)))] + (&/->list defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [=type (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags =type)))) + tag-groups)] (return true)))) redo-cache))) redo-cache) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0ae4ce2da..26ef73cb7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -571,6 +571,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$Nil) ;; VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -616,6 +617,7 @@ (.visitInsn Opcodes/DUP) ;; I2VV (.visitLdcInsn (int 0)) ;; I2VVI (.visitLdcInsn &/$Cons) ;; I2VVIT + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; I2V (.visitInsn Opcodes/DUP_X1) ;; IV2V (.visitInsn Opcodes/SWAP) ;; IVV2 diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index e2b9f0e89..83e294c1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -73,6 +73,7 @@ (return nil))) (defn compile-variant [compile *type* ?tag ?value] + ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) @@ -105,7 +106,7 @@ (defn compile-global [compile *type* ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) "_datum" "Ljava/lang/Object;")]] + :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]] (return nil))) (defn compile-apply [compile *type* ?fn ?args] @@ -134,7 +135,7 @@ (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN (.visitInsn Opcodes/AASTORE) ;; V )] @@ -173,7 +174,7 @@ :let [_ (doto **writer** (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI - (.visitFieldInsn Opcodes/GETSTATIC current-class "_datum" "Ljava/lang/Object;") + (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") (.visitInsn Opcodes/AASTORE))] :let [_ (.visitInsn **writer** Opcodes/AASTORE)]] (return nil))) @@ -194,19 +195,19 @@ =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" "Ljava/lang/String;" nil ?name) + (-> (.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" datum-sig nil nil) + (-> (.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" datum-sig nil nil) + (-> (.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 "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] _ (compile ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class "_datum" datum-sig)] + :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" datum-sig)] + :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/meta-field datum-sig)] :let [_ (doto **writer** (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -216,7 +217,7 @@ _ (&&/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") (.get nil)) =value-type)] + _ (&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] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj new file mode 100644 index 000000000..db73e8bb4 --- /dev/null +++ b/src/lux/compiler/module.clj @@ -0,0 +1,28 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns lux.compiler.module + (:require (clojure [string :as string] + [set :as set] + [template :refer [do-template]]) + clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail* |case]] + [type :as &type]) + [lux.analyser.module :as &module])) + +;; [Exports] +(def tag-groups + "(Lux (List (, Text (List Text))))" + (|do [module &/get-current-module] + (return (&/|map (fn [pair] + (|case pair + [name [tags _]] + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) + )) -- cgit v1.2.3 From 9606c19f9947c8f2ff5647b4613ac2029ac3881f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 02:54:00 -0400 Subject: - Restructuring how sums & products work [part 1] --- src/lux/analyser.clj | 401 ++++++++++++++-------------- src/lux/analyser/base.clj | 230 ++++++++-------- src/lux/analyser/case.clj | 355 +++++++++++-------------- src/lux/analyser/env.clj | 38 +-- src/lux/analyser/host.clj | 158 +++++------ src/lux/analyser/lambda.clj | 22 +- src/lux/analyser/lux.clj | 255 ++++++++---------- src/lux/analyser/module.clj | 247 ++++++++--------- src/lux/analyser/record.clj | 122 +-------- src/lux/base.clj | 527 +++++++++++++++++++++---------------- src/lux/compiler.clj | 18 +- src/lux/compiler/base.clj | 44 ++-- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 89 ++++--- src/lux/compiler/host.clj | 26 +- src/lux/compiler/lux.clj | 75 +++--- src/lux/compiler/module.clj | 4 +- src/lux/compiler/type.clj | 89 ++++--- src/lux/host.clj | 6 +- src/lux/lexer.clj | 66 ++--- src/lux/parser.clj | 62 ++--- src/lux/reader.clj | 54 ++-- src/lux/type.clj | 627 ++++++++++++++++++++++---------------------- 23 files changed, 1725 insertions(+), 1798 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c88328f5..41a59fc00 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case]] + (lux [base :as & :refer [|let |do return fail return* fail* |case $$]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,24 +23,24 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) - (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) - (&/$Cons ?catch-body - (&/$Nil))))))) - (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) - (&/$Cons ?finally-body - (&/$Nil))))) - (return (&/T catch+ (&/V &/$Some ?finally-body))) + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] + (&/$Cons [_ (&/$TextS ?ex-class)] + (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] + (&/$Cons ?catch-body + (&/$Nil))))))] + (return (&/P (&/|++ catch+ (&/|list ($$ &/P ?ex-class ?ex-arg ?catch-body))) finally+)) + + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] + (&/$Cons ?finally-body + (&/$Nil))))] + (return (&/P catch+ (&/Some$ ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - (&/$Meta _ (&/$TagS "" name)) + [_ (&/$TagS "" name)] (return name) _ @@ -49,44 +49,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) - (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) - (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] + (&/$Cons [_ (&/$SymbolS _ ?class)] + (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) - (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) - (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] + (&/$Cons [_ (&/$SymbolS "" ?args)] (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -97,86 +97,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -185,106 +185,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] + (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -295,53 +295,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -351,63 +351,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -418,60 +418,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] + (&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) - (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] + (&/$Cons [_ (&/$TupleS tags)] + (&/$Cons [_ (&/$SymbolS "" type-name)] (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) - (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] + (&/$Cons [_ (&/$TextS ?path)] (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] + (&/$Cons [_ (&/$SymbolS "" ?ident)] (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) - (&/$Cons (&/$Meta _ (&/$TextS ?alias)) - (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] + (&/$Cons [_ (&/$TextS ?alias)] + (&/$Cons [_ (&/$TextS ?module)] (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -483,23 +483,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) + (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,20 +528,21 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - (&/$Meta meta ?token) + [meta ?token] (fn [state] - (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - (catch Error e - (prn e) - (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ;; (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + ;; (catch Error e + ;; (prn e) + ;; (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) (&/$Left "") - (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/$get-cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) (&/$Left msg) - (fail* (add-loc (&/get$ &/$cursor state) msg)) + (fail* (add-loc (&/$get-cursor state) msg)) )) )) @@ -553,42 +554,44 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/T ?output-term ?output-type*))) - (return (&/T ?output-term ?output-type))) + (return (&/P ?output-term ?output-type*))) + (return (&/P ?output-term ?output-type))) [_ _] - (return (&/T ?output-term ?output-type))) + (return (&/P ?output-term ?output-type))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] + ;; (prn 'analyse-ast (&/adt->text token)) ;; (prn 'analyse-ast (&/show-ast token)) - (&/with-cursor (aget token 1 0) - (&/with-expected-type exo-type - (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) + (|let [[cursor _] token] + (&/with-cursor cursor + (&/with-expected-type exo-type + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/P module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + [meta (&/$FormS (&/$Cons ?fn ?args))] + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index fe1e0d55b..622f0b853 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -13,120 +13,120 @@ [type :as &type]))) ;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) +(deftags + ["bool" + "int" + "real" + "char" + "text" + "unit" + "sum" + "prod" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + ]) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/T module* ?name))))) + (return (&/P module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 483002adc..aab25d741 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,7 +9,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case]] + (lux [base :as & :refer [deftags |do return fail |let |case $$]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -18,31 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags "" - "DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "TupleTotal" - "VariantTotal" +(deftags + ["DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "ProdTotal" + "SumTotal"] ) -(deftags "" - "StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "TupleTestAC" - "VariantTestAC" +(deftags + ["StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "ProdTestAC" + "SumTestAC"] ) ;; [Utils] (def ^:private unit - (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) + (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) (defn ^:private resolve-type [type] (|case type @@ -64,74 +64,66 @@ _ (&type/actual-type type))) -(defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) - (|case type - (&/$AllT _aenv _aname _aarg _abody) - (&type/with-var - (fn [$var] - (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) - - (&/$TupleT ?members) - (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&type/Tuple$ (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - (&/$VariantT ?members) - (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] - (&type/clean* _avar _abody)))) - type - up)] - (return (&/V &/$VariantT (&/|map (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) - v - up)) - ?members*)))) - - (&/$AppT ?tfun ?targ) - (|do [=type (&type/apply-type ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##9##")))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - _ - (assert false (prn 'adjust-type* (&type/show-type type))) - )) +(let [cleaner (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/S &/$BoundT _aarg))] + (&type/clean* _avar _abody))))] + (defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) + (|case type + (&/$AllT _aenv _aname _aarg _abody) + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/Cons$ ($$ &/P _aenv _aname _aarg $var) up) =type)))) + + (&/$SumT ?left ?right) + (|do [=left (&/fold% cleaner ?left up) + =right (&/fold% cleaner ?right up)] + (return (&type/Sum$ =left =right))) + + (&/$ProdT ?left ?right) + (|do [=left (&/fold% cleaner ?left up) + =right (&/fold% cleaner ?right up)] + (return (&type/Prod$ =left =right))) + + (&/$AppT ?tfun ?targ) + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn 'adjust-type* (&type/show-type type))) + ))) (defn adjust-type [type] "(-> Type (Lux Type))" (adjust-type* (&/|list) type)) +(defn ^:private resolve-tag [tag type] + (|do [[=module =name] (&&/resolved-ident tag) + type* (adjust-type type) + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + case-type (&type/variant-case idx type*)] + (return ($$ &/P idx (&/|length group) case-type)))) + (defn ^:private analyse-pattern [value-type pattern kont] - (|let [(&/$Meta _ pattern*) pattern] + (|let [[_ pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/T (&/V $StoreTestAC idx) =kont))) + (return (&/P (&/S $StoreTestAC idx) =kont))) (&/$SymbolS ident) (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) @@ -139,194 +131,152 @@ (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/T (&/V $BoolTestAC ?value) =kont))) + (return (&/P (&/S $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/T (&/V $IntTestAC ?value) =kont))) + (return (&/P (&/S $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/T (&/V $RealTestAC ?value) =kont))) + (return (&/P (&/S $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/T (&/V $CharTestAC ?value) =kont))) + (return (&/P (&/S $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/T (&/V $TextTestAC ?value) =kont))) + (return (&/P (&/S $TextTestAC ?value) =kont))) - (&/$TupleS ?members) + (&/$TupleS (&/$Cons ?_left ?tail)) (|do [value-type* (adjust-type value-type)] - (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (|case value-type* - (&/$TupleT ?member-types) - (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont))))) - - _ - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) - - (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs) - ;; :let [_ (prn 'PRE (&type/show-type value-type))] - value-type* (adjust-type value-type) - ;; :let [_ (prn 'POST (&type/show-type value-type*))] - ;; value-type* (resolve-type value-type) - ] (|case value-type* - (&/$TupleT ?member-types) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont)))) + (&/$ProdT ?left ?right) + (|do [[=left [=right =kont]] (analyse-pattern ?left ?_left + (|do [[=right =kont] (|case ?tail + (&/$Cons ?_right (&/$Nil)) + (analyse-pattern ?right ?_right kont) + + (&/$Nil) + (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") + + _ + (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))] + (return (&/P =right =kont))))] + (return (&/P (&/S $ProdTestAC =left =right) =kont))) _ - (fail "[Pattern-matching Error] Record requires record-type."))) + (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) + + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs)] + (analyse-pattern value-type (&/S &/$TupleS ?members) kont)) (&/$TagS ?ident) - (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#01")] - value-type* (adjust-type value-type) - ;; :let [_ (println "#02")] - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (println "#03")] - case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#04")] - [=test =kont] (analyse-pattern case-type unit kont) - ;; :let [_ (println "#05")] - ] - (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + (|do [[idx group-count case-type] (resolve-tag ?ident value-type) + [=test =kont] (analyse-pattern case-type unit kont)] + (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#11")] - value-type* (adjust-type value-type) - ;; :let [_ (println "#12" (&type/show-type value-type*))] - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (println "#13")] - case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#14" (&type/show-type case-type))] + (|do [[idx group-count case-type] (resolve-tag ?ident value-type) [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) ;; :let [_ (println "#15")] ] - (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/|cons pattern+body patterns)))) + (return (&/Cons$ pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/V $DefaultTotal true)) + (return (&/S $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/V ?tag (&/T true ?values))) + (return (&/S ?tag (&/P true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) + (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|list ?value)))) + (return (&/S $IntTotal (&/P total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|list ?value)))) + (return (&/S $RealTotal (&/P total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|list ?value)))) + (return (&/S $CharTotal (&/P total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|list ?value)))) + (return (&/S $TextTotal (&/P total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) - - [($DefaultTotal total?) ($TupleTestAC ?tests)] - (|do [structs (&/map% (fn [t] - (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) - ?tests)] - (return (&/V $TupleTotal (&/T total? structs)))) - - [($TupleTotal total? ?values) ($TupleTestAC ?tests)] - (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) - (|do [structs (&/map2% (fn [v t] - (merge-total v (&/T t ?body))) - ?values ?tests)] - (return (&/V $TupleTotal (&/T total? structs)))) - (fail "[Pattern-matching Error] Inconsistent tuple-size.")) - - [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/V $DefaultTotal total?) - (&/T ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) + (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) + + [($DefaultTotal total?) ($ProdTestAC ?left ?right)] + (|do [:let [_default (&/S $DefaultTotal total?)] + =left (merge-total _default (&/P ?left ?body)) + =right (merge-total _default (&/P ?right ?body))] + (return (&/S $ProdTotal ($$ &/P total? =left =right)))) + + [($ProdTotal total? ?_left ?_right) ($ProdTestAC ?left ?right)] + (|do [=left (merge-total ?_left (&/P ?left ?body)) + =right (merge-total ?_right (&/P ?right ?body))] + (return (&/S $ProdTotal ($$ &/P total? =left =right)))) + + [($DefaultTotal total?) ($SumTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/S $DefaultTotal total?) + (&/P ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/S $DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) + (return (&/S $SumTotal (&/P total? structs)))) - [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] + [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/V $DefaultTotal total?)) - (&/T ?test ?body)) + (&/S $DefaultTotal total?)) + (&/P ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/V $VariantTotal (&/T total? structs)))) + (return (&/S $SumTotal (&/P total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -351,33 +301,36 @@ ($TextTotal ?total _) (return ?total) - ($TupleTotal ?total ?structs) + ($ProdTotal ?total ?_left ?_right) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (&/$ProdT ?left ?right) + (|do [=left (check-totality ?left ?_left) + =right (check-totality ?right ?_right)] + (return (and =left =right))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($VariantTotal ?total ?structs) + ($SumTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$VariantT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - ;; (prn '$VariantTotal - ;; (&/adt->text sub-struct) - ;; (&type/show-type ?member)) - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|case [value-type* ?structs] + [(&/$SumT ?left ?right) (&/$Cons ?_left ?tail)] + (|do [=left (check-totality ?left ?_left) + =right (|case ?tail + (&/$Cons ?_right (&/$Nil)) + (check-totality ?right ?_right) + + (&/$Nil) + (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") + + _ + (check-totality ?right ($SumTotal ?total ?tail)))] + (return (and =left =right))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -394,7 +347,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/S $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 4e9dcd79f..5686700e3 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,31 +15,31 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) + (return* state (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) - =return (body (&/update$ &/$envs - (fn [stack] - (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] - (&/|cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] + (let [old-mappings (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-mappings)) + =return (body (&/$update-envs + (fn [stack] + (let [bound-unit (&/S &&/$var (&/S &/$Local (->> (&/|head stack) (&/$get-locals) (&/$get-counter))))] + (&/Cons$ (&/$update-locals #(->> % + (&/$update-counter inc) + (&/$update-mappings (fn [m] (&/|put name (&/P bound-unit type) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] (|case =return (&/$Right ?state ?value) - (return* (&/update$ &/$envs (fn [stack*] - (&/|cons (&/update$ &/$locals #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) + (return* (&/$update-envs (fn [stack*] + (&/Cons$ (&/$update-locals #(->> % + (&/$update-counter dec) + (&/$set-mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) ?value) _ @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) + (return* state (->> state (&/$get-envs) &/|head (&/$get-closure) (&/$get-mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 64f297994..69aa95f12 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] + (lux [base :as & :refer [|let |do return fail |case $$]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - (&/$Meta _ (&/$TextS ?text)) + [_ (&/$TextS ?text)] (return ?text) _ @@ -32,7 +32,7 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/P ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&/V &/$DataT (&type/as-obj class)) + (&type/Data$ (&type/as-obj class)) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&/V &/$DataT ) - output-type (&/V &/$DataT )] + (let [input-type (&type/Data$ ) + output-type (&type/Data$ )] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) + (return (&/|list (&/P (&/S (&/P =x =y)) output-type)))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -143,31 +143,31 @@ ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?class =object)) output-type))))) (do-template [ ] (defn [analyse exo-type ?class ?method ?classes ?object ?args] (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/P (&/S ($$ &/P ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -179,73 +179,73 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V &/$DataT "null")] + (|do [:let [output-type (&type/Data$ "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V &/$DataT ?class)] + :let [output-type (&type/Data$ ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) - (&/V &/$Nil nil))))))) + (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) + (&/S &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) + (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) + (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - (&/$Meta _ (&/$TextS "public")) + [_ (&/$TextS "public")] (return (assoc so-far :visibility "public")) - (&/$Meta _ (&/$TextS "private")) + [_ (&/$TextS "private")] (return (assoc so-far :visibility "private")) - (&/$Meta _ (&/$TextS "protected")) + [_ (&/$TextS "protected")] (return (assoc so-far :visibility "protected")) - (&/$Meta _ (&/$TextS "static")) + [_ (&/$TextS "static")] (return (assoc so-far :static? true)) - (&/$Meta _ (&/$TextS "final")) + [_ (&/$TextS "final")] (return (assoc so-far :final? true)) - (&/$Meta _ (&/$TextS "abstract")) + [_ (&/$TextS "abstract")] (return (assoc so-far :abstract? true)) - (&/$Meta _ (&/$TextS "synchronized")) + [_ (&/$TextS "synchronized")] (return (assoc so-far :concurrency "synchronized")) - (&/$Meta _ (&/$TextS "volatile")) + [_ (&/$TextS "volatile")] (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) - (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) - (&/$Nil)))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,18 +289,18 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) - (&/$Cons ?method-body - (&/$Nil))))))))] + [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?method-inputs)] + (&/$Cons [_ (&/$TextS ?method-output)] + (&/$Cons [_ (&/$TupleS ?method-modifiers)] + (&/$Cons ?method-body + (&/$Nil)))))))]] (|do [=method-inputs (&/map% (fn [minput] (|case minput - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) - (&/$Nil))))) - (return (&/T ?input-name ?input-type)) + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] + (&/$Cons [_ (&/$TextS ?input-type)] + (&/$Nil))))] + (return (&/P ?input-name ?input-type)) _ (fail "[Analyser Error] Wrong syntax for method input."))) @@ -309,14 +309,14 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V &/$DataT (as-otype itype)) + (&&env/with-local iname (&type/Data$ (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/|cons (&/T ";this" ?super-class) + (&/Cons$ (&/P "this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -327,18 +327,18 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/S &&/$jvm-class ($$ &/P ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) - (&/$Nil))))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?inputs)] + (&/$Cons [_ (&/$TextS ?output)] + (&/$Cons [_ (&/$TupleS ?modifiers)] + (&/$Nil))))))] (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -349,29 +349,29 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] + _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return (&/T ?ex-class idx =catch-body)))) + (return ($$ &/P ?ex-class idx =catch-body)))) ?catches) - =finally (|case [?finally] - (&/$None) (return (&/V &/$None nil)) + =finally (|case ?finally + (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) + (return (&/Some$ =finally))))] + (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] + (return (&/|list (&/P (&/S &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] (defn [analyse exo-type ?monitor] @@ -379,18 +379,18 @@ _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =monitor) output-type))))) + (return (&/|list (&/P (&/S =monitor) output-type))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + (return (&/|list (&/P (&/S =value) output-type)))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -413,11 +413,11 @@ ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + (return (&/|list (&/P (&/S =value) output-type)))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V &&/$jvm-program =body))] + (&&env/with-local ?args (&type/App$ &type/List &type/Text) + (&&/analyse-1 analyse (&type/App$ &type/IO &type/Unit) ?body))) + _ (compile-token (&/S &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index aeb5a4814..696c816e9 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -9,7 +9,7 @@ (ns lux.analyser.lambda (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case]] + (lux [base :as & :refer [|let |do return fail |case $$]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -22,15 +22,19 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return (&/T scope-name =captured =return)))))))) + (return ($$ &/P scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register)) + register* (&/P (&/S &&/$captured ($$ &/P scope + (->> frame (&/$get-closure) (&/$get-counter)) + register)) register-type)] - (&/T register* (&/update$ &/$closure #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) - frame)))) + (do (prn 'close-over 'updating-closure + [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] + [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) + (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) + ($$ &/P register* (&/$update-closure #(->> % + (&/$update-counter inc) + (&/$update-mappings (fn [mps] (&/|put name register* mps)))) + frame))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d241201f4..f7ed07ee4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case $$]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -27,52 +27,64 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/P ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - (&/$Meta _ syntax) - (&/V &/$Meta (&/T cursor syntax)))) + [_ syntax] + (&/P cursor syntax))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - - (&/$AllT _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) - - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) - -(defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (|case ?values - (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse exo-type ?value) + ;; (prn 'analyse-tuple/_0 (&type/show-type exo-type) (->> ?elems (&/|map &/show-ast) (&/->seq))) + (|case ?elems + (&/$Nil) + (|do [_ (&type/check exo-type &type/Unit)] + (return (&/|list (&/P (&/S &&/$unit nil) + exo-type)))) + + (&/$Cons single (&/$Nil)) + (fail (str "Tuples can't have only 1 element: " (&/show-ast single))) + + (&/$Cons head tail) + (|do [exo-type* (&type/actual-type exo-type) + ;; :let [_ (prn 'analyse-tuple/_0.25_0 (&/show-ast head) (&/adt->text exo-type*)) + ;; _ (prn 'analyse-tuple/_0.25_1 (&/show-ast head) (&type/show-type exo-type*))] + ] + (|case exo-type* + (&/$ProdT ?left ?right) + (|do [;; :let [_ (prn 'analyse-tuple/_0.5 (&/show-ast head) (&type/show-type ?left))] + =left (&&/analyse-1 analyse ?left head) + ;; :let [_ (prn 'analyse-tuple/_1 =left (&type/show-type ?left))] + =right (|case tail + (&/$Nil) + (fail "Tuples has wrong size.") + + (&/$Cons single (&/$Nil)) + (&&/analyse-1 analyse ?right single) + + _ + (&/ensure-1 (analyse-tuple analyse ?right tail))) + ;; :let [_ (prn 'analyse-tuple/_2 =right (&type/show-type ?right))] + ] + (return (&/|list (&/P (&/S &&/$prod (&/P =left =right)) + exo-type)))) - _ - (analyse-tuple analyse exo-type ?values) - )] - (|case output - (&/$Cons x (&/$Nil)) - (return x) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail "[Analyser Error] Can't expand to other than 1 element.")))) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) + )) (defn analyse-variant [analyse exo-type idx ?values] + ;; (prn 'analyse-variant/_0 + ;; (&type/show-type exo-type) + ;; idx + ;; (->> ?values (&/|map &/show-ast) (&/->seq))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -83,82 +95,41 @@ _ (&type/actual-type exo-type))] (|case exo-type* - (&/$VariantT ?cases) - (|case (&/|at idx ?cases) - (&/$Some vtype) - (|do [=value (analyse-variant-body analyse vtype ?values)] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) - - (&/$None) - (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) - (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** idx ?values)))) - - _ - (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) -;; (defn analyse-variant [analyse exo-type ident ?values] -;; (|do [exo-type* (|case exo-type -;; (&/$VarT ?id) -;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] -;; (&type/actual-type exo-type*)) -;; (|do [_ (&type/set-var ?id &type/Type)] -;; (&type/actual-type &type/Type)))) - -;; _ -;; (&type/actual-type exo-type))] -;; (|case exo-type* -;; (&/$VariantT ?cases) -;; (|do [?tag (&&/resolved-ident ident)] -;; (if-let [vtype (&/|get ?tag ?cases)] -;; (|do [=value (analyse-variant-body analyse vtype ?values)] -;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) -;; exo-type)))) -;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - -;; (&/$AllT _) -;; (&type/with-var -;; (fn [$var] -;; (|do [exo-type** (&type/apply-type exo-type* $var)] -;; (analyse-variant analyse exo-type** ident ?values)))) - -;; _ -;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) -(defn analyse-record [analyse exo-type ?elems] - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - - (&/$AllT _) - (|do [$var &type/existential - =type (&type/apply-type exo-type $var)] - (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type exo-type $var)] - ;; (&type/actual-type =type)))) + ?variant + (|do [;; :let [_ (prn 'analyse-variant/_1 + ;; (&type/show-type ?variant) + ;; idx + ;; (->> ?values (&/|map &/show-ast) (&/->seq)))] + vtype (&type/variant-case idx ?variant) + ;; :let [_ (prn 'analyse-variant/_2 + ;; idx + ;; (&type/show-type vtype))] + =value (&/ensure-1 (|case ?values + (&/$Nil) + (analyse-tuple analyse vtype (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse vtype ?value) + + _ + (analyse-tuple analyse vtype ?values))) + ;; :let [_ (prn 'analyse-variant/_3 + ;; idx + ;; =value)] + ] + (return (&/|list (&/P (&/S &&/$sum (&/P idx =value)) + exo-type)))) + ))) - _ - (&type/actual-type exo-type)) - types (|case exo-type* - (&/$TupleT ?table) - (return ?table) - - _ - (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) - _ (&/assert! (= (&/|length types) (&/|length ?elems)) - (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - members (&&record/order-record ?elems) - =members (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - types members)] - (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) +(defn analyse-record [analyse exo-type ?elems] + (|do [members (&&record/order-record ?elems)] + (analyse-tuple analyse exo-type members))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -177,14 +148,17 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/get$ &/$envs state) - no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) - (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) + (|let [stack (&/$get-envs state) + no-binding? #(do ;; (prn 'analyse-local/_ (->> % &/adt->text)) + ;; (prn 'analyse-local/_1 (->> % (&/$get-locals) &/adt->text)) + ;; (prn 'analyse-local/_2 (->> % (&/$get-closure) &/adt->text)) + (and (->> % (&/$get-locals) (&/$get-mappings) (&/|contains? name) not) + (->> % (&/$get-closure) (&/$get-mappings) (&/|contains? name) not))) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -193,8 +167,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/$get-locals) (&/$get-mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/$get-locals) (&/$get-mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -213,32 +187,31 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) endo-type)))) state) - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) (fail* "_{_ analyse-symbol _}_"))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) - (&/|map #(&/get$ &/$name %) outer) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/$get-name %2) %1) + (&/|map #(&/$get-name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T register* (&/|cons frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + (&/P register* (&/Cons$ frame* new-inner)))) + (&/P (or (->> top-outer (&/$get-locals) (&/$get-mappings) (&/|get name)) + (->> top-outer (&/$get-closure) (&/$get-mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/set$ &/$envs (&/|++ inner* outer) state)))) + (&/$set-envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -253,7 +226,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/T fun-type (&/|list)))) + (return (&/P fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -271,15 +244,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/T type** =args))) + (return (&/P type** =args))) )))) (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T =output-t (&/|cons =arg =args)))) + (return (&/P =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -313,12 +286,12 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) + (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) + (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) =output-t))))) ))) @@ -329,7 +302,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) + (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -348,7 +321,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -370,22 +343,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/T _expr exo-type)) + (return (&/P _expr exo-type)) (&/$ExT _) - (return (&/T _expr exo-type)) + (return (&/P _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/T _expr exo-type)) + ;; (return (&/P _expr exo-type)) (if ?? (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/T _expr exo-type))) + (return (&/P _expr exo-type))) ) _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/T _expr exo-type)))))))) + (return (&/P _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -418,7 +391,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -428,16 +401,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) + _ (compile-token (&/S &&/$declare-macro (&/P module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] (return (&/|list)))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) @@ -469,7 +442,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) + (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -477,5 +450,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) + (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index d23953f5e..909e7e2c4 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,69 +12,70 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] + (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] [type :as &type] [host :as &host]))) ;; [Utils] -(deftags "" - "module-aliases" - "defs" - "imports" - "tags" - "types") +(defrtags + ["module-aliases" + "defs" + "imports" + "tags" + "types"]) (def ^:private +init+ - (&/T ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + ($$ &/P + ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + (&/|list) + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + )) ;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/update$ $imports (partial &/|cons module) m)) - ms)) - state) + (return* (&/$update-modules + (fn [ms] + (&/|update current-module + (fn [m] ($update-imports (partial &/Cons$ module) m)) + ms)) + state) nil)))) (defn set-imports [imports] "(-> (List Text) (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/set$ $imports imports m)) - ms)) - state) + (return* (&/$update-modules + (fn [ms] + (&/|update current-module + (fn [m] ($set-imports imports m)) + ms)) + state) nil)))) (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] - (|case (&/get$ &/$envs state) + (|case (&/$get-envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T false def-data) %) - m)) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update module + (fn [m] + ($update-defs + #(&/|put name (&/P false def-data) %) + m)) + ms)))) nil) _ @@ -83,8 +84,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$def (->> $module ($get-defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -104,31 +105,31 @@ (defn type-def [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$def (->> $module ($get-defs) (&/|get name))] (|case $def [_ (&/$TypeD _type)] (return* state _type) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/P module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/P module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/get$ &/$envs state) + (|case (&/$get-envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update a-module - (fn [m] - (&/update$ $defs - #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) - m)) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update a-module + (fn [m] + ($update-defs + #(&/|put a-name (&/P false (&/S &/$AliasD (&/P r-module r-name))) %) + m)) + ms)))) nil) _ @@ -137,26 +138,30 @@ (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] + ;; (prn 'exists?/_0 &/$modules name) + ;; (prn 'exists?/_2 (&/adt->text state)) + ;; (prn 'exists?/_3 (&/adt->text (->> state (&/$get-modules)))) + ;; (prn 'exists?/_4 (&/adt->text (->> state (&/$get-modules) (&/|contains? name)))) (return* state - (->> state (&/get$ &/$modules) (&/|contains? name))))) + (->> state (&/$get-modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - #(&/update$ $module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) + (&/$update-modules + (fn [ms] + (&/|update module + #($update-module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) nil))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] + (if-let [real-name (->> state (&/$get-modules) (&/|get current-module) ($get-module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -164,9 +169,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$module (->> state (&/$get-modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (if-let [$def (->> $module ($get-defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -177,7 +182,7 @@ state)) _ - (return* state (&/T (&/T module name) $$def))) + (return* state (&/P (&/P module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) @@ -198,7 +203,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] + (if-let [$module (->> state (&/$get-modules) (&/|get module) ($get-defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -208,15 +213,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/update$ &/$modules - (fn [$modules] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/$update-modules + (fn [$modules] + (&/|update module + (fn [m] + ($update-defs + #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -230,21 +235,21 @@ (defn export [module name] (fn [state] - (|case (&/get$ &/$envs state) + (|case (&/$get-envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] + (if-let [$def (->> state (&/$get-modules) (&/|get module) ($get-defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/update$ &/$modules (fn [ms] - (&/|update module (fn [m] - (&/update$ $defs - #(&/|put name (&/T true ?data) %) - m)) - ms)))) + (&/$update-modules (fn [ms] + (&/|update module (fn [m] + ($update-defs + #(&/|put name (&/P true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -260,61 +265,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) + ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - (&/T ?exported? k "M") + ($$ &/P ?exported? k "M") (&/$TypeD _) - (&/T ?exported? k "T") + ($$ &/P ?exported? k "T") _ - (&/T ?exported? k "V"))))) - (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) + ($$ &/P ?exported? k "V"))))) + (->> state (&/$get-modules) (&/|get module) ($get-defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) + (return* state (->> state (&/$get-modules) (&/|get module) ($get-imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) + (return* (&/$update-modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/update$ &/$modules #(&/|put name +init+ %)) - (&/set$ &/$envs (&/|list (&/env name)))) + (&/$update-modules #(&/|put name +init+ %)) + (&/$set-envs (&/|list (&/env name)))) nil))) -(do-template [ ] +(do-template [ ] (defn [module] (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ =module)) + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (return* state ( =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + tags-by-module $get-tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $get-types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" ) (defn ensure-undeclared-tags [module tags] (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P module tag)))) (return nil))) tags)] (return nil))) (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -327,37 +332,37 @@ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) _ (ensure-undeclared-type _module _name)] (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] - (return* (&/update$ &/$modules - (fn [=modules] - (&/|update module - #(->> % - (&/set$ $tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name (&/T idx tags type) table))) - (&/get$ $tags %) - (&/enumerate tag-names))) - (&/update$ $types (partial &/|put _name (&/T tags type)))) - =modules)) - state) + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/P module tag-name)) tag-names)] + (return* (&/$update-modules + (fn [=modules] + (&/|update module + #(->> % + ($set-tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name ($$ &/P idx tags type) table))) + ($get-tags %) + (&/enumerate tag-names))) + ($update-types (partial &/|put _name (&/P tags type)))) + =modules)) + state) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) (defn tag-index [module tag-name] "(-> Text Text (Lux Int))" (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) (fail* (str "[Module Error] Unknown module: " module))))) (defn tag-group [module tag-name] "(-> Text Text (Lux (List Ident)))" (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 2b4b7e095..96c988544 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,122 +13,6 @@ (lux.analyser [base :as &&] [module :as &&module]))) -;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) - ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" @@ -136,7 +20,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -144,9 +28,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [(&/$Meta _ (&/$TagS k)) v] + [[_ (&/$TagS k)] v] (|do [=k (&&/resolved-ident k)] - (return (&/T (&/ident->text =k) v))) + (return (&/P (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 6247524af..2f0925586 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,99 +11,157 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [Tags] -(defmacro deftags [prefix & names] +;; [ADTs] +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) + +(defmacro deftags [names] + (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] `(def ~(symbol (str "$" name)) ~idx)))) +(defn ^:private unfold-accesses + ([elems] + (unfold-accesses 1 (count elems) elems)) + ([begin end elems] + (if (= begin end) + (list elems) + (cons (take begin elems) + (unfold-accesses (inc begin) end elems))))) + +(defmacro defrtags [tags] + (let [num-tags (count tags) + normals (butlast tags) + special (last tags) + tags+locs (cons [special (repeat (dec num-tags) 1)] + (map #(vector %1 (concat (repeat %2 1) [0])) + normals + (range num-tags)))] + `(do ~@(for [[tag loc] tags+locs + :let [getter (symbol (str "$get-" tag)) + setter (symbol (str "$set-" tag)) + updater (symbol (str "$update-" tag)) + record (gensym "record") + value (gensym "value")]] + `(do (defn ~getter [~record] + ;; (if (= '~'$get-source '~getter) + ;; (prn '~getter '~loc ~record (aget ~record ~@loc)) + ;; (prn '~getter '~loc ~record (adt->text (aget ~record ~@loc)))) + (aget ~record ~@loc)) + (defn ~setter [~value ~record] + ;; (if (= '~'$set-source '~setter) + ;; (prn '~setter '_1 '~loc ~record) + ;; (prn '~setter '_2 '~loc ~record (adt->text ~value))) + ;; (doto record# + ;; (aset ~@loc value#)) + ;; (doto record# + ;; (aset 1 (doto (aget record# 1) + ;; (aset 1 ...)))) + ~(reduce (fn [inner indices] + `(doto (aclone ~(if (= 1 (count indices)) + record + `(aget ~record ~@(butlast indices)))) + (aset ~(last indices) ~inner))) + value + (reverse (unfold-accesses loc))) + ) + (defn ~updater [f# ~record] + ;; (prn '~updater '~loc ~record) + ;; (doto record# + ;; (aset ~@loc (f# (aget record# ~@loc)))) + (~setter (f# (~getter ~record)) ~record))))) + )) + ;; List -(deftags "" - "Nil" - "Cons") +(deftags + ["Nil" + "Cons"]) ;; Maybe -(deftags "" - "None" - "Some") - -;; Meta -(deftags "" - "Meta") +(deftags + ["None" + "Some"]) ;; Either -(deftags "" - "Left" - "Right") +(deftags + ["Left" + "Right"]) ;; AST -(deftags "" - "BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS") +(deftags + ["BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS"]) ;; Type -(deftags "" - "DataT" - "VariantT" - "TupleT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "AllT" - "AppT" - "NamedT") +(deftags + ["VoidT" + "UnitT" + "SumT" + "ProdT" + "DataT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT" + "NamedT"]) ;; Vars -(deftags "lux;" - "Local" - "Global") +(deftags + ["Local" + "Global"]) ;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") +(deftags + ["ValueD" + "TypeD" + "MacroD" + "AliasD"]) ;; Binding -(deftags "" - "counter" - "mappings") +(defrtags + ["counter" + "mappings"]) ;; Env -(deftags "" - "name" - "inner-closures" - "locals" - "closure") +(defrtags + ["name" + "inner-closures" + "locals" + "closure"]) ;; Host -(deftags "" - "writer" - "loader" - "classes") +(defrtags + ["writer" + "loader" + "classes"]) ;; Compiler -(deftags "" - "source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host") +(defrtags + ["source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host"]) ;; [Exports] +;; Class fields (def datum-field "_datum") (def meta-field "_meta") (def name-field "_name") @@ -117,55 +175,59 @@ (def +name-separator+ ";") -(defn T [& elems] - (to-array elems)) - -(defn V [^Long tag value] - (to-array [tag value])) +(def prelude-name "lux") -;; Constructors -(def None$ (V $None nil)) -(defn Some$ [x] (V $Some x)) +(defmacro $$ [op & args] + (assert (> (count args) 1) + (prn-str '$$ op args)) + (let [[last & others] (reverse args)] + (reduce (fn [right left] `(~op ~left ~right)) + last + others))) -(def Nil$ (V $Nil nil)) -(defn Cons$ [h t] (V $Cons (T h t))) +(defn S [^Long tag value] + (to-array [tag value])) -(defn get$ [slot ^objects record] - (aget record slot)) +(defn P [left right] + (to-array [left right])) -(defn set$ [slot value ^objects record] - (let [record* (aclone record) - size (alength record)] - (aset record* slot value) - record*)) +;; Constructors +(def None$ (S $None nil)) +(defn Some$ [x] (S $Some x)) -(defmacro update$ [slot f record] - `(let [record# ~record] - (set$ ~slot (~f (get$ ~slot record#)) - record#))) +(def Nil$ (S $Nil nil)) +(defn Cons$ [h t] (S $Cons (P h t))) (defn fail* [message] - (V $Left message)) + (S $Left message)) (defn return* [state value] - (V $Right (T state value))) + (S $Right (P state value))) + +(defn ^:private transform-tuple-pattern [pattern] + (case (count pattern) + 0 '_ + 1 (assert false "Can't have singleton tuples.") + 2 pattern + ;; else + (let [[last & others] (reverse pattern)] + (reduce (fn [r l] [l r]) last others)))) (defn transform-pattern [pattern] - (cond (vector? pattern) (mapv transform-pattern pattern) + (cond (vector? pattern) (transform-tuple-pattern (mapv transform-pattern pattern)) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) - 0 '_ 1 (first parts) ;; else - `[~@parts]))))) + (transform-tuple-pattern parts)))))) :else pattern )) (defmacro |case [value & branches] (assert (= 0 (mod (count branches) 2))) (let [value* (if (vector? value) - [`(T ~@value)] + [`($$ P ~@value)] [value])] `(matchv ::M/objects ~value* ~@(mapcat (fn [[pattern body]] @@ -183,8 +245,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(V $Cons (T ~head ~tail))) - `(V $Nil nil) + `(Cons$ ~head ~tail)) + `Nil$ (reverse elems))) (defmacro |table [& elems] @@ -204,17 +266,18 @@ (|get slot table*)))) (defn |put [slot value table] + ;; (prn '|put slot (adt->text value) (adt->text table)) (|case table ($Nil) - (V $Cons (T (T slot value) (V $Nil nil))) + (Cons$ (P slot value) Nil$) ($Cons [k v] table*) (if (.equals ^Object k slot) - (V $Cons (T (T slot value) table*)) - (V $Cons (T (T k v) (|put slot value table*)))) + (Cons$ (P slot value) table*) + (Cons$ (P k v) (|put slot value table*))) ;; _ - ;; (assert false (prn-str '|put (aget table 0))) + ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table))) )) (defn |remove [slot table] @@ -225,7 +288,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (V $Cons (T (T k v) (|remove slot table*)))))) + (Cons$ (P k v) (|remove slot table*))))) (defn |update [k f table] (|case table @@ -234,8 +297,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (V $Cons (T (T k* (f v)) table*)) - (V $Cons (T (T k* v) (|update k f table*)))))) + (Cons$ (P k* (f v)) table*) + (Cons$ (P k* v) (|update k f table*))))) (defn |head [xs] (|case xs @@ -256,11 +319,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (V $Left message))) + (S $Left message))) (defn return [value] (fn [state] - (V $Right (T state value)))) + (S $Right (P state value)))) (defn bind [m-value step] (fn [state] @@ -288,22 +351,13 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn |cons [head tail] - (V $Cons (T head tail))) - (defn |++ [xs ys] (|case xs ($Nil) ys ($Cons x xs*) - (V $Cons (T x (|++ xs* ys))))) - -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) + (Cons$ x (|++ xs* ys)))) (defn |map [f xs] (|case xs @@ -311,7 +365,7 @@ xs ($Cons x xs*) - (V $Cons (T (f x) (|map f xs*))) + (Cons$ (f x) (|map f xs*)) _ (assert false (prn-str '|map f (adt->text xs))) @@ -332,7 +386,7 @@ ($Cons x xs*) (if (p x) - (V $Cons (T x (|filter p xs*))) + (Cons$ x (|filter p xs*)) (|filter p xs*)))) (defn flat-map [f xs] @@ -346,13 +400,13 @@ (defn |split-with [p xs] (|case xs ($Nil) - (T xs xs) + (P xs xs) ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T (|cons x pre) post)) - (T (V $Nil nil) xs)))) + (P (Cons$ x pre) post)) + (P Nil$ xs)))) (defn |contains? [k table] (|case table @@ -361,7 +415,10 @@ ($Cons [k* _] table*) (or (.equals ^Object k k*) - (|contains? k table*)))) + (|contains? k table*)) + + _ + (assert false (prn-str '|contains? k (adt->text table))))) (defn fold [f init xs] (|case xs @@ -386,15 +443,15 @@ (|list init) ($Cons x xs*) - (|cons init (folds f (f init x) xs*)))) + (Cons$ init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (V $Cons (T from (|range* (inc from) to))) - (V $Nil nil)))] + (Cons$ from (|range* (inc from) to)) + Nil$))] (defn |range [n] (|range* 0 n))) @@ -409,10 +466,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (V $Cons (T (T x y) (zip2 xs* ys*))) + (Cons$ (P x y) (zip2 xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn |keys [plist] (|case plist @@ -420,7 +477,7 @@ (|list) ($Cons [k v] plist*) - (|cons k (|keys plist*)))) + (Cons$ k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -428,7 +485,7 @@ (|list) ($Cons [k v] plist*) - (|cons v (|vals plist*)))) + (Cons$ v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -439,7 +496,7 @@ xs ($Cons x xs*) - (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) + (Cons$ x (Cons$ sep (|interpose sep xs*))))) (do-template [ ] (defn [f xs] @@ -452,23 +509,23 @@ ys ( f xs*)] (return ( y ys))))) - map% |cons + map% Cons$ flat-map% |++) (defn list-join [xss] - (fold |++ (V $Nil nil) xss)) + (fold |++ Nil$ xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (V $Cons (T (T x y) (|as-pairs xs*))) + (Cons$ (P x y) (|as-pairs xs*)) _ - (V $Nil nil))) + Nil$)) (defn |reverse [xs] (fold (fn [tail head] - (|cons head tail)) + (Cons$ head tail)) (|list) xs)) @@ -504,7 +561,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (|cons head tail))) + (return (Cons$ head tail))) (return (|list))))) (defn exhaust% [step] @@ -551,28 +608,28 @@ (def loader (fn [state] - (return* state (->> state (get$ $host) (get$ $loader))))) + (return* state (->> state $get-host ($get-loader))))) (def classes (fn [state] - (return* state (->> state (get$ $host) (get$ $classes))))) + (return* state (->> state $get-host ($get-classes))))) (def +init-bindings+ - (T ;; "lux;counter" + (P ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - (T ;; "lux;name" - name - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+ - )) + ($$ P ;; "lux;name" + name + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+ + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) @@ -594,41 +651,41 @@ (defn host [_] (let [store (atom {})] - (T ;; "lux;writer" - (V $None nil) - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store))) + ($$ P ;; "lux;writer" + None$ + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store))) (defn init-state [_] - (T ;; "lux;source" - (V $None nil) - ;; "lux;cursor" - (T "" -1 -1) - ;; "lux;modules" - (|table) - ;; "lux;envs" - (|list) - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - (V $VariantT (|list)) - ;; "lux;seed" - 0 - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) - )) + ($$ P ;; "lux;source" + None$ + ;; "lux;cursor" + ($$ P "" -1 -1) + ;; "lux;modules" + (|table) + ;; "lux;envs" + (|list) + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + (S $VoidT nil) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) + )) (defn save-module [body] (fn [state] (|case (body state) ($Right state* output) (return* (->> state* - (set$ $envs (get$ $envs state)) - (set$ $source (get$ $source state))) + ($set-envs ($get-envs state)) + ($set-source ($get-source state))) output) ($Left msg) @@ -636,20 +693,20 @@ (defn with-eval [body] (fn [state] - (|case (body (set$ $eval? true state)) + (|case (body ($set-eval? true state)) ($Right state* output) - (return* (set$ $eval? (get$ $eval? state) state*) output) + (return* ($set-eval? ($get-eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state (get$ $eval? state)))) + (return* state ($get-eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state (get$ $host) (get$ $writer))] + (let [writer* (->> state ($get-host) ($get-writer))] (|case writer* ($Some datum) (return* state datum) @@ -659,15 +716,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head (get$ $envs state))] + (try (let [top (|head ($get-envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed (get$ $seed state)] - (return* (set$ $seed (inc seed) state) seed)))) + (let [seed ($get-seed state)] + (return* ($set-seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -680,26 +737,26 @@ (defn ->list [seq] (if (empty? seq) (|list) - (|cons (first seq) (->list (rest seq))))) + (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (|cons x (|repeat (dec n) x)) + (Cons$ x (|repeat (dec n) x)) (|list))) (def get-module-name (fn [state] - (|case (|reverse (get$ $envs state)) + (|case (|reverse ($get-envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state (get$ $name ?global))))) + (return* state ($get-name ?global))))) (defn find-module [name] "(-> Text (Lux (Module Compiler)))" (fn [state] - (if-let [module (|get name (get$ $modules state))] + (if-let [module (|get name ($get-modules state))] (return* state module) (fail* (str "Unknown module: " name))))) @@ -710,10 +767,10 @@ (defn with-scope [name body] (fn [state] - (let [output (body (update$ $envs #(|cons (env name) %) state))] + (let [output (body ($update-envs #(Cons$ (env name) %) state))] (|case output ($Right state* datum) - (return* (update$ $envs |tail state*) datum) + (return* ($update-envs |tail state*) datum) _ output)))) @@ -723,23 +780,24 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $inner-closures) str)))] + (return (->> top ($get-inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) - (|tail %)) - state)))))) + (run-state body* ($update-envs #(Cons$ ($update-inner-closures inc (|head %)) + (|tail %)) + state)))))) (def get-scope-name (fn [state] - (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) + (return* state (->> state ($get-envs) (|map #($get-name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (prn 'with-writer writer body) + (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* ($update-host #($set-writer (->> state ($get-host) ($get-writer)) %) ?state) ?value) _ @@ -748,10 +806,11 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - (let [output (body (set$ $expected type state))] + ;; (prn 'with-expected-type type state) + (let [output (body ($set-expected type state))] (|case output ($Right ?state ?value) - (return* (set$ $expected (get$ $expected state) ?state) + (return* ($set-expected ($get-expected state) ?state) ?value) _ @@ -759,14 +818,20 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" + ;; (prn 'with-cursor/_0 (adt->text cursor)) (if (= "" (aget cursor 0)) body (fn [state] - (let [output (body (set$ $cursor cursor state))] + (let [;; _ (prn 'with-cursor/_1 cursor) + state* ($set-cursor cursor state) + ;; _ (prn 'with-cursor/_2 state*) + output (body state*)] (|case output ($Right ?state ?value) - (return* (set$ $cursor (get$ $cursor state) ?state) - ?value) + (let [?state* ($set-cursor ($get-cursor state) ?state)] + ;; (prn 'with-cursor/_3 ?state*) + (return* ?state* + ?value)) _ output))))) @@ -774,40 +839,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - ($Meta _ ($BoolS ?value)) + [_ ($BoolS ?value)] (pr-str ?value) - ($Meta _ ($IntS ?value)) + [_ ($IntS ?value)] (pr-str ?value) - ($Meta _ ($RealS ?value)) + [_ ($RealS ?value)] (pr-str ?value) - ($Meta _ ($CharS ?value)) + [_ ($CharS ?value)] (pr-str ?value) - ($Meta _ ($TextS ?value)) + [_ ($TextS ?value)] (str "\"" ?value "\"") - ($Meta _ ($TagS ?module ?tag)) + [_ ($TagS ?module ?tag)] (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?ident)) + [_ ($SymbolS ?module ?ident)] (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - ($Meta _ ($TupleS ?elems)) + [_ ($TupleS ?elems)] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ($Meta _ ($RecordS ?elems)) + [_ ($RecordS ?elems)] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ($Meta _ ($FormS ?elems)) + [_ ($FormS ?elems)] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ @@ -835,10 +900,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (|cons z zs))) + (return (Cons$ z zs))) [($Nil) ($Nil)] - (return (V $Nil nil)) + (return Nil$) [_ _] (fail "Lists don't match in size."))) @@ -846,10 +911,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (|cons (f x y) (map2 f xs* ys*)) + (Cons$ (f x y) (map2 f xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn fold2 [f init xs ys] (|case [xs ys] @@ -867,8 +932,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (V $Cons (T (T idx x) - (enumerate* (inc idx) xs*))) + (Cons$ (P idx x) + (enumerate* (inc idx) xs*)) ($Nil) xs @@ -881,7 +946,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys (get$ $modules state))))) + (return* state (|keys ($get-modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -895,23 +960,23 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - (V $None nil) + None$ (= idx 0) - (V $Some x) + (Some$ x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - (V $None nil) + None$ )) (defn normalize [ident] "(-> Ident (Lux Ident))" (|case ident ["" name] (|do [module get-module-name] - (return (T module name))) + (return (P module name))) _ (return ident))) (defn ident= [x y] @@ -923,12 +988,24 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - (V $None nil) + None$ ($Cons x xs*) (if (= idx 0) - (V $Some (V $Cons (T val xs*))) + (Some$ (Cons$ val xs*)) (|case (|list-put (dec idx) val xs*) - ($None) (V $None nil) - ($Some xs**) (V $Some (V $Cons (T x xs**)))) + ($None) None$ + ($Some xs**) (Some$ (Cons$ x xs**))) ))) + +(defn ensure-1 [m-value] + (|do [output m-value] + (|case output + ($Cons x ($Nil)) + (return x) + + _ + (fail "[Error] Can't expand to other than 1 element.")))) + +(defn cursor$ [file-name line-num column-num] + ($$ P file-name line-num column-num)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 79d2c84f8..4315ea75d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -39,8 +39,12 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] + ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[?form ?type] syntax] (|case ?form + (&a/$unit) + (&&lux/compile-unit compile-expression ?type) + (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) @@ -56,8 +60,11 @@ (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - (&a/$tuple ?elems) - (&&lux/compile-tuple compile-expression ?type ?elems) + (&a/$prod left right) + (&&lux/compile-prod compile-expression ?type left right) + + (&a/$sum tag value) + (&&lux/compile-sum compile-expression ?type tag value) (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -71,9 +78,6 @@ (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) - (&a/$variant ?tag ?members) - (&&lux/compile-variant compile-expression ?type ?tag ?members) - (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) @@ -424,7 +428,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from file-name file-content) state)) + (&/$set-source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -471,7 +475,7 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) + (|case ((&/map% compile-module (&/|list &/prelude-name program-module)) (&/init-state nil)) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 1e5f3a024..72d569ed1 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,26 +76,32 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) - ;; (doto writer - ;; ;; X - ;; (.visitTypeInsn Opcodes/NEW ) ;; XW - ;; (.visitInsn ) ;; WXW - ;; (.visitInsn ) ;; WWXW - ;; (.visitInsn Opcodes/POP) ;; WWX - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W - ;; ) - ) + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature ))))) - wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 - wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 - wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 - wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 - wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 - wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 - wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 - wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + wrap-boolean "java/lang/Boolean" "(Z)" + wrap-byte "java/lang/Byte" "(B)" + wrap-short "java/lang/Short" "(S)" + wrap-int "java/lang/Integer" "(I)" + wrap-long "java/lang/Long" "(J)" + wrap-float "java/lang/Float" "(F)" + wrap-double "java/lang/Double" "(D)" + wrap-char "java/lang/Character" "(C)" + ) + +(do-template [ ] + (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" )))) + + unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" + unwrap-byte "java/lang/Byte" "B" "byteValue" + unwrap-short "java/lang/Short" "S" "shortValue" + unwrap-int "java/lang/Integer" "I" "intValue" + unwrap-long "java/lang/Long" "J" "longValue" + unwrap-float "java/lang/Float" "F" "floatValue" + unwrap-double "java/lang/Double" "D" "doubleValue" + unwrap-char "java/lang/Character" "C" "charValue" ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index dc224f52e..48b35c83a 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) + (let [needed-modules (->> state (&/$get-modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -120,7 +120,7 @@ ;; (prn '_group _group) (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] ;; (prn '[_type _tags] [_type _tags]) - (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + (&/P _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) @@ -132,10 +132,10 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) + (&a-module/define module _name (&/S &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index dd3258059..b30fcb4f8 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -11,7 +11,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] + (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -84,63 +84,62 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$TupleTestAC ?members) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (-> (doto (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)) - (.visitInsn Opcodes/AALOAD) - (compile-match test $next $sub-else) - (.visitLabel $sub-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $next)) - (->> (|let [[idx test] idx+member - $next (new Label) - $sub-else (new Label)]) - (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$ProdTestAC left right) + (let [$post-left (new Label) + $post-right (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (compile-match left $post-left $else) + (.visitLabel $post-left) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (compile-match right $post-right $else) + (.visitLabel $post-right) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target))) - (&a-case/$VariantTestAC ?tag ?count ?test) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (-> (doto (compile-match ?test $value-then $value-else) - (.visitLabel $value-then) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $value-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else)) - (->> (let [$value-then (new Label) - $value-else (new Label)])))) + (&a-case/$SumTestAC ?tag ?count ?test) + (let [$value-then (new Label) + $sum-else (new Label)] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (&&/unwrap-int) + (.visitLdcInsn (int ?tag)) + (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (compile-match ?test $value-then $sum-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $sum-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else))) ))) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] - (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) - (&/T 0 (&/|table) (&/|table)) + ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + ($$ &/P 0 (&/|table) (&/|table)) patterns)] - (&/T mappings (&/|reverse patterns*)))) + (&/P mappings (&/|reverse patterns*)))) (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] - (&/T (&/T ?branch label) - (&/T label ?body)))) + (&/P (&/P ?branch label) + (&/P label ?body)))) mappings) mappings* (&/|map &/|first entries)] (doto writer diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 26ef73cb7..ead44085a 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$TupleT (&/$Nil)) + (&/$UnitT) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean") @@ -421,14 +421,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -455,12 +455,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 83e294c1a..79383acc0 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -28,27 +28,43 @@ ClassWriter MethodVisitor))) +;; [Utils] +(defn ^:private array-of [^MethodVisitor *writer* type-name size] + (do (doto *writer* + (.visitLdcInsn (int size)) + (.visitTypeInsn Opcodes/ANEWARRAY type-name)) + (return nil))) + +(defn ^:private store-at [^MethodVisitor *writer* compile idx value] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + _ (compile value) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return nil))) + ;; [Exports] +(defn compile-unit [compile *type*] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] + (return nil))) + (defn compile-bool [compile *type* ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (try (doto *writer* - (.visitTypeInsn Opcodes/NEW ) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) - (catch Exception e - (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] + :let [_ (doto *writer* + (.visitLdcInsn value) + ())]] (return nil))) - compile-int "java/lang/Long" "(J)V" long - compile-real "java/lang/Double" "(D)V" double - compile-char "java/lang/Character" "(C)V" char + compile-int &&/wrap-long + compile-real &&/wrap-double + compile-char &&/wrap-char ) (defn compile-text [compile *type* ?value] @@ -56,37 +72,28 @@ :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-tuple [compile *type* ?elems] +(defn compile-prod [compile *type* left right] + ;; (prn 'compile-prod (&type/show-type *type*) + ;; (&/adt->text left) + ;; (&/adt->text right)) (|do [^MethodVisitor *writer* &/get-writer - :let [num-elems (&/|length ?elems) - _ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (&/|range num-elems) ?elems)] + _ (array-of *writer* "java/lang/Object" 2) + _ (store-at *writer* compile 0 left) + ;; :let [_ (prn 'compile-prod (&type/show-type *type*) left right)] + _ (store-at *writer* compile 1 right)] (return nil))) -(defn compile-variant [compile *type* ?tag ?value] +(defn compile-sum [compile *type* ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer + _ (array-of *writer* "java/lang/Object" 2) :let [_ (doto *writer* - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) - (.visitLdcInsn ?tag) - (&&/wrap-long) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)))] - _ (compile ?value) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (.visitLdcInsn (int ?tag)) + (&&/wrap-int) + (.visitInsn Opcodes/AASTORE))] + _ (store-at *writer* compile 1 ?value)] (return nil))) (defn compile-local [compile *type* ?idx] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index db73e8bb4..50d8b0011 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -23,6 +23,6 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) - (&/get$ &module/$types module))) + (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&module/$get-types module))) )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 7e2bc6961..cfaa9668b 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -9,83 +9,86 @@ (ns lux.compiler.type (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case]] + (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] [type :as &type]) [lux.analyser.base :as &a])) ;; [Utils] -(defn ^:private variant$ [tag body] - "(-> Text Analysis Analysis)" - (&/T (&/V &a/$variant (&/T tag body)) +(def ^:private unit$ + "Analysis" + (&/P (&/S &a/$unit nil) + &type/$Void)) + +(defn ^:private sum$ [tag body] + "(-> Int Analysis Analysis)" + (&/P (&/S &a/$sum (&/P tag body)) &type/$Void)) -(defn ^:private tuple$ [members] - "(-> (List Analysis) Analysis)" - (&/T (&/V &a/$tuple members) +(defn ^:private prod$ [left right] + "(-> Analysis Analysis Analysis)" + (&/P (&/S &a/$prod (&/P left right)) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V &a/$text text) + (&/P (&/S &a/$text text) &type/$Void)) (def ^:private $Nil "Analysis" - (variant$ &/$Nil (tuple$ (&/|list)))) + (sum$ &/$Nil unit$)) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (variant$ &/$Cons (tuple$ (&/|list head tail)))) + (sum$ &/$Cons (prod$ head tail))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT ?class) - (variant$ &/$DataT (text$ ?class)) + (sum$ &/$DataT (text$ ?class)) - (&/$TupleT ?members) - (variant$ &/$TupleT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) + (&/$ProdT left right) + (sum$ &/$ProdT + (prod$ (->analysis left) + (->analysis right))) - (&/$VariantT ?members) - (variant$ &/$VariantT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) + (&/$SumT left right) + (sum$ &/$SumT + (prod$ (->analysis left) + (->analysis right))) (&/$LambdaT ?input ?output) - (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) + (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output))) (&/$AllT ?env ?name ?arg ?body) - (variant$ &/$AllT - (tuple$ (&/|list (|case ?env - (&/$None) - (variant$ &/$None (tuple$ (&/|list))) + (sum$ &/$AllT + ($$ prod$ + (|case ?env + (&/$None) + (sum$ &/$None unit$) - (&/$Some ??env) - (variant$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body)))) + (&/$Some ??env) + (sum$ &/$Some + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (prod$ (text$ hlabel) + (->analysis htype)) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body))) (&/$BoundT ?name) - (variant$ &/$BoundT (text$ ?name)) + (sum$ &/$BoundT (text$ ?name)) (&/$AppT ?fun ?arg) - (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg))) (&/$NamedT [?module ?name] ?type) - (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) - (->analysis ?type)))) + (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name)) + (->analysis ?type))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index dfd4df23d..d77e9b31c 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,8 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&/S &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base))) ))) (defn ^:private method->type [^Method method] @@ -76,7 +76,7 @@ (&/$LambdaT _ _) (->type-signature function-class) - (&/$TupleT (&/$Nil)) + (&/$VoidT) "V" (&/$NamedT ?name ?type) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index e848cc3fd..91693cc77 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -13,22 +13,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] @@ -58,19 +58,19 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) + (return (&/P meta (&/S $White_Space white-space))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/P meta (&/S $Comment comment))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] - (return (&/T meta comment))) + (return (&/P meta comment))) (|do [;; :let [_ (prn 'pre/_0)] [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] @@ -79,10 +79,10 @@ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] - (return (&/T meta (str pre "#(" inner ")#" post)))))) + (return (&/P meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/P meta (&/S $Comment comment))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -91,7 +91,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/V &/$Meta (&/T meta (&/V token)))))) + (return (&/P meta (&/S token))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -105,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) + (return (&/P meta (&/S $Char token))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) + (return (&/P meta (&/S $Text token))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -119,35 +119,35 @@ [_ local-token] (&reader/read-regex +ident-re+) ? (&module/exists? token)] (if ? - (return (&/T meta (&/T token local-token))) + (return (&/P meta (&/P token local-token))) (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] + (&module/dealias token))] (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/T meta (&/T unaliased local-token))))))) - (return (&/T meta (&/T "" token))) + (return (&/P meta (&/P unaliased local-token))))))) + (return (&/P meta (&/P "" token))) ))) (|do [[meta _] (&reader/read-text ";;") [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/T meta (&/T module-name token)))) + (return (&/P meta (&/P module-name token)))) (|do [[meta _] (&reader/read-text ";") [_ token] (&reader/read-regex +ident-re+)] - (return (&/T meta (&/T "lux" token)))) + (return (&/P meta (&/P &/prelude-name token)))) ))) (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) + (return (&/P meta (&/S $Symbol ident))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) + (return (&/P meta (&/S $Tag ident))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/V &/$Meta (&/T meta (&/V nil)))))) + (return (&/P meta (&/S nil))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index eaa22db20..c40221d63 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -14,22 +14,22 @@ [lexer :as &lexer]))) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] @@ -38,8 +38,8 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - (&/$Meta meta [ _]) - (return (&/V (&/fold &/|++ (&/|list) elems))) + [meta [ _]] + (return (&/S (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -53,9 +53,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ($Close_Brace _)) + [meta ($Close_Brace _)] (if (even? (&/|length elems)) - (return (&/V &/$RecordS (&/|as-pairs elems))) + (return (&/S &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -64,7 +64,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [(&/$Meta meta token*) token]] + :let [[meta token*] token]] (|case token* ($White_Space _) (return (&/|list)) @@ -73,37 +73,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) + (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) + (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value))))) ($Char ^String ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) + (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0))))) ($Text ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) + (return (&/|list (&/P meta (&/S &/$TextS ?value)))) ($Symbol ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) + (return (&/|list (&/P meta (&/S &/$SymbolS ?ident)))) ($Tag ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) + (return (&/|list (&/P meta (&/S &/$TagS ?ident)))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/P meta syntax)))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e3f95b5f9..24a0bf94d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,18 +10,18 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case $$]])) ;; [Tags] -(deftags "" - "No" - "Done" - "Yes") +(deftags + ["No" + "Done" + "Yes"]) ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/get$ &/$source state) + (|case (&/$get-source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/set$ &/$source more state) + (return* (&/$set-source more state) output) ($Yes output line*) - (return* (&/set$ &/$source (&/|cons line* more) state) + (return* (&/$set-source (&/Cons$ line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/get$ &/$source state)) + (|case (body (&/$get-source state)) (&/$Right reader* match) - (return* (&/set$ &/$source reader* state) + (return* (&/$set-source reader* state) match) (&/$Left msg) @@ -85,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) match)) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) match)) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) match) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -98,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2))) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2)) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -110,7 +110,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/V &/$Left "[Reader Error] EOF") + (&/S &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -120,10 +120,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line) reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) - (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/P (&/cursor$ file-name line-num column-num) (str prefix match)))))) + (&/S &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -133,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/V $Done (&/T (&/T file-name line-num column-num) text)) - (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) - (&/T (&/T file-name line-num column-num*) line))))) - (&/V $No (str "[Reader Error] Text failed: " text)))))) + (&/S $Done (&/P (&/cursor$ file-name line-num column-num) text)) + (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) text) + (&/P (&/cursor$ file-name line-num column-num*) line))))) + (&/S $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] @@ -144,7 +144,7 @@ file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/T (&/T file-name (inc line-num) 0) + (&/P (&/cursor$ file-name (inc line-num) 0) line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index 9f3adb036..4193d8df4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -10,7 +10,7 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case $$]])) (declare show-type) @@ -26,302 +26,300 @@ _ false)) -(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(def ^:private no-env (&/V &/$None nil)) +(def ^:private empty-env (&/Some$ &/Nil$)) +(def ^:private no-env &/None$) +(def Ident$ &/P) (defn Data$ [name] - (&/V &/$DataT name)) + (&/S &/$DataT name)) (defn Bound$ [name] - (&/V &/$BoundT name)) + (&/S &/$BoundT name)) (defn Var$ [id] - (&/V &/$VarT id)) + (&/S &/$VarT id)) (defn Lambda$ [in out] - (&/V &/$LambdaT (&/T in out))) + (&/S &/$LambdaT (&/P in out))) (defn App$ [fun arg] - (&/V &/$AppT (&/T fun arg))) -(defn Tuple$ [members] + (&/S &/$AppT (&/P fun arg))) +(defn Prod$ [left right] ;; (assert (|list? members)) - (&/V &/$TupleT members)) -(defn Variant$ [members] + (&/S &/$ProdT (&/P left right))) +(defn Sum$ [left right] ;; (assert (|list? members)) - (&/V &/$VariantT members)) + (&/S &/$SumT (&/P left right))) (defn All$ [env name arg body] - (&/V &/$AllT (&/T env name arg body))) + (&/S &/$AllT ($$ &/P env name arg body))) (defn Named$ [name type] - (&/V &/$NamedT (&/T name type))) + (&/S &/$NamedT (&/P name type))) - -(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) -(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) -(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) -(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) -(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) -(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) -(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) +(def Bool (Named$ (Ident$ &/prelude-name "Bool") (Data$ "java.lang.Boolean"))) +(def Int (Named$ (Ident$ &/prelude-name "Int") (Data$ "java.lang.Long"))) +(def Real (Named$ (Ident$ &/prelude-name "Real") (Data$ "java.lang.Double"))) +(def Char (Named$ (Ident$ &/prelude-name "Char") (Data$ "java.lang.Character"))) +(def Text (Named$ (Ident$ &/prelude-name "Text") (Data$ "java.lang.String"))) +(def Unit (Named$ (Ident$ &/prelude-name "Unit") (&/S &/$UnitT nil))) +(def $Void (Named$ (Ident$ &/prelude-name "Void") (&/S &/$VoidT nil))) +(def Ident (Named$ (Ident$ &/prelude-name "Ident") (Prod$ Text Text))) (def IO - (Named$ (&/T "lux/data" "IO") + (Named$ (Ident$ "lux/data" "IO") (All$ empty-env "IO" "a" (Lambda$ Unit (Bound$ "a"))))) (def List - (Named$ (&/T "lux" "List") + (Named$ (Ident$ &/prelude-name "List") (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (Sum$ + ;; lux;Nil + Unit + ;; lux;Cons + (Prod$ (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a"))) + )))) (def Maybe - (Named$ (&/T "lux" "Maybe") + (Named$ (Ident$ &/prelude-name "Maybe") (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (Sum$ + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + )))) (def Type - (Named$ (&/T "lux" "Type") + (Named$ (Ident$ &/prelude-name "Type") (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) - TypePair (Tuple$ (&/|list Type Type))] + TypeEnv (App$ List (Prod$ Text Type)) + TypePair (Prod$ Type Type)] (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) - ;; AppT - TypePair - ;; NamedT - (Tuple$ (&/|list Ident Type)) - ))) + ($$ Sum$ + ;; VoidT + Unit + ;; UnitT + Unit + ;; SumT + TypePair + ;; ProdT + TypePair + ;; DataT + Text + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + ($$ Prod$ (App$ Maybe TypeEnv) Text Text Type) + ;; AppT + TypePair + ;; NamedT + (Prod$ Ident Type) + )) $Void)))) (def Bindings - (Named$ (&/T "lux" "Bindings") + (Named$ (Ident$ &/prelude-name "Bindings") (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v")))))))))) + (Prod$ + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Prod$ (Bound$ "k") + (Bound$ "v")))))))) (def Env - (Named$ (&/T "lux" "Env") + (Named$ (Ident$ &/prelude-name "Env") (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) + ($$ Prod$ + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + )))))) (def Cursor - (Named$ (&/T "lux" "Cursor") - (Tuple$ (&/|list Text Int Int)))) + (Named$ (Ident$ &/prelude-name "Cursor") + ($$ Prod$ Text Int Int))) (def Meta - (Named$ (&/T "lux" "Meta") + (Named$ (Ident$ &/prelude-name "Meta") (All$ empty-env "lux;Meta" "m" (All$ no-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v"))))))))) + (Prod$ (Bound$ "m") + (Bound$ "v")))))) (def AST* - (Named$ (&/T "lux" "AST'") + (Named$ (Ident$ &/prelude-name "AST'") (let [AST* (App$ (Bound$ "w") (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) + ($$ Sum$ + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Prod$ AST* AST*)) + ))))) (def AST - (Named$ (&/T "lux" "AST") + (Named$ (Ident$ &/prelude-name "AST") (let [w (App$ Meta Cursor)] (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (Named$ (&/T "lux" "Either") + (Named$ (Ident$ &/prelude-name "Either") (All$ empty-env "lux;Either" "l" (All$ no-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r"))))))) + (Sum$ + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r")))))) (def StateE (All$ empty-env "lux;StateE" "s" (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ "s") - (Bound$ "a")))))))) + (Prod$ (Bound$ "s") + (Bound$ "a"))))))) (def Source - (Named$ (&/T "lux" "Source") + (Named$ (Ident$ &/prelude-name "Source") (App$ List (App$ (App$ Meta Cursor) Text)))) (def Host - (Named$ (&/T "lux" "Host") - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom"))))) + (Named$ (Ident$ &/prelude-name "Host") + ($$ Prod$ + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom")))) (def DefData* (All$ empty-env "lux;DefData'" "" - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - )))) + ($$ Sum$ + ;; "lux;ValueD" + (Prod$ Type Unit) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + ))) (def LuxVar - (Named$ (&/T "lux" "LuxVar") - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident)))) + (Named$ (Ident$ &/prelude-name "LuxVar") + (Sum$ + ;; "lux;Local" + Int + ;; "lux;Global" + Ident))) (def $Module (All$ empty-env "lux;$Module" "Compiler" - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) + ($$ Prod$ + ;; "lux;module-aliases" + (App$ List (Prod$ Text Text)) + ;; "lux;defs" + (App$ List + (Prod$ Text + (Prod$ Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Prod$ Text + ($$ Prod$ Int + (App$ List Ident) + Type))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Prod$ Text + (Prod$ (App$ List Ident) + Type))) + ))) (def $Compiler - (Named$ (&/T "lux" "Compiler") + (Named$ (Ident$ &/prelude-name "Compiler") (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) + ($$ Prod$ + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Prod$ Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Prod$ LuxVar Type))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + )) $Void))) (def Macro - (Named$ (&/T "lux" "Macro") + (Named$ (Ident$ &/prelude-name "Macro") (Lambda$ ASTList (App$ (App$ StateE $Compiler) ASTList)))) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [type (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -332,7 +330,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [type* (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -343,32 +341,37 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] + (if-let [tvar (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) - ts)) - state) + (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/Some$ type) %) + ts)) + state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/$get-type-vars) (&/$get-mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) - state) + (let [id (->> state &/$get-type-vars &/$get-counter)] + (return* (&/$update-type-vars #(do ;; (prn 'create-var/_0 (&/adt->text %)) + ;; (prn 'create-var/_1 (&/adt->text (->> % (&/$update-counter inc)))) + ;; (prn 'create-var/_2 (&/adt->text (->> % + ;; (&/$update-counter inc) + ;; (&/$update-mappings (fn [ms] (&/|put id &/None$ ms)))))) + (->> % + (&/$update-counter inc) + (&/$update-mappings (fn [ms] (&/|put id &/None$ ms))))) + state) id)))) (def existential (|do [seed &/gen-id] - (return (&/V &/$ExT seed)))) + (return (&/S &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -390,19 +393,19 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V &/$None nil))) + (return (&/P ?id &/None$)) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/T ?id (&/V &/$Some ?type**))))) + (return (&/P ?id (&/Some$ ?type**))))) )))) - (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] + (->> state (&/$get-type-vars) (&/$get-mappings)))] (fn [state] - (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) - state) + (return* (&/$update-type-vars #(->> % + (&/$update-counter dec) + (&/$set-mappings (&/|remove id mappings*))) + state) nil))) state)))) @@ -435,13 +438,15 @@ =param (clean* ?tid ?param)] (return (App$ =lambda =param))) - (&/$TupleT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Tuple$ =members))) - - (&/$VariantT ?members) - (|do [=members (&/map% (partial clean* ?tid) ?members)] - (return (Variant$ =members))) + (&/$SumT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (Sum$ =left =right))) + + (&/$ProdT ?left ?right) + (|do [=left (clean* ?tid ?left) + =right (clean* ?tid ?right)] + (return (Prod$ =left =right))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -451,9 +456,9 @@ (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) + (return (&/P k =v)))) ?env*)] - (return (&/V &/$Some clean-env)))) + (return (&/Some$ clean-env)))) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -473,37 +478,36 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T ??out (&/|cons ?in ?args))) + (&/P ??out (&/Cons$ ?in ?args))) _ - (&/T type (&/|list)))) + (&/P type (&/|list)))) (defn ^:private unravel-app [fun-type] (|case fun-type (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] - (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) + (&/P ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/T fun-type (&/|list)))) + (&/P fun-type (&/|list)))) (defn show-type [^objects type] (|case type + (&/$VoidT) + "(|)" + + (&/$UnitT) + "(,)" + (&/$DataT name) (str "(^ " name ")") - (&/$TupleT elems) - (if (&/|empty? elems) - "(,)" - (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$VariantT cases) - (if (&/|empty? cases) - "(|)" - (str "(| " (->> cases - (&/|map show-type) - (&/|interpose " ") - (&/fold str "")) ")")) + (&/$ProdT left right) + (str "(, " (show-type left) " " (show-type right) ")") + + (&/$SumT left right) + (str "(| " (show-type left) " " (show-type right) ")") (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] @@ -547,15 +551,13 @@ [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [(&/$TupleT xelems) (&/$TupleT yelems)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xelems yelems) + [(&/$ProdT xleft xright) (&/$ProdT yleft yright)] + (and (type= xleft yleft) + (type= xright yright)) - [(&/$VariantT xcases) (&/$VariantT ycases)] - (&/fold2 (fn [old x y] (and old (type= x y))) - true - xcases ycases) + [(&/$SumT xleft xright) (&/$SumT yleft yright)] + (and (type= xleft yleft) + (type= xright yright)) [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) @@ -607,17 +609,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - (&/V &/$None nil) + &/None$ (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/V &/$Some v*) + (&/Some$ v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/|cons (&/T k v) fixpoints)) + (&/Cons$ (&/P k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -626,11 +628,11 @@ (defn beta-reduce [env type] (|case type - (&/$VariantT ?members) - (Variant$ (&/|map (partial beta-reduce env) ?members)) + (&/$SumT ?left ?right) + (Sum$ (beta-reduce env ?left) (beta-reduce env ?right)) - (&/$TupleT ?members) - (Tuple$ (&/|map (partial beta-reduce env) ?members)) + (&/$ProdT ?left ?right) + (Prod$ (beta-reduce env ?left) (beta-reduce env ?right)) (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -638,7 +640,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) + (All$ (&/Some$ env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -697,30 +699,32 @@ (def ^:private init-fixpoints (&/|list)) (defn ^:private check* [class-loader fixpoints expected actual] + ;; (prn 'check*/_0 (&/adt->text expected) (&/adt->text actual)) + ;; (prn 'check*/_1 (show-type expected) (show-type actual)) (if (clojure.lang.Util/identical expected actual) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (|case [expected actual] [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/V &/$Some ebound)) + (return* state* (&/Some$ ebound)) (&/$Left _) - (return* state (&/V &/$None nil)))) + (return* state &/None$))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/V &/$Some abound)) + (return* state* (&/Some$ abound)) (&/$Left _) - (return* state (&/V &/$None nil))))] + (return* state &/None$)))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] - (return (&/T fixpoints nil))) + (return (&/P fixpoints nil))) [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) @@ -735,7 +739,7 @@ (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) - (return* state* (&/T fixpoints nil)) + (return* state* (&/P fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -746,7 +750,7 @@ (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) - (return* state* (&/T fixpoints nil)) + (return* state* (&/P fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -757,9 +761,9 @@ (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)] + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state) (&/$Right state* output) (return* state* output) @@ -780,11 +784,11 @@ (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/T fixpoints nil))) + ;; (return (&/P fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] @@ -799,14 +803,14 @@ e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) + ;; (return (&/P fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] @@ -821,17 +825,17 @@ e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/T fixpoints** nil))) + (return (&/P fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/T fixpoints** nil))) + ;; (return (&/P fixpoints** nil))) [(&/$AppT F A) _] - (let [fp-pair (&/T expected actual) + (let [fp-pair (&/P expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] @@ -844,7 +848,7 @@ (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (check-error expected actual))) (&/$None) @@ -870,39 +874,33 @@ [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) + (return (&/P fixpoints nil))) [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [(&/$TupleT e!members) (&/$TupleT a!members)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!members a!members)] - (return (&/T fixpoints* nil))) + [(&/$ProdT e!left e!right) (&/$ProdT a!left a!right)] + (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) + [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] + (return (&/P fixpoints** nil))) - [(&/$VariantT e!cases) (&/$VariantT a!cases)] - (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] - (return fp*))) - fixpoints - e!cases a!cases)] - (return (&/T fixpoints* nil))) + [(&/$SumT e!left e!right) (&/$SumT a!left a!right)] + (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) + [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] + (return (&/P fixpoints** nil))) [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) - (return (&/T fixpoints nil)) + (return (&/P fixpoints nil)) (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] @@ -958,20 +956,31 @@ )) (defn variant-case [tag type] + ;; (prn 'variant-case tag (show-type type)) (|case type (&/$NamedT ?name ?type) (variant-case tag ?type) - (&/$VariantT ?cases) - (|case (&/|at tag ?cases) - (&/$Some case-type) - (return case-type) + (&/$SumT ?left ?right) + (case tag + 0 + (return ?left) - (&/$None) - (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) + 1 + (|case ?right + (&/$SumT ?left* _) + (return ?left*) + + _ + (return ?right)) + + ;; else + (variant-case (dec tag) ?right)) _ - (fail (str "[Type Error] Type is not a variant: " (show-type type))))) + (fail (str "[Type Error] Type is not a variant: " (show-type type))) + ;; (assert false (str "[Type Error] Type is not a variant: " (show-type type))) + )) (defn type-name [type] "(-> Type (Lux Ident))" -- cgit v1.2.3 From 82b019a5b5f547f3b321642ce687d8aec59e802e Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 17:41:45 -0400 Subject: - Restructuring how sums & products work [part 2] --- src/lux/analyser/case.clj | 28 +++++++++++++++++++++++----- src/lux/analyser/lambda.clj | 8 ++++---- src/lux/analyser/module.clj | 31 ++++++++++++++----------------- src/lux/base.clj | 4 ++-- src/lux/compiler/base.clj | 1 + src/lux/compiler/case.clj | 25 +++++++++++++++++-------- src/lux/compiler/lux.clj | 4 ++-- src/lux/type.clj | 14 +++++++++++++- 8 files changed, 76 insertions(+), 39 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index aab25d741..212f02665 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -25,6 +25,7 @@ "RealTotal" "CharTotal" "TextTotal" + "UnitTotal" "ProdTotal" "SumTotal"] ) @@ -36,6 +37,7 @@ "RealTestAC" "CharTestAC" "TextTestAC" + "UnitTestAC" "ProdTestAC" "SumTestAC"] ) @@ -113,11 +115,14 @@ type* (adjust-type type) idx (&module/tag-index =module =name) group (&module/tag-group =module =name) + ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))] case-type (&type/variant-case idx type*)] (return ($$ &/P idx (&/|length group) case-type)))) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[_ pattern*] pattern] + (|let [[_ pattern*] pattern + ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))] + ] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type @@ -153,6 +158,11 @@ =kont kont] (return (&/P (&/S $TextTestAC ?value) =kont))) + (&/$TupleS (&/$Nil)) + (|do [_ (&type/check value-type &type/Unit) + =kont kont] + (return (&/P (&/S $UnitTestAC nil) =kont))) + (&/$TupleS (&/$Cons ?_left ?tail)) (|do [value-type* (adjust-type value-type)] (|case value-type* @@ -168,7 +178,7 @@ _ (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))] (return (&/P =right =kont))))] - (return (&/P (&/S $ProdTestAC =left =right) =kont))) + (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) _ (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) @@ -182,8 +192,7 @@ [=test =kont] (analyse-pattern case-type unit kont)] (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] - ?values)) + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) (|do [[idx group-count case-type] (resolve-tag ?ident value-type) [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) @@ -240,6 +249,12 @@ [($TextTotal total? ?values) ($TextTestAC ?value)] (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) + [($DefaultTotal total?) ($UnitTestAC)] + (return (&/S $UnitTotal nil)) + + [($UnitTotal) ($UnitTestAC)] + (return (&/S $UnitTotal nil)) + [($DefaultTotal total?) ($ProdTestAC ?left ?right)] (|do [:let [_default (&/S $DefaultTotal total?)] =left (merge-total _default (&/P ?left ?body)) @@ -301,6 +316,9 @@ ($TextTotal ?total _) (return ?total) + ($UnitTotal) + (return true) + ($ProdTotal ?total ?_left ?_right) (if ?total (return true) @@ -329,7 +347,7 @@ (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") _ - (check-totality ?right ($SumTotal ?total ?tail)))] + (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))] (return (and =left =right))) _ diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 696c816e9..b30953f67 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -30,10 +30,10 @@ (->> frame (&/$get-closure) (&/$get-counter)) register)) register-type)] - (do (prn 'close-over 'updating-closure - [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] - [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) - (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) + (do ;; (prn 'close-over 'updating-closure + ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] + ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) + ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) ($$ &/P register* (&/$update-closure #(->> % (&/$update-counter inc) (&/$update-mappings (fn [mps] (&/|put name register* mps)))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 909e7e2c4..bc9647f9f 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -349,20 +349,17 @@ nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(defn tag-index [module tag-name] - "(-> Text Text (Lux Int))" - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - -(defn tag-group [module tag-name] - "(-> Text Text (Lux (List Ident)))" - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) +(do-template [ ] + (defn [module tag-name] + + (fn [state] + (if-let [=module (->> state (&/$get-modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] + (|let [[idx tags type] idx+tags] + (return* state )) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + + tag-index idx "(-> Text Text (Lux Int))" + tag-group tags "(-> Text Text (Lux (List Ident)))" + ) diff --git a/src/lux/base.clj b/src/lux/base.clj index 2f0925586..d261145ae 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -21,7 +21,7 @@ (defmacro deftags [names] (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) ~idx)))) + `(def ~(symbol (str "$" name)) (int ~idx))))) (defn ^:private unfold-accesses ([elems] @@ -793,7 +793,7 @@ (defn with-writer [writer body] (fn [state] - (prn 'with-writer writer body) + ;; (prn 'with-writer writer body) (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] (|case output ($Right ?state ?value) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 72d569ed1..e327d1de4 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -94,6 +94,7 @@ (do-template [ ] (defn [^MethodVisitor writer] (doto writer + (.visitTypeInsn Opcodes/CHECKCAST ) (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" )))) unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index b30fcb4f8..0a928a056 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -84,27 +84,36 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$UnitTestAC) + (doto writer + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target)) + (&a-case/$ProdTestAC left right) (let [$post-left (new Label) - $post-right (new Label)] + $post-right (new Label) + $pre-else (new Label)] (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) (.visitInsn Opcodes/AALOAD) - (compile-match left $post-left $else) + (compile-match left $post-left $pre-else) (.visitLabel $post-left) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) (.visitInsn Opcodes/AALOAD) - (compile-match right $post-right $else) + (compile-match right $post-right $pre-else) (.visitLabel $post-right) (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target))) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $pre-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else))) (&a-case/$SumTestAC ?tag ?count ?test) (let [$value-then (new Label) - $sum-else (new Label)] + $pre-else (new Label)] (doto writer (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") (.visitInsn Opcodes/DUP) @@ -112,15 +121,15 @@ (.visitInsn Opcodes/AALOAD) (&&/unwrap-int) (.visitLdcInsn (int ?tag)) - (.visitJumpInsn Opcodes/IF_ICMPNE $sum-else) + (.visitJumpInsn Opcodes/IF_ICMPNE $else) (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 1)) (.visitInsn Opcodes/AALOAD) - (compile-match ?test $value-then $sum-else) + (compile-match ?test $value-then $pre-else) (.visitLabel $value-then) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $sum-else) + (.visitLabel $pre-else) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $else))) ))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 79383acc0..10ee40839 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -138,7 +138,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT - (&&/wrap-long) + (&&/wrap-int) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -165,7 +165,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT - (&&/wrap-long) + (&&/wrap-int) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/type.clj b/src/lux/type.clj index 4193d8df4..91bc6e480 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -548,6 +548,12 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] + [(&/$UnitT) (&/$UnitT)] + true + + [(&/$VoidT) (&/$VoidT)] + true + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) @@ -704,6 +710,9 @@ (if (clojure.lang.Util/identical expected actual) (return (&/P fixpoints nil)) (|case [expected actual] + [(&/$UnitT) (&/$UnitT)] + (return (&/P fixpoints nil)) + [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) (return (&/P fixpoints nil)) @@ -840,7 +849,7 @@ (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] (|let [[e a] pair] - (str (show-type e) ":+:" + (str (show-type e) " :+: " (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) @@ -909,6 +918,9 @@ [_ (&/$NamedT ?aname ?atype)] (check* class-loader fixpoints expected ?atype) + [_ (&/$VoidT)] + (return (&/P fixpoints nil)) + [_ _] (fail (check-error expected actual)) ))) -- cgit v1.2.3 From 37a9044d8ec523a282c0470d65380ce5cff27084 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 23 Aug 2015 20:27:51 -0400 Subject: - Restructuring how sums & products work [part 3] --- src/lux/analyser/case.clj | 11 ++++------- src/lux/analyser/lux.clj | 22 +++++++++++++--------- src/lux/type.clj | 4 ++-- 3 files changed, 19 insertions(+), 18 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 212f02665..6bb767d3e 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -120,8 +120,8 @@ (return ($$ &/P idx (&/|length group) case-type)))) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[_ pattern*] pattern - ;; :let [_ (prn 'analyse-pattern (&/adt->text pattern*) (&type/show-type value-type))] + (|let [[meta pattern*] pattern + ;; _ (prn 'analyse-pattern (&/show-ast pattern) (&type/show-type value-type)) ] (|case pattern* (&/$SymbolS "" name) @@ -130,9 +130,6 @@ idx &env/next-local-idx] (return (&/P (&/S $StoreTestAC idx) =kont))) - (&/$SymbolS ident) - (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) - (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] @@ -176,7 +173,7 @@ (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") _ - (analyse-pattern ?right (&/S &/$TupleS ?tail) kont))] + (analyse-pattern ?right (&/P meta (&/S &/$TupleS ?tail)) kont))] (return (&/P =right =kont))))] (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) @@ -185,7 +182,7 @@ (&/$RecordS pairs) (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/S &/$TupleS ?members) kont)) + (analyse-pattern value-type (&/P meta (&/S &/$TupleS ?members)) kont)) (&/$TagS ?ident) (|do [[idx group-count case-type] (resolve-tag ?ident value-type) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index f7ed07ee4..20e435eb3 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -209,7 +209,11 @@ (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] + ;; :let [_ (prn 'analyse-local/_0 name) + ;; _ (prn 'analyse-local/_1 name (&type/show-type exo-type) (&type/show-type btype))] + _ (&type/check exo-type btype) + ;; :let [_ (prn 'analyse-local/_2 name 'CHECKED)] + ] (return (&/|list =local))) (&/$set-envs (&/|++ inner* outer) state)))) )))) @@ -273,14 +277,14 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - ;; :let [_ (when (or (= "defsig" (aget real-name 1)) - ;; ;; (= "type" (aget real-name 1)) - ;; ;; (= &&/$struct r-name) - ;; ) - ;; (->> (&/|map &/show-ast macro-expansion) - ;; (&/|interpose "\n") - ;; (&/fold str "") - ;; (prn (&/ident->text real-name))))] + :let [_ (when (or (= "using" (aget real-name 1)) + ;; (= "type" (aget real-name 1)) + ;; (= &&/$struct r-name) + ) + (->> (&/|map &/show-ast macro-expansion) + (&/|interpose "\n") + (&/fold str "") + (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 91bc6e480..37f3a99d4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -685,7 +685,7 @@ (apply-type ?type param) _ - (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type Error] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -947,7 +947,7 @@ (apply-lambda ?type param) _ - (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) + (fail (str "[Type Error] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] -- cgit v1.2.3 From f403ee7a9662f81c91aa124f0573c5957a88ebe5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 06:37:46 -0400 Subject: Due to several performance issues and my inability to optimize them away due to too many corner cases, I decided the abandon the path towards a more mathematical implementation of tuples & variants. --- src/lux/analyser.clj | 401 ++++++++++++++------------- src/lux/analyser/base.clj | 230 ++++++++-------- src/lux/analyser/case.clj | 380 ++++++++++++++------------ src/lux/analyser/env.clj | 38 +-- src/lux/analyser/host.clj | 158 +++++------ src/lux/analyser/lambda.clj | 22 +- src/lux/analyser/lux.clj | 277 ++++++++++--------- src/lux/analyser/module.clj | 266 +++++++++--------- src/lux/analyser/record.clj | 122 ++++++++- src/lux/base.clj | 529 ++++++++++++++++-------------------- src/lux/compiler.clj | 18 +- src/lux/compiler/base.clj | 45 ++-- src/lux/compiler/cache.clj | 8 +- src/lux/compiler/case.clj | 92 +++---- src/lux/compiler/host.clj | 26 +- src/lux/compiler/lux.clj | 79 +++--- src/lux/compiler/module.clj | 4 +- src/lux/compiler/type.clj | 89 +++--- src/lux/host.clj | 6 +- src/lux/lexer.clj | 66 ++--- src/lux/parser.clj | 62 ++--- src/lux/reader.clj | 54 ++-- src/lux/type.clj | 645 +++++++++++++++++++++----------------------- 23 files changed, 1826 insertions(+), 1791 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 41a59fc00..8c88328f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail return* fail* |case $$]] + (lux [base :as & :refer [|let |do return fail return* fail* |case]] [reader :as &reader] [parser :as &parser] [type :as &type] @@ -23,24 +23,24 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] - (&/$Cons [_ (&/$TextS ?ex-class)] - (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] - (&/$Cons ?catch-body - (&/$Nil))))))] - (return (&/P (&/|++ catch+ (&/|list ($$ &/P ?ex-class ?ex-arg ?catch-body))) finally+)) - - [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] - (&/$Cons ?finally-body - (&/$Nil))))] - (return (&/P catch+ (&/Some$ ?finally-body))) + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) + (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) + (&/$Cons ?catch-body + (&/$Nil))))))) + (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) + (&/$Cons ?finally-body + (&/$Nil))))) + (return (&/T catch+ (&/V &/$Some ?finally-body))) _ (fail (str "[Analyser Error] Wrong syntax for exception handler: " (&/show-ast token))))) (defn ^:private parse-tag [ast] (|case ast - [_ (&/$TagS "" name)] + (&/$Meta _ (&/$TagS "" name)) (return name) _ @@ -49,44 +49,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] - (&/$Cons [_ (&/$SymbolS _ ?class)] - (&/$Cons [_ (&/$IntS ?length)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) + (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) + (&/$Cons (&/$Meta _ (&/$IntS ?length)) (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] + (&/$Cons (&/$Meta _ (&/$IntS ?idx)) (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TextS ?super-class)] - (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) + (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) + (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] - (&/$Cons [_ (&/$TextS ?name)] - (&/$Cons [_ (&/$TupleS ?supers)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) + (&/$Cons (&/$Meta _ (&/$TextS ?name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] - (&/$Cons [_ (&/$SymbolS "" ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -97,86 +97,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -185,106 +185,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] - (&/$Cons [_ (&/$TextS ?class)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?field)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?field)) (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] - (&/$Cons [_ (&/$TupleS ?args)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] - (&/$Cons [_ (&/$TextS ?class)] - (&/$Cons [_ (&/$TextS ?method)] - (&/$Cons [_ (&/$TupleS ?classes)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) + (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$Cons (&/$Meta _ (&/$TextS ?method)) + (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) (&/$Cons ?object - (&/$Cons [_ (&/$TupleS ?args)] + (&/$Cons (&/$Meta _ (&/$TupleS ?args)) (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/P (&/|list) &/None$) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -295,53 +295,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -351,63 +351,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -418,60 +418,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] - (&/$Cons [_ (&/$SymbolS "" ?self)] - (&/$Cons [_ (&/$SymbolS "" ?arg)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] - (&/$Cons [_ (&/$SymbolS "" ?name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] - (&/$Cons [_ (&/$TupleS tags)] - (&/$Cons [_ (&/$SymbolS "" type-name)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) + (&/$Cons (&/$Meta _ (&/$TupleS tags)) + (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] - (&/$Cons [_ (&/$TextS ?path)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) + (&/$Cons (&/$Meta _ (&/$TextS ?path)) (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] - (&/$Cons [_ (&/$SymbolS "" ?ident)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) + (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] - (&/$Cons [_ (&/$TextS ?alias)] - (&/$Cons [_ (&/$TextS ?module)] + (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) + (&/$Cons (&/$Meta _ (&/$TextS ?alias)) + (&/$Cons (&/$Meta _ (&/$TextS ?module)) (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -483,23 +483,23 @@ ;; Standard special forms (&/$BoolS ?value) (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/P (&/S &&/$bool ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) (&/$IntS ?value) (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/P (&/S &&/$int ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) (&/$RealS ?value) (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/P (&/S &&/$real ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) (&/$CharS ?value) (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/P (&/S &&/$char ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) (&/$TextS ?value) (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/P (&/S &&/$text ?value) exo-type)))) + (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse exo-type ?elems) @@ -528,21 +528,20 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - [meta ?token] + (&/$Meta meta ?token) (fn [state] - (|case ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) - ;; (catch Error e - ;; (prn e) - ;; (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) + (catch Error e + (prn e) + (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) (&/$Right state* output) (return* state* output) (&/$Left "") - (fail* (add-loc (&/$get-cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) + (fail* (add-loc (&/get$ &/$cursor state) (str "[Analyser Error] Unrecognized token: " (&/show-ast token)))) (&/$Left msg) - (fail* (add-loc (&/$get-cursor state) msg)) + (fail* (add-loc (&/get$ &/$cursor state) msg)) )) )) @@ -554,44 +553,42 @@ [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/P ?output-term ?output-type*))) - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type*))) + (return (&/T ?output-term ?output-type))) [_ _] - (return (&/P ?output-term ?output-type))) + (return (&/T ?output-term ?output-type))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - ;; (prn 'analyse-ast (&/adt->text token)) ;; (prn 'analyse-ast (&/show-ast token)) - (|let [[cursor _] token] - (&/with-cursor cursor - (&/with-expected-type exo-type - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/P module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - [meta (&/$FormS (&/$Cons ?fn ?args))] - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) + (&/with-cursor (aget token 1 0) + (&/with-expected-type exo-type + (|case token + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 622f0b853..fe1e0d55b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -13,120 +13,120 @@ [type :as &type]))) ;; [Tags] -(deftags - ["bool" - "int" - "real" - "char" - "text" - "unit" - "sum" - "prod" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - ]) +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) ;; [Exports] (defn expr-type [syntax+] @@ -147,4 +147,4 @@ (|do [module* (if (.equals "" ?module) &/get-module-name (return ?module))] - (return (&/P module* ?name))))) + (return (&/T module* ?name))))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 6bb767d3e..483002adc 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -9,7 +9,7 @@ (ns lux.analyser.case (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |do return fail |let |case $$]] + (lux [base :as & :refer [deftags |do return fail |let |case]] [parser :as &parser] [type :as &type]) (lux.analyser [base :as &&] @@ -18,33 +18,31 @@ [record :as &&record]))) ;; [Tags] -(deftags - ["DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "UnitTotal" - "ProdTotal" - "SumTotal"] +(deftags "" + "DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal" ) -(deftags - ["StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "UnitTestAC" - "ProdTestAC" - "SumTestAC"] +(deftags "" + "StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC" ) ;; [Utils] (def ^:private unit - (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS (&/|list)))) + (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) (defn ^:private resolve-type [type] (|case type @@ -66,229 +64,269 @@ _ (&type/actual-type type))) -(let [cleaner (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/S &/$BoundT _aarg))] - (&type/clean* _avar _abody))))] - (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) - (|case type - (&/$AllT _aenv _aname _aarg _abody) - (&type/with-var - (fn [$var] - (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ ($$ &/P _aenv _aname _aarg $var) up) =type)))) - - (&/$SumT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (&/fold% cleaner ?left up) - =right (&/fold% cleaner ?right up)] - (return (&type/Prod$ =left =right))) - - (&/$AppT ?tfun ?targ) - (|do [=type (&type/apply-type ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$VarT ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (fail "##9##")))] - (adjust-type* up type*)) - - (&/$NamedT ?name ?type) - (adjust-type* up ?type) - - _ - (assert false (prn 'adjust-type* (&type/show-type type))) - ))) +(defn adjust-type* [up type] + "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + ;; (prn 'adjust-type* (&type/show-type type)) + (|case type + (&/$AllT _aenv _aname _aarg _abody) + (&type/with-var + (fn [$var] + (|do [=type (&type/apply-type type $var)] + (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + + (&/$TupleT ?members) + (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&type/Tuple$ (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$VariantT ?members) + (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] + (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (&type/clean* _avar _abody)))) + type + up)] + (return (&/V &/$VariantT (&/|map (fn [v] + (&/fold (fn [_abody ena] + (|let [[_aenv _aname _aarg _avar] ena] + (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + v + up)) + ?members*)))) + + (&/$AppT ?tfun ?targ) + (|do [=type (&type/apply-type ?tfun ?targ)] + (adjust-type* up =type)) + + (&/$VarT ?id) + (|do [type* (&/try-all% (&/|list (&type/deref ?id) + (fail "##9##")))] + (adjust-type* up type*)) + + (&/$NamedT ?name ?type) + (adjust-type* up ?type) + + _ + (assert false (prn 'adjust-type* (&type/show-type type))) + )) (defn adjust-type [type] "(-> Type (Lux Type))" (adjust-type* (&/|list) type)) -(defn ^:private resolve-tag [tag type] - (|do [[=module =name] (&&/resolved-ident tag) - type* (adjust-type type) - idx (&module/tag-index =module =name) - group (&module/tag-group =module =name) - ;; :let [_ (prn 'resolve-tag =module =name (&/adt->text group))] - case-type (&type/variant-case idx type*)] - (return ($$ &/P idx (&/|length group) case-type)))) - (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[meta pattern*] pattern - ;; _ (prn 'analyse-pattern (&/show-ast pattern) (&type/show-type value-type)) - ] + (|let [(&/$Meta _ pattern*) pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type kont) idx &env/next-local-idx] - (return (&/P (&/S $StoreTestAC idx) =kont))) + (return (&/T (&/V $StoreTestAC idx) =kont))) + + (&/$SymbolS ident) + (fail (str "[Pattern-matching Error] Symbols must be unqualified: " (&/ident->text ident))) (&/$BoolS ?value) (|do [_ (&type/check value-type &type/Bool) =kont kont] - (return (&/P (&/S $BoolTestAC ?value) =kont))) + (return (&/T (&/V $BoolTestAC ?value) =kont))) (&/$IntS ?value) (|do [_ (&type/check value-type &type/Int) =kont kont] - (return (&/P (&/S $IntTestAC ?value) =kont))) + (return (&/T (&/V $IntTestAC ?value) =kont))) (&/$RealS ?value) (|do [_ (&type/check value-type &type/Real) =kont kont] - (return (&/P (&/S $RealTestAC ?value) =kont))) + (return (&/T (&/V $RealTestAC ?value) =kont))) (&/$CharS ?value) (|do [_ (&type/check value-type &type/Char) =kont kont] - (return (&/P (&/S $CharTestAC ?value) =kont))) + (return (&/T (&/V $CharTestAC ?value) =kont))) (&/$TextS ?value) (|do [_ (&type/check value-type &type/Text) =kont kont] - (return (&/P (&/S $TextTestAC ?value) =kont))) + (return (&/T (&/V $TextTestAC ?value) =kont))) - (&/$TupleS (&/$Nil)) - (|do [_ (&type/check value-type &type/Unit) - =kont kont] - (return (&/P (&/S $UnitTestAC nil) =kont))) - - (&/$TupleS (&/$Cons ?_left ?tail)) + (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] + (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) + (|case value-type* + (&/$TupleT ?member-types) + (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont))))) + + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + + (&/$RecordS pairs) + (|do [?members (&&record/order-record pairs) + ;; :let [_ (prn 'PRE (&type/show-type value-type))] + value-type* (adjust-type value-type) + ;; :let [_ (prn 'POST (&type/show-type value-type*))] + ;; value-type* (resolve-type value-type) + ] (|case value-type* - (&/$ProdT ?left ?right) - (|do [[=left [=right =kont]] (analyse-pattern ?left ?_left - (|do [[=right =kont] (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (analyse-pattern ?right ?_right kont) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Tuple has wrong size.") - - _ - (analyse-pattern ?right (&/P meta (&/S &/$TupleS ?tail)) kont))] - (return (&/P =right =kont))))] - (return (&/P (&/S $ProdTestAC (&/P =left =right)) =kont))) + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/|cons =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T (&/|list) =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) _ - (fail (str "[Pattern-matching Error] Tuples require product-types: " (&type/show-type value-type*))))) - - (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/P meta (&/S &/$TupleS ?members)) kont)) + (fail "[Pattern-matching Error] Record requires record-type."))) (&/$TagS ?ident) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) - [=test =kont] (analyse-pattern case-type unit kont)] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) - - (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [[idx group-count case-type] (resolve-tag ?ident value-type) + (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#01")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#02")] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#03")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#04")] + [=test =kont] (analyse-pattern case-type unit kont) + ;; :let [_ (println "#05")] + ] + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + ?values)) + (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] + [=module =name] (&&/resolved-ident ?ident) + ;; :let [_ (println "#11")] + value-type* (adjust-type value-type) + ;; :let [_ (println "#12" (&type/show-type value-type*))] + idx (&module/tag-index =module =name) + group (&module/tag-group =module =name) + ;; :let [_ (println "#13")] + case-type (&type/variant-case idx value-type*) + ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (&/|length ?values) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/P (&/cursor$ "" -1 -1) (&/S &/$TupleS ?values)) kont)) + (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) ;; :let [_ (println "#15")] ] - (return (&/P (&/S $SumTestAC ($$ &/P idx group-count =test)) =kont))) + (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/Cons$ pattern+body patterns)))) + (return (&/|cons pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] (|let [[test ?body] test+body] (|case [struct test] [($DefaultTotal total?) ($StoreTestAC ?idx)] - (return (&/S $DefaultTotal true)) + (return (&/V $DefaultTotal true)) [[?tag [total? ?values]] ($StoreTestAC ?idx)] - (return (&/S ?tag (&/P true ?values))) + (return (&/V ?tag (&/T true ?values))) [($DefaultTotal total?) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/|list ?value)))) + (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/S $BoolTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/|list ?value)))) + (return (&/V $IntTotal (&/T total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/S $IntTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/|list ?value)))) + (return (&/V $RealTotal (&/T total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/S $RealTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/|list ?value)))) + (return (&/V $CharTotal (&/T total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/S $CharTotal (&/P total? (&/Cons$ ?value ?values)))) + (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/|list ?value)))) + (return (&/V $TextTotal (&/T total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/S $TextTotal (&/P total? (&/Cons$ ?value ?values)))) - - [($DefaultTotal total?) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($UnitTotal) ($UnitTestAC)] - (return (&/S $UnitTotal nil)) - - [($DefaultTotal total?) ($ProdTestAC ?left ?right)] - (|do [:let [_default (&/S $DefaultTotal total?)] - =left (merge-total _default (&/P ?left ?body)) - =right (merge-total _default (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($ProdTotal total? ?_left ?_right) ($ProdTestAC ?left ?right)] - (|do [=left (merge-total ?_left (&/P ?left ?body)) - =right (merge-total ?_right (&/P ?right ?body))] - (return (&/S $ProdTotal ($$ &/P total? =left =right)))) - - [($DefaultTotal total?) ($SumTestAC ?tag ?count ?test)] - (|do [sub-struct (merge-total (&/S $DefaultTotal total?) - (&/P ?test ?body)) - structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/S $DefaultTotal total?))) + (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) + + [($DefaultTotal total?) ($TupleTestAC ?tests)] + (|do [structs (&/map% (fn [t] + (merge-total (&/V $DefaultTotal total?) (&/T t ?body))) + ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + + [($TupleTotal total? ?values) ($TupleTestAC ?tests)] + (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) + (|do [structs (&/map2% (fn [v t] + (merge-total v (&/T t ?body))) + ?values ?tests)] + (return (&/V $TupleTotal (&/T total? structs)))) + (fail "[Pattern-matching Error] Inconsistent tuple-size.")) + + [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] + (|do [sub-struct (merge-total (&/V $DefaultTotal total?) + (&/T ?test ?body)) + structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count (&/V $DefaultTotal total?))) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) - [($SumTotal total? ?branches) ($SumTestAC ?tag ?count ?test)] + [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) (&/$Some sub) sub (&/$None) - (&/S $DefaultTotal total?)) - (&/P ?test ?body)) + (&/V $DefaultTotal total?)) + (&/T ?test ?body)) structs (|case (&/|list-put ?tag sub-struct ?branches) (&/$Some list) (return list) (&/$None) (fail "[Pattern-matching Error] YOLO"))] - (return (&/S $SumTotal (&/P total? structs)))) + (return (&/V $VariantTotal (&/T total? structs)))) )))) (defn ^:private check-totality [value-type struct] @@ -313,39 +351,33 @@ ($TextTotal ?total _) (return ?total) - ($UnitTotal) - (return true) - - ($ProdTotal ?total ?_left ?_right) + ($TupleTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] (|case value-type* - (&/$ProdT ?left ?right) - (|do [=left (check-totality ?left ?_left) - =right (check-totality ?right ?_right)] - (return (and =left =right))) + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Tuple is not total.")))) - ($SumTotal ?total ?structs) + ($VariantTotal ?total ?structs) (if ?total (return true) (|do [value-type* (resolve-type value-type)] - (|case [value-type* ?structs] - [(&/$SumT ?left ?right) (&/$Cons ?_left ?tail)] - (|do [=left (check-totality ?left ?_left) - =right (|case ?tail - (&/$Cons ?_right (&/$Nil)) - (check-totality ?right ?_right) - - (&/$Nil) - (fail "[Pattern-matching Error] Pattern-matching mismatch. Variant has wrong size.") - - _ - (check-totality ?right (&/S $SumTotal (&/P ?total ?tail))))] - (return (and =left =right))) + (|case value-type* + (&/$VariantT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + ;; (prn '$VariantTotal + ;; (&/adt->text sub-struct) + ;; (&type/show-type ?member)) + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Variant is not total.")))) @@ -362,7 +394,7 @@ (analyse-branch analyse exo-type value-type pattern body patterns))) (&/|list) branches) - struct (&/fold% merge-total (&/S $DefaultTotal false) patterns) + struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] (if ? (return patterns) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 5686700e3..4e9dcd79f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,31 +15,31 @@ ;; [Exports] (def next-local-idx (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-counter))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] ;; (prn 'with-local name) (fn [state] ;; (prn 'with-local name) - (let [old-mappings (->> state (&/$get-envs) &/|head (&/$get-locals) (&/$get-mappings)) - =return (body (&/$update-envs - (fn [stack] - (let [bound-unit (&/S &&/$var (&/S &/$Local (->> (&/|head stack) (&/$get-locals) (&/$get-counter))))] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [m] (&/|put name (&/P bound-unit type) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] + (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) + =return (body (&/update$ &/$envs + (fn [stack] + (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/|head stack)) + (&/|tail stack)))) + state))] (|case =return (&/$Right ?state ?value) - (return* (&/$update-envs (fn [stack*] - (&/Cons$ (&/$update-locals #(->> % - (&/$update-counter dec) - (&/$set-mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) + (return* (&/update$ &/$envs (fn [stack*] + (&/|cons (&/update$ &/$locals #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings old-mappings)) + (&/|head stack*)) + (&/|tail stack*))) + ?state) ?value) _ @@ -47,4 +47,4 @@ (def captured-vars (fn [state] - (return* state (->> state (&/$get-envs) &/|head (&/$get-closure) (&/$get-mappings))))) + (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$closure) (&/get$ &/$mappings))))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 69aa95f12..64f297994 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -20,7 +20,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - [_ (&/$TextS ?text)] + (&/$Meta _ (&/$TextS ?text)) (return ?text) _ @@ -32,7 +32,7 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -47,20 +47,20 @@ "(-> Type Type)" (|case type (&/$DataT class) - (&type/Data$ (&type/as-obj class)) + (&/V &/$DataT (&type/as-obj class)) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&type/Data$ ) - output-type (&type/Data$ )] + (let [input-type (&/V &/$DataT ) + output-type (&/V &/$DataT )] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S (&/P =x =y)) output-type)))))) + (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -108,7 +108,7 @@ =type (&host/lookup-static-field class-loader ?class ?field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getstatic (&/P ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) (defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] (|do [class-loader &/loader @@ -116,7 +116,7 @@ =object (&&/analyse-1 analyse ?object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-getfield ($$ &/P ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) (defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] (|do [class-loader &/loader @@ -124,7 +124,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putstatic ($$ &/P ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) (defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] (|do [class-loader &/loader @@ -133,7 +133,7 @@ =value (&&/analyse-1 analyse =type ?value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-putfield ($$ &/P ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) (defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] (|do [class-loader &/loader @@ -143,31 +143,31 @@ ;; [[&/$DataT _return-class]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class) _arg)) + (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokestatic ($$ &/P ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-instanceof (&/P ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) (do-template [ ] (defn [analyse exo-type ?class ?method ?classes ?object ?args] (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -179,73 +179,73 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&type/Data$ ?class) ?object) + =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&type/Data$ ?c) ?o)) + (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-invokespecial ($$ &/P ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] (|do [=object (analyse-1+ analyse ?object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null? =object) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null")] + (|do [:let [output-type (&/V &/$DataT "null")] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-null nil) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&type/Data$ ?class)] + :let [output-type (&/V &/$DataT ?class)] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S &&/$jvm-new ($$ &/P ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/P (&/S &&/$jvm-new-array (&/P ?class ?length)) (&/S "array" (&/P (&type/Data$ ?class) - (&/S &/$Nil nil))))))) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) =elem (analyse-1+ analyse ?elem) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aastore ($$ &/P =array ?idx =elem)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) (defn analyse-jvm-aaload [analyse ?array ?idx] (|do [=array (analyse-1+ analyse ?array) =array-type (&&/expr-type =array)] - (return (&/|list (&/P (&/S &&/$jvm-aaload (&/P =array ?idx)) =array-type))))) + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - [_ (&/$TextS "public")] + (&/$Meta _ (&/$TextS "public")) (return (assoc so-far :visibility "public")) - [_ (&/$TextS "private")] + (&/$Meta _ (&/$TextS "private")) (return (assoc so-far :visibility "private")) - [_ (&/$TextS "protected")] + (&/$Meta _ (&/$TextS "protected")) (return (assoc so-far :visibility "protected")) - [_ (&/$TextS "static")] + (&/$Meta _ (&/$TextS "static")) (return (assoc so-far :static? true)) - [_ (&/$TextS "final")] + (&/$Meta _ (&/$TextS "final")) (return (assoc so-far :final? true)) - [_ (&/$TextS "abstract")] + (&/$Meta _ (&/$TextS "abstract")) (return (assoc so-far :abstract? true)) - [_ (&/$TextS "synchronized")] + (&/$Meta _ (&/$TextS "synchronized")) (return (assoc so-far :concurrency "synchronized")) - [_ (&/$TextS "volatile")] + (&/$Meta _ (&/$TextS "volatile")) (return (assoc so-far :concurrency "volatile")) _ @@ -275,10 +275,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) + (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) + (&/$Nil)))))) (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -289,18 +289,18 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] + [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) + (&/$Cons ?method-body + (&/$Nil))))))))] (|do [=method-inputs (&/map% (fn [minput] (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/P ?input-name ?input-type)) + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) + (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) + (&/$Nil))))) + (return (&/T ?input-name ?input-type)) _ (fail "[Analyser Error] Wrong syntax for method input."))) @@ -309,14 +309,14 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype)) + (&&env/with-local iname (&/V &/$DataT (as-otype itype)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/Cons$ (&/P "this" ?super-class) + (&/|cons (&/T ";this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -327,18 +327,18 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/S &&/$jvm-class ($$ &/P ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?inputs)] - (&/$Cons [_ (&/$TextS ?output)] - (&/$Cons [_ (&/$TupleS ?modifiers)] - (&/$Nil))))))] + (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) + (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) + (&/$Cons (&/$Meta _ (&/$TextS ?output)) + (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) + (&/$Nil))))))) (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -349,29 +349,29 @@ _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) ?methods) - _ (compile-token (&/S &&/$jvm-interface ($$ &/P ?name =supers =methods)))] + _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] - (return ($$ &/P ?ex-class idx =catch-body)))) + (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (|case ?finally - (&/$None) (return &/None$) + =finally (|case [?finally] + (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/Some$ =finally))))] - (return (&/|list (&/P (&/S &&/$jvm-try ($$ &/P =body =catches =finally)) exo-type))))) + (return (&/V &/$Some =finally))))] + (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable") _type)] - (return (&/|list (&/P (&/S &&/$jvm-throw =ex) &type/$Void))))) + _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] (defn [analyse exo-type ?monitor] @@ -379,18 +379,18 @@ _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S =monitor) output-type))))) + (return (&/|list (&/T (&/V =monitor) output-type))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit ) (do-template [ ] - (let [output-type (&type/Data$ )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S =value) output-type)))))) + (return (&/|list (&/T (&/V =value) output-type)))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -413,11 +413,11 @@ ) (do-template [ ] - (let [output-type (&type/Data$ )] + (let [output-type (&/V &/$DataT )] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ ) ?value) + (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) _ (&type/check exo-type output-type)] - (return (&/|list (&/P (&/S =value) output-type)))))) + (return (&/|list (&/T (&/V =value) output-type)))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" @@ -436,7 +436,7 @@ (defn analyse-jvm-program [analyse compile-token ?args ?body] (|do [=body (&/with-scope "" - (&&env/with-local ?args (&type/App$ &type/List &type/Text) - (&&/analyse-1 analyse (&type/App$ &type/IO &type/Unit) ?body))) - _ (compile-token (&/S &&/$jvm-program =body))] + (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) + (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] (return (&/|list)))) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index b30953f67..aeb5a4814 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -9,7 +9,7 @@ (ns lux.analyser.lambda (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|let |do return fail |case $$]] + (lux [base :as & :refer [|let |do return fail |case]] [host :as &host]) (lux.analyser [base :as &&] [env :as &env]))) @@ -22,19 +22,15 @@ (&env/with-local arg arg-type (|do [=return body =captured &env/captured-vars] - (return ($$ &/P scope-name =captured =return)))))))) + (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] (|let [[_ register-type] register - register* (&/P (&/S &&/$captured ($$ &/P scope - (->> frame (&/$get-closure) (&/$get-counter)) - register)) + register* (&/T (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)) register-type)] - (do ;; (prn 'close-over 'updating-closure - ;; [(->> frame (&/$get-closure) (&/$get-counter)) (->> frame (&/$get-closure) (&/$get-counter) inc)] - ;; [(->> frame (&/$get-closure) (&/$get-mappings) &/ident->text) - ;; (->> frame (&/$get-closure) (&/$get-mappings) (&/|put name register*) &/ident->text)]) - ($$ &/P register* (&/$update-closure #(->> % - (&/$update-counter inc) - (&/$update-mappings (fn [mps] (&/|put name register* mps)))) - frame))))) + (&/T register* (&/update$ &/$closure #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) + frame)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 20e435eb3..d241201f4 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -10,7 +10,7 @@ (:require (clojure [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return return* fail fail* |let |list |case $$]] + (lux [base :as & :refer [|do return return* fail fail* |let |list |case]] [parser :as &parser] [type :as &type] [host :as &host]) @@ -27,64 +27,52 @@ (|do [=expr (&&/analyse-1 analyse $var ?token) :let [[?item ?type] =expr] =type (&type/clean $var ?type)] - (return (&/P ?item =type)))))) + (return (&/T ?item =type)))))) (defn ^:private with-cursor [cursor form] (|case form - [_ syntax] - (&/P cursor syntax))) + (&/$Meta _ syntax) + (&/V &/$Meta (&/T cursor syntax)))) ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - ;; (prn 'analyse-tuple/_0 (&type/show-type exo-type) (->> ?elems (&/|map &/show-ast) (&/->seq))) - (|case ?elems - (&/$Nil) - (|do [_ (&type/check exo-type &type/Unit)] - (return (&/|list (&/P (&/S &&/$unit nil) - exo-type)))) - - (&/$Cons single (&/$Nil)) - (fail (str "Tuples can't have only 1 element: " (&/show-ast single))) - - (&/$Cons head tail) - (|do [exo-type* (&type/actual-type exo-type) - ;; :let [_ (prn 'analyse-tuple/_0.25_0 (&/show-ast head) (&/adt->text exo-type*)) - ;; _ (prn 'analyse-tuple/_0.25_1 (&/show-ast head) (&type/show-type exo-type*))] - ] - (|case exo-type* - (&/$ProdT ?left ?right) - (|do [;; :let [_ (prn 'analyse-tuple/_0.5 (&/show-ast head) (&type/show-type ?left))] - =left (&&/analyse-1 analyse ?left head) - ;; :let [_ (prn 'analyse-tuple/_1 =left (&type/show-type ?left))] - =right (|case tail - (&/$Nil) - (fail "Tuples has wrong size.") - - (&/$Cons single (&/$Nil)) - (&&/analyse-1 analyse ?right single) - - _ - (&/ensure-1 (analyse-tuple analyse ?right tail))) - ;; :let [_ (prn 'analyse-tuple/_2 =right (&type/show-type ?right))] - ] - (return (&/|list (&/P (&/S &&/$prod (&/P =left =right)) - exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) - (&/$AllT _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) + (&/$AllT _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))))) - )) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) + +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (|case ?values + (&/$Nil) + (analyse-tuple analyse exo-type (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse exo-type ?values) + )] + (|case output + (&/$Cons x (&/$Nil)) + (return x) + + _ + (fail "[Analyser Error] Can't expand to other than 1 element.")))) (defn analyse-variant [analyse exo-type idx ?values] - ;; (prn 'analyse-variant/_0 - ;; (&type/show-type exo-type) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] @@ -95,41 +83,82 @@ _ (&type/actual-type exo-type))] (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (analyse-variant-body analyse vtype ?values)] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + (&/$AllT _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] (analyse-variant analyse exo-type** idx ?values)))) - - ?variant - (|do [;; :let [_ (prn 'analyse-variant/_1 - ;; (&type/show-type ?variant) - ;; idx - ;; (->> ?values (&/|map &/show-ast) (&/->seq)))] - vtype (&type/variant-case idx ?variant) - ;; :let [_ (prn 'analyse-variant/_2 - ;; idx - ;; (&type/show-type vtype))] - =value (&/ensure-1 (|case ?values - (&/$Nil) - (analyse-tuple analyse vtype (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse vtype ?value) - - _ - (analyse-tuple analyse vtype ?values))) - ;; :let [_ (prn 'analyse-variant/_3 - ;; idx - ;; =value)] - ] - (return (&/|list (&/P (&/S &&/$sum (&/P idx =value)) - exo-type)))) - ))) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) +;; (defn analyse-variant [analyse exo-type ident ?values] +;; (|do [exo-type* (|case exo-type +;; (&/$VarT ?id) +;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] +;; (&type/actual-type exo-type*)) +;; (|do [_ (&type/set-var ?id &type/Type)] +;; (&type/actual-type &type/Type)))) + +;; _ +;; (&type/actual-type exo-type))] +;; (|case exo-type* +;; (&/$VariantT ?cases) +;; (|do [?tag (&&/resolved-ident ident)] +;; (if-let [vtype (&/|get ?tag ?cases)] +;; (|do [=value (analyse-variant-body analyse vtype ?values)] +;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) +;; exo-type)))) +;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) + +;; (&/$AllT _) +;; (&type/with-var +;; (fn [$var] +;; (|do [exo-type** (&type/apply-type exo-type* $var)] +;; (analyse-variant analyse exo-type** ident ?values)))) + +;; _ +;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [exo-type* (|case exo-type + (&/$VarT ?id) + (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + + (&/$AllT _) + (|do [$var &type/existential + =type (&type/apply-type exo-type $var)] + (&type/actual-type =type)) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [=type (&type/apply-type exo-type $var)] + ;; (&type/actual-type =type)))) + + _ + (&type/actual-type exo-type)) + types (|case exo-type* + (&/$TupleT ?table) + (return ?table) + + _ + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) + _ (&/assert! (= (&/|length types) (&/|length ?elems)) + (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) + members (&&record/order-record ?elems) + =members (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + types members)] + (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -148,17 +177,14 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] - (|let [stack (&/$get-envs state) - no-binding? #(do ;; (prn 'analyse-local/_ (->> % &/adt->text)) - ;; (prn 'analyse-local/_1 (->> % (&/$get-locals) &/adt->text)) - ;; (prn 'analyse-local/_2 (->> % (&/$get-closure) &/adt->text)) - (and (->> % (&/$get-locals) (&/$get-mappings) (&/|contains? name) not) - (->> % (&/$get-closure) (&/$get-mappings) (&/|contains? name) not))) + (|let [stack (&/get$ &/$envs state) + no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) + (->> % (&/get$ &/$closure) (&/get$ &/$mappings) (&/|contains? name) not)) [inner outer] (&/|split-with no-binding? stack)] (|case outer (&/$Nil) @@ -167,8 +193,8 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/$get-locals) (&/$get-mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/$get-locals) (&/$get-mappings) (&/|get name))] + (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) (|case global [(&/$Global ?module* name*) _] @@ -187,35 +213,32 @@ (clojure.lang.Util/identical &type/Type exo-type)) (return nil) (&type/check exo-type endo-type))] - (return (&/|list (&/P (&/S &&/$var (&/S &/$Global (&/P r-module r-name))) + (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) endo-type)))) state) - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) + [_] + (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) (fail* "_{_ analyse-symbol _}_"))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/$get-name %2) %1) - (&/|map #(&/$get-name %) outer) + (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/P register* (&/Cons$ frame* new-inner)))) - (&/P (or (->> top-outer (&/$get-locals) (&/$get-mappings) (&/|get name)) - (->> top-outer (&/$get-closure) (&/$get-mappings) (&/|get name))) + (&/T register* (&/|cons frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] ((|do [btype (&&/expr-type =local) - ;; :let [_ (prn 'analyse-local/_0 name) - ;; _ (prn 'analyse-local/_1 name (&type/show-type exo-type) (&type/show-type btype))] - _ (&type/check exo-type btype) - ;; :let [_ (prn 'analyse-local/_2 name 'CHECKED)] - ] + _ (&type/check exo-type btype)] (return (&/|list =local))) - (&/$set-envs (&/|++ inner* outer) state)))) + (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -230,7 +253,7 @@ (|case ?args (&/$Nil) (|do [_ (&type/check exo-type fun-type)] - (return (&/P fun-type (&/|list)))) + (return (&/T fun-type (&/|list)))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -248,15 +271,15 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/S &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] (&type/clean $var =output-t)))] - (return (&/P type** =args))) + (return (&/T type** =args))) )))) (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/P =output-t (&/Cons$ =arg =args)))) + (return (&/T =output-t (&/|cons =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -277,25 +300,25 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] - :let [_ (when (or (= "using" (aget real-name 1)) - ;; (= "type" (aget real-name 1)) - ;; (= &&/$struct r-name) - ) - (->> (&/|map &/show-ast macro-expansion) - (&/|interpose "\n") - (&/fold str "") - (prn (&/ident->text real-name))))] + ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; ;; (= "type" (aget real-name 1)) + ;; ;; (= &&/$struct r-name) + ;; ) + ;; (->> (&/|map &/show-ast macro-expansion) + ;; (&/|interpose "\n") + ;; (&/fold str "") + ;; (prn (&/ident->text real-name))))] ] (&/flat-map% (partial analyse exo-type) macro-expansion)) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t)))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/P (&/S &&/$apply (&/P =fn =args)) + (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) =output-t))))) ))) @@ -306,7 +329,7 @@ =value (analyse-1+ analyse ?value) =value-type (&&/expr-type =value) =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] - (return (&/|list (&/P (&/S &&/$case (&/P =value =match)) + (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] @@ -325,7 +348,7 @@ (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t (&&/analyse-1 analyse ?return-t ?body))] - (return (&/P (&/S &&/$lambda ($$ &/P =scope =captured =body)) exo-type*))) + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) _ (fail (str "[Analyser Error] Functions require function types: " @@ -347,22 +370,22 @@ ] (|case dtype (&/$BoundT ?vname) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$ExT _) - (return (&/P _expr exo-type)) + (return (&/T _expr exo-type)) (&/$VarT ?_id) (|do [?? (&type/bound? ?_id)] - ;; (return (&/P _expr exo-type)) + ;; (return (&/T _expr exo-type)) (if ?? (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) - (return (&/P _expr exo-type))) + (return (&/T _expr exo-type))) ) _ (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) - (return (&/P _expr exo-type)))))))) + (return (&/T _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] @@ -395,7 +418,7 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/S &&/$def (&/P ?name =value))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) _ (println 'DEF (str module-name ";" ?name))]] (return (&/|list))))) @@ -405,16 +428,16 @@ (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] module-name &/get-module-name ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/S &&/$declare-macro (&/P module-name ?name))) + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] (return (&/|list)))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/P module-name type-name)) (&/->seq tags) (&/adt->text def-data))] + ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) @@ -446,7 +469,7 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] @@ -454,5 +477,5 @@ ==type (eval! =type) _ (&type/check exo-type ==type) =value (analyse-1+ analyse ?value)] - (return (&/|list (&/P (&/S &&/$ann (&/P =value =type)) + (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index bc9647f9f..d23953f5e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -12,70 +12,69 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [defrtags |let |do return return* fail fail* |case $$]] + (lux [base :as & :refer [deftags |let |do return return* fail fail* |case]] [type :as &type] [host :as &host]))) ;; [Utils] -(defrtags - ["module-aliases" - "defs" - "imports" - "tags" - "types"]) +(deftags "" + "module-aliases" + "defs" + "imports" + "tags" + "types") (def ^:private +init+ - ($$ &/P - ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - (&/|list) - ;; "lux;tags" - (&/|table) - ;; "lux;types" - (&/|table) - )) + (&/T ;; "lux;module-aliases" + (&/|table) + ;; "lux;defs" + (&/|table) + ;; "lux;imports" + (&/|list) + ;; "lux;tags" + (&/|table) + ;; "lux;types" + (&/|table) + )) ;; [Exports] (defn add-import [module] "(-> Text (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($update-imports (partial &/Cons$ module) m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/update$ $imports (partial &/|cons module) m)) + ms)) + state) nil)))) (defn set-imports [imports] "(-> (List Text) (Lux (,)))" (|do [current-module &/get-module-name] (fn [state] - (return* (&/$update-modules - (fn [ms] - (&/|update current-module - (fn [m] ($set-imports imports m)) - ms)) - state) + (return* (&/update$ &/$modules + (fn [ms] + (&/|update current-module + (fn [m] (&/set$ $imports imports m)) + ms)) + state) nil)))) (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P false def-data) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T false def-data) %) + m)) + ms)))) nil) _ @@ -84,8 +83,8 @@ (defn def-type [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _)] (return* state &type/Type) @@ -105,31 +104,31 @@ (defn type-def [module name] "(-> Text Text (Lux Type))" (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module))] - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|case $def [_ (&/$TypeD _type)] (return* state _type) _ - (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/P module name))))) - (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/P module name))))) + (fail* (str "[Analyser Error] Not a type: " (&/ident->text (&/T module name))))) + (fail* (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T module name))))) (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update a-module - (fn [m] - ($update-defs - #(&/|put a-name (&/P false (&/S &/$AliasD (&/P r-module r-name))) %) - m)) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update a-module + (fn [m] + (&/update$ $defs + #(&/|put a-name (&/T false (&/V &/$AliasD (&/T r-module r-name))) %) + m)) + ms)))) nil) _ @@ -138,30 +137,26 @@ (defn exists? [name] "(-> Text (Lux Bool))" (fn [state] - ;; (prn 'exists?/_0 &/$modules name) - ;; (prn 'exists?/_2 (&/adt->text state)) - ;; (prn 'exists?/_3 (&/adt->text (->> state (&/$get-modules)))) - ;; (prn 'exists?/_4 (&/adt->text (->> state (&/$get-modules) (&/|contains? name)))) (return* state - (->> state (&/$get-modules) (&/|contains? name))))) + (->> state (&/get$ &/$modules) (&/|contains? name))))) (defn alias [module alias reference] (fn [state] (return* (->> state - (&/$update-modules - (fn [ms] - (&/|update module - #($update-module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) nil))) (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] - (if-let [real-name (->> state (&/$get-modules) (&/|get current-module) ($get-module-aliases) (&/|get name))] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] (return* state real-name) (fail* (str "Unknown alias: " name)))))) @@ -169,9 +164,9 @@ (|do [current-module &/get-module-name] (fn [state] ;; (prn 'find-def/_0 module name 'current-module current-module) - (if-let [$module (->> state (&/$get-modules) (&/|get module))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module ($get-defs) (&/|get name))] + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] (|let [[exported? $$def] $def] (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) (if (or exported? (.equals ^Object current-module module)) @@ -182,7 +177,7 @@ state)) _ - (return* state (&/P (&/P module name) $$def))) + (return* state (&/T (&/T module name) $$def))) (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) @@ -203,7 +198,7 @@ (defn declare-macro [module name] (fn [state] - (if-let [$module (->> state (&/$get-modules) (&/|get module) ($get-defs))] + (if-let [$module (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))] (if-let [$def (&/|get name $module)] (|case $def [exported? (&/$ValueD ?type _)] @@ -213,15 +208,15 @@ (.getField &/datum-field) (.get nil))]] (fn [state*] - (return* (&/$update-modules - (fn [$modules] - (&/|update module - (fn [m] - ($update-defs - #(&/|put name (&/P exported? (&/S &/$MacroD macro)) %) - m)) - $modules)) - state*) + (return* (&/update$ &/$modules + (fn [$modules] + (&/|update module + (fn [m] + (&/update$ $defs + #(&/|put name (&/T exported? (&/V &/$MacroD macro)) %) + m)) + $modules)) + state*) nil))) state) @@ -235,21 +230,21 @@ (defn export [module name] (fn [state] - (|case (&/$get-envs state) + (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) - (if-let [$def (->> state (&/$get-modules) (&/|get module) ($get-defs) (&/|get name))] + (if-let [$def (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs) (&/|get name))] (|case $def [true _] (fail* (str "[Analyser Error] Definition has already been exported: " module ";" name)) [false ?data] (return* (->> state - (&/$update-modules (fn [ms] - (&/|update module (fn [m] - ($update-defs - #(&/|put name (&/P true ?data) %) - m)) - ms)))) + (&/update$ &/$modules (fn [ms] + (&/|update module (fn [m] + (&/update$ $defs + #(&/|put name (&/T true ?data) %) + m)) + ms)))) nil)) (fail* (str "[Analyser Error] Can't export an inexistent definition: " (str module &/+name-separator+ name)))) @@ -265,61 +260,61 @@ (do ;; (prn 'defs k ?exported?) (|case ?def (&/$AliasD ?r-module ?r-name) - ($$ &/P ?exported? k (str "A" ?r-module ";" ?r-name)) + (&/T ?exported? k (str "A" ?r-module ";" ?r-name)) (&/$MacroD _) - ($$ &/P ?exported? k "M") + (&/T ?exported? k "M") (&/$TypeD _) - ($$ &/P ?exported? k "T") + (&/T ?exported? k "T") _ - ($$ &/P ?exported? k "V"))))) - (->> state (&/$get-modules) (&/|get module) ($get-defs))))))) + (&/T ?exported? k "V"))))) + (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs))))))) (def imports (|do [module &/get-module-name] (fn [state] - (return* state (->> state (&/$get-modules) (&/|get module) ($get-imports)))))) + (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports)))))) (defn create-module [name] "(-> Text (Lux (,)))" (fn [state] - (return* (&/$update-modules #(&/|put name +init+ %) state) nil))) + (return* (&/update$ &/$modules #(&/|put name +init+ %) state) nil))) (defn enter-module [name] "(-> Text (Lux (,)))" (fn [state] (return* (->> state - (&/$update-modules #(&/|put name +init+ %)) - (&/$set-envs (&/|list (&/env name)))) + (&/update$ &/$modules #(&/|put name +init+ %)) + (&/set$ &/$envs (&/|list (&/env name)))) nil))) -(do-template [ ] +(do-template [ ] (defn [module] (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (return* state ( =module)) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (return* state (&/get$ =module)) (fail* (str "[Lux Error] Unknown module: " module))) )) - tags-by-module $get-tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" - types-by-module $get-types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" + tags-by-module $tags "(-> Text (Lux (List (, Text (, Int (List Text) Type)))))" + types-by-module $types "(-> Text (Lux (List (, Text (, (List Text) Type)))))" ) (defn ensure-undeclared-tags [module tags] (|do [tags-table (tags-by-module module) _ (&/map% (fn [tag] (if (&/|get tag tags-table) - (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/P module tag)))) + (fail (str "[Analyser Error] Can't re-declare tag: " (&/ident->text (&/T module tag)))) (return nil))) tags)] (return nil))) (defn ensure-undeclared-type [module name] (|do [types-table (types-by-module module) - _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/P module name))))] + _ (&/assert! (nil? (&/|get name types-table)) (str "[Analyser Error] Can't re-declare type: " (&/ident->text (&/T module name))))] (return nil))) (defn declare-tags [module tag-names type] @@ -332,34 +327,37 @@ (str "[Module Error] Can't define tags for a type belonging to a foreign module: " (&/ident->text type-name))) _ (ensure-undeclared-type _module _name)] (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (let [tags (&/|map (fn [tag-name] (&/P module tag-name)) tag-names)] - (return* (&/$update-modules - (fn [=modules] - (&/|update module - #(->> % - ($set-tags (&/fold (fn [table idx+tag-name] - (|let [[idx tag-name] idx+tag-name] - (&/|put tag-name ($$ &/P idx tags type) table))) - ($get-tags %) - (&/enumerate tag-names))) - ($update-types (partial &/|put _name (&/P tags type)))) - =modules)) - state) + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (let [tags (&/|map (fn [tag-name] (&/T module tag-name)) tag-names)] + (return* (&/update$ &/$modules + (fn [=modules] + (&/|update module + #(->> % + (&/set$ $tags (&/fold (fn [table idx+tag-name] + (|let [[idx tag-name] idx+tag-name] + (&/|put tag-name (&/T idx tags type) table))) + (&/get$ $tags %) + (&/enumerate tag-names))) + (&/update$ $types (partial &/|put _name (&/T tags type)))) + =modules)) + state) nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(do-template [ ] - (defn [module tag-name] - - (fn [state] - (if-let [=module (->> state (&/$get-modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name ($get-tags =module))] - (|let [[idx tags type] idx+tags] - (return* state )) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/P module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - - tag-index idx "(-> Text Text (Lux Int))" - tag-group tags "(-> Text Text (Lux (List Ident)))" - ) +(defn tag-index [module tag-name] + "(-> Text Text (Lux Int))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 0)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + +(defn tag-group [module tag-name] + "(-> Text Text (Lux (List Ident)))" + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags 1)) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 96c988544..2b4b7e095 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -13,6 +13,122 @@ (lux.analyser [base :as &&] [module :as &&module]))) +;; [Tags] +(deftags "" + "bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr" + + ) + ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" @@ -20,7 +136,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [[_ (&/$TagS tag1)] _] _) + (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -28,9 +144,9 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [[_ (&/$TagS k)] v] + [(&/$Meta _ (&/$TagS k)) v] (|do [=k (&&/resolved-ident k)] - (return (&/P (&/ident->text =k) v))) + (return (&/T (&/ident->text =k) v))) _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) diff --git a/src/lux/base.clj b/src/lux/base.clj index d261145ae..6247524af 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -11,157 +11,99 @@ [clojure.core.match :as M :refer [matchv]] clojure.core.match.array)) -;; [ADTs] -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) - -(defmacro deftags [names] - (assert (vector? names)) +;; [Tags] +(defmacro deftags [prefix & names] `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) (int ~idx))))) - -(defn ^:private unfold-accesses - ([elems] - (unfold-accesses 1 (count elems) elems)) - ([begin end elems] - (if (= begin end) - (list elems) - (cons (take begin elems) - (unfold-accesses (inc begin) end elems))))) - -(defmacro defrtags [tags] - (let [num-tags (count tags) - normals (butlast tags) - special (last tags) - tags+locs (cons [special (repeat (dec num-tags) 1)] - (map #(vector %1 (concat (repeat %2 1) [0])) - normals - (range num-tags)))] - `(do ~@(for [[tag loc] tags+locs - :let [getter (symbol (str "$get-" tag)) - setter (symbol (str "$set-" tag)) - updater (symbol (str "$update-" tag)) - record (gensym "record") - value (gensym "value")]] - `(do (defn ~getter [~record] - ;; (if (= '~'$get-source '~getter) - ;; (prn '~getter '~loc ~record (aget ~record ~@loc)) - ;; (prn '~getter '~loc ~record (adt->text (aget ~record ~@loc)))) - (aget ~record ~@loc)) - (defn ~setter [~value ~record] - ;; (if (= '~'$set-source '~setter) - ;; (prn '~setter '_1 '~loc ~record) - ;; (prn '~setter '_2 '~loc ~record (adt->text ~value))) - ;; (doto record# - ;; (aset ~@loc value#)) - ;; (doto record# - ;; (aset 1 (doto (aget record# 1) - ;; (aset 1 ...)))) - ~(reduce (fn [inner indices] - `(doto (aclone ~(if (= 1 (count indices)) - record - `(aget ~record ~@(butlast indices)))) - (aset ~(last indices) ~inner))) - value - (reverse (unfold-accesses loc))) - ) - (defn ~updater [f# ~record] - ;; (prn '~updater '~loc ~record) - ;; (doto record# - ;; (aset ~@loc (f# (aget record# ~@loc)))) - (~setter (f# (~getter ~record)) ~record))))) - )) + `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(deftags - ["Nil" - "Cons"]) +(deftags "" + "Nil" + "Cons") ;; Maybe -(deftags - ["None" - "Some"]) +(deftags "" + "None" + "Some") + +;; Meta +(deftags "" + "Meta") ;; Either -(deftags - ["Left" - "Right"]) +(deftags "" + "Left" + "Right") ;; AST -(deftags - ["BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS"]) +(deftags "" + "BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS") ;; Type -(deftags - ["VoidT" - "UnitT" - "SumT" - "ProdT" - "DataT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "AllT" - "AppT" - "NamedT"]) +(deftags "" + "DataT" + "VariantT" + "TupleT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "AllT" + "AppT" + "NamedT") ;; Vars -(deftags - ["Local" - "Global"]) +(deftags "lux;" + "Local" + "Global") ;; Definitions -(deftags - ["ValueD" - "TypeD" - "MacroD" - "AliasD"]) +(deftags "lux;" + "ValueD" + "TypeD" + "MacroD" + "AliasD") ;; Binding -(defrtags - ["counter" - "mappings"]) +(deftags "" + "counter" + "mappings") ;; Env -(defrtags - ["name" - "inner-closures" - "locals" - "closure"]) +(deftags "" + "name" + "inner-closures" + "locals" + "closure") ;; Host -(defrtags - ["writer" - "loader" - "classes"]) +(deftags "" + "writer" + "loader" + "classes") ;; Compiler -(defrtags - ["source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host"]) +(deftags "" + "source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host") ;; [Exports] -;; Class fields (def datum-field "_datum") (def meta-field "_meta") (def name-field "_name") @@ -175,59 +117,55 @@ (def +name-separator+ ";") -(def prelude-name "lux") - -(defmacro $$ [op & args] - (assert (> (count args) 1) - (prn-str '$$ op args)) - (let [[last & others] (reverse args)] - (reduce (fn [right left] `(~op ~left ~right)) - last - others))) +(defn T [& elems] + (to-array elems)) -(defn S [^Long tag value] +(defn V [^Long tag value] (to-array [tag value])) -(defn P [left right] - (to-array [left right])) - ;; Constructors -(def None$ (S $None nil)) -(defn Some$ [x] (S $Some x)) +(def None$ (V $None nil)) +(defn Some$ [x] (V $Some x)) + +(def Nil$ (V $Nil nil)) +(defn Cons$ [h t] (V $Cons (T h t))) -(def Nil$ (S $Nil nil)) -(defn Cons$ [h t] (S $Cons (P h t))) +(defn get$ [slot ^objects record] + (aget record slot)) + +(defn set$ [slot value ^objects record] + (let [record* (aclone record) + size (alength record)] + (aset record* slot value) + record*)) + +(defmacro update$ [slot f record] + `(let [record# ~record] + (set$ ~slot (~f (get$ ~slot record#)) + record#))) (defn fail* [message] - (S $Left message)) + (V $Left message)) (defn return* [state value] - (S $Right (P state value))) - -(defn ^:private transform-tuple-pattern [pattern] - (case (count pattern) - 0 '_ - 1 (assert false "Can't have singleton tuples.") - 2 pattern - ;; else - (let [[last & others] (reverse pattern)] - (reduce (fn [r l] [l r]) last others)))) + (V $Right (T state value))) (defn transform-pattern [pattern] - (cond (vector? pattern) (transform-tuple-pattern (mapv transform-pattern pattern)) + (cond (vector? pattern) (mapv transform-pattern pattern) (seq? pattern) (let [parts (mapv transform-pattern (rest pattern))] (vec (cons (eval (first pattern)) (list (case (count parts) + 0 '_ 1 (first parts) ;; else - (transform-tuple-pattern parts)))))) + `[~@parts]))))) :else pattern )) (defmacro |case [value & branches] (assert (= 0 (mod (count branches) 2))) (let [value* (if (vector? value) - [`($$ P ~@value)] + [`(T ~@value)] [value])] `(matchv ::M/objects ~value* ~@(mapcat (fn [[pattern body]] @@ -245,8 +183,8 @@ (defmacro |list [& elems] (reduce (fn [tail head] - `(Cons$ ~head ~tail)) - `Nil$ + `(V $Cons (T ~head ~tail))) + `(V $Nil nil) (reverse elems))) (defmacro |table [& elems] @@ -266,18 +204,17 @@ (|get slot table*)))) (defn |put [slot value table] - ;; (prn '|put slot (adt->text value) (adt->text table)) (|case table ($Nil) - (Cons$ (P slot value) Nil$) + (V $Cons (T (T slot value) (V $Nil nil))) ($Cons [k v] table*) (if (.equals ^Object k slot) - (Cons$ (P slot value) table*) - (Cons$ (P k v) (|put slot value table*))) + (V $Cons (T (T slot value) table*)) + (V $Cons (T (T k v) (|put slot value table*)))) ;; _ - ;; (assert false (prn-str '|put slot (adt->text value) (adt->text table))) + ;; (assert false (prn-str '|put (aget table 0))) )) (defn |remove [slot table] @@ -288,7 +225,7 @@ ($Cons [k v] table*) (if (.equals ^Object k slot) table* - (Cons$ (P k v) (|remove slot table*))))) + (V $Cons (T (T k v) (|remove slot table*)))))) (defn |update [k f table] (|case table @@ -297,8 +234,8 @@ ($Cons [k* v] table*) (if (.equals ^Object k k*) - (Cons$ (P k* (f v)) table*) - (Cons$ (P k* v) (|update k f table*))))) + (V $Cons (T (T k* (f v)) table*)) + (V $Cons (T (T k* v) (|update k f table*)))))) (defn |head [xs] (|case xs @@ -319,11 +256,11 @@ ;; [Resources/Monads] (defn fail [message] (fn [_] - (S $Left message))) + (V $Left message))) (defn return [value] (fn [state] - (S $Right (P state value)))) + (V $Right (T state value)))) (defn bind [m-value step] (fn [state] @@ -351,13 +288,22 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] +(defn |cons [head tail] + (V $Cons (T head tail))) + (defn |++ [xs ys] (|case xs ($Nil) ys ($Cons x xs*) - (Cons$ x (|++ xs* ys)))) + (V $Cons (T x (|++ xs* ys))))) + +(let [array-class (class (to-array []))] + (defn adt->text [adt] + (if (= array-class (class adt)) + (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") + (pr-str adt)))) (defn |map [f xs] (|case xs @@ -365,7 +311,7 @@ xs ($Cons x xs*) - (Cons$ (f x) (|map f xs*)) + (V $Cons (T (f x) (|map f xs*))) _ (assert false (prn-str '|map f (adt->text xs))) @@ -386,7 +332,7 @@ ($Cons x xs*) (if (p x) - (Cons$ x (|filter p xs*)) + (V $Cons (T x (|filter p xs*))) (|filter p xs*)))) (defn flat-map [f xs] @@ -400,13 +346,13 @@ (defn |split-with [p xs] (|case xs ($Nil) - (P xs xs) + (T xs xs) ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (P (Cons$ x pre) post)) - (P Nil$ xs)))) + (T (|cons x pre) post)) + (T (V $Nil nil) xs)))) (defn |contains? [k table] (|case table @@ -415,10 +361,7 @@ ($Cons [k* _] table*) (or (.equals ^Object k k*) - (|contains? k table*)) - - _ - (assert false (prn-str '|contains? k (adt->text table))))) + (|contains? k table*)))) (defn fold [f init xs] (|case xs @@ -443,15 +386,15 @@ (|list init) ($Cons x xs*) - (Cons$ init (folds f (f init x) xs*)))) + (|cons init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) (let [|range* (fn |range* [from to] (if (< from to) - (Cons$ from (|range* (inc from) to)) - Nil$))] + (V $Cons (T from (|range* (inc from) to))) + (V $Nil nil)))] (defn |range [n] (|range* 0 n))) @@ -466,10 +409,10 @@ (defn zip2 [xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (P x y) (zip2 xs* ys*)) + (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - Nil$)) + (V $Nil nil))) (defn |keys [plist] (|case plist @@ -477,7 +420,7 @@ (|list) ($Cons [k v] plist*) - (Cons$ k (|keys plist*)))) + (|cons k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -485,7 +428,7 @@ (|list) ($Cons [k v] plist*) - (Cons$ v (|vals plist*)))) + (|cons v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -496,7 +439,7 @@ xs ($Cons x xs*) - (Cons$ x (Cons$ sep (|interpose sep xs*))))) + (V $Cons (T x (V $Cons (T sep (|interpose sep xs*))))))) (do-template [ ] (defn [f xs] @@ -509,23 +452,23 @@ ys ( f xs*)] (return ( y ys))))) - map% Cons$ + map% |cons flat-map% |++) (defn list-join [xss] - (fold |++ Nil$ xss)) + (fold |++ (V $Nil nil) xss)) (defn |as-pairs [xs] (|case xs ($Cons x ($Cons y xs*)) - (Cons$ (P x y) (|as-pairs xs*)) + (V $Cons (T (T x y) (|as-pairs xs*))) _ - Nil$)) + (V $Nil nil))) (defn |reverse [xs] (fold (fn [tail head] - (Cons$ head tail)) + (|cons head tail)) (|list) xs)) @@ -561,7 +504,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (Cons$ head tail))) + (return (|cons head tail))) (return (|list))))) (defn exhaust% [step] @@ -608,28 +551,28 @@ (def loader (fn [state] - (return* state (->> state $get-host ($get-loader))))) + (return* state (->> state (get$ $host) (get$ $loader))))) (def classes (fn [state] - (return* state (->> state $get-host ($get-classes))))) + (return* state (->> state (get$ $host) (get$ $classes))))) (def +init-bindings+ - (P ;; "lux;counter" + (T ;; "lux;counter" 0 ;; "lux;mappings" (|table))) (defn env [name] - ($$ P ;; "lux;name" - name - ;; "lux;inner-closures" - 0 - ;; "lux;locals" - +init-bindings+ - ;; "lux;closure" - +init-bindings+ - )) + (T ;; "lux;name" + name + ;; "lux;inner-closures" + 0 + ;; "lux;locals" + +init-bindings+ + ;; "lux;closure" + +init-bindings+ + )) (let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String (class (byte-array [])) @@ -651,41 +594,41 @@ (defn host [_] (let [store (atom {})] - ($$ P ;; "lux;writer" - None$ - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store))) + (T ;; "lux;writer" + (V $None nil) + ;; "lux;loader" + (memory-class-loader store) + ;; "lux;classes" + store))) (defn init-state [_] - ($$ P ;; "lux;source" - None$ - ;; "lux;cursor" - ($$ P "" -1 -1) - ;; "lux;modules" - (|table) - ;; "lux;envs" - (|list) - ;; "lux;types" - +init-bindings+ - ;; "lux;expected" - (S $VoidT nil) - ;; "lux;seed" - 0 - ;; "lux;eval?" - false - ;; "lux;host" - (host nil) - )) + (T ;; "lux;source" + (V $None nil) + ;; "lux;cursor" + (T "" -1 -1) + ;; "lux;modules" + (|table) + ;; "lux;envs" + (|list) + ;; "lux;types" + +init-bindings+ + ;; "lux;expected" + (V $VariantT (|list)) + ;; "lux;seed" + 0 + ;; "lux;eval?" + false + ;; "lux;host" + (host nil) + )) (defn save-module [body] (fn [state] (|case (body state) ($Right state* output) (return* (->> state* - ($set-envs ($get-envs state)) - ($set-source ($get-source state))) + (set$ $envs (get$ $envs state)) + (set$ $source (get$ $source state))) output) ($Left msg) @@ -693,20 +636,20 @@ (defn with-eval [body] (fn [state] - (|case (body ($set-eval? true state)) + (|case (body (set$ $eval? true state)) ($Right state* output) - (return* ($set-eval? ($get-eval? state) state*) output) + (return* (set$ $eval? (get$ $eval? state) state*) output) ($Left msg) (fail* msg)))) (def get-eval (fn [state] - (return* state ($get-eval? state)))) + (return* state (get$ $eval? state)))) (def get-writer (fn [state] - (let [writer* (->> state ($get-host) ($get-writer))] + (let [writer* (->> state (get$ $host) (get$ $writer))] (|case writer* ($Some datum) (return* state datum) @@ -716,15 +659,15 @@ (def get-top-local-env (fn [state] - (try (let [top (|head ($get-envs state))] + (try (let [top (|head (get$ $envs state))] (return* state top)) (catch Throwable _ (fail* "No local environment."))))) (def gen-id (fn [state] - (let [seed ($get-seed state)] - (return* ($set-seed (inc seed) state) seed)))) + (let [seed (get$ $seed state)] + (return* (set$ $seed (inc seed) state) seed)))) (defn ->seq [xs] (|case xs @@ -737,26 +680,26 @@ (defn ->list [seq] (if (empty? seq) (|list) - (Cons$ (first seq) (->list (rest seq))))) + (|cons (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (Cons$ x (|repeat (dec n) x)) + (|cons x (|repeat (dec n) x)) (|list))) (def get-module-name (fn [state] - (|case (|reverse ($get-envs state)) + (|case (|reverse (get$ $envs state)) ($Nil) (fail* "[Analyser Error] Can't get the module-name without a module.") ($Cons ?global _) - (return* state ($get-name ?global))))) + (return* state (get$ $name ?global))))) (defn find-module [name] "(-> Text (Lux (Module Compiler)))" (fn [state] - (if-let [module (|get name ($get-modules state))] + (if-let [module (|get name (get$ $modules state))] (return* state module) (fail* (str "Unknown module: " name))))) @@ -767,10 +710,10 @@ (defn with-scope [name body] (fn [state] - (let [output (body ($update-envs #(Cons$ (env name) %) state))] + (let [output (body (update$ $envs #(|cons (env name) %) state))] (|case output ($Right state* datum) - (return* ($update-envs |tail state*) datum) + (return* (update$ $envs |tail state*) datum) _ output)))) @@ -780,24 +723,23 @@ (defn with-closure [body] (|do [closure-name (|do [top get-top-local-env] - (return (->> top ($get-inner-closures) str)))] + (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* ($update-envs #(Cons$ ($update-inner-closures inc (|head %)) - (|tail %)) - state)))))) + (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) + (|tail %)) + state)))))) (def get-scope-name (fn [state] - (return* state (->> state ($get-envs) (|map #($get-name %)) |reverse)))) + (return* state (->> state (get$ $envs) (|map #(get$ $name %)) |reverse)))) (defn with-writer [writer body] (fn [state] - ;; (prn 'with-writer writer body) - (let [output (body ($update-host #($set-writer (Some$ writer) %) state))] + (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* ($update-host #($set-writer (->> state ($get-host) ($get-writer)) %) ?state) + (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) ?value) _ @@ -806,11 +748,10 @@ (defn with-expected-type [type body] "(All [a] (-> Type (Lux a)))" (fn [state] - ;; (prn 'with-expected-type type state) - (let [output (body ($set-expected type state))] + (let [output (body (set$ $expected type state))] (|case output ($Right ?state ?value) - (return* ($set-expected ($get-expected state) ?state) + (return* (set$ $expected (get$ $expected state) ?state) ?value) _ @@ -818,20 +759,14 @@ (defn with-cursor [^objects cursor body] "(All [a] (-> Cursor (Lux a)))" - ;; (prn 'with-cursor/_0 (adt->text cursor)) (if (= "" (aget cursor 0)) body (fn [state] - (let [;; _ (prn 'with-cursor/_1 cursor) - state* ($set-cursor cursor state) - ;; _ (prn 'with-cursor/_2 state*) - output (body state*)] + (let [output (body (set$ $cursor cursor state))] (|case output ($Right ?state ?value) - (let [?state* ($set-cursor ($get-cursor state) ?state)] - ;; (prn 'with-cursor/_3 ?state*) - (return* ?state* - ?value)) + (return* (set$ $cursor (get$ $cursor state) ?state) + ?value) _ output))))) @@ -839,40 +774,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - [_ ($BoolS ?value)] + ($Meta _ ($BoolS ?value)) (pr-str ?value) - [_ ($IntS ?value)] + ($Meta _ ($IntS ?value)) (pr-str ?value) - [_ ($RealS ?value)] + ($Meta _ ($RealS ?value)) (pr-str ?value) - [_ ($CharS ?value)] + ($Meta _ ($CharS ?value)) (pr-str ?value) - [_ ($TextS ?value)] + ($Meta _ ($TextS ?value)) (str "\"" ?value "\"") - [_ ($TagS ?module ?tag)] + ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - [_ ($SymbolS ?module ?ident)] + ($Meta _ ($SymbolS ?module ?ident)) (if (.equals "" ?module) ?ident (str ?module ";" ?ident)) - [_ ($TupleS ?elems)] + ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - [_ ($RecordS ?elems)] + ($Meta _ ($RecordS ?elems)) (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - [_ ($FormS ?elems)] + ($Meta _ ($FormS ?elems)) (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ @@ -900,10 +835,10 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (Cons$ z zs))) + (return (|cons z zs))) [($Nil) ($Nil)] - (return Nil$) + (return (V $Nil nil)) [_ _] (fail "Lists don't match in size."))) @@ -911,10 +846,10 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (Cons$ (f x y) (map2 f xs* ys*)) + (|cons (f x y) (map2 f xs* ys*)) [_ _] - Nil$)) + (V $Nil nil))) (defn fold2 [f init xs ys] (|case [xs ys] @@ -932,8 +867,8 @@ "(All [a] (-> Int (List a) (List (, Int a))))" (|case xs ($Cons x xs*) - (Cons$ (P idx x) - (enumerate* (inc idx) xs*)) + (V $Cons (T (T idx x) + (enumerate* (inc idx) xs*))) ($Nil) xs @@ -946,7 +881,7 @@ (def modules "(Lux (List Text))" (fn [state] - (return* state (|keys ($get-modules state))))) + (return* state (|keys (get$ $modules state))))) (defn when% [test body] "(-> Bool (Lux (,)) (Lux (,)))" @@ -960,23 +895,23 @@ (|case xs ($Cons x xs*) (cond (< idx 0) - None$ + (V $None nil) (= idx 0) - (Some$ x) + (V $Some x) :else ;; > 1 (|at (dec idx) xs*)) ($Nil) - None$ + (V $None nil) )) (defn normalize [ident] "(-> Ident (Lux Ident))" (|case ident ["" name] (|do [module get-module-name] - (return (P module name))) + (return (T module name))) _ (return ident))) (defn ident= [x y] @@ -988,24 +923,12 @@ (defn |list-put [idx val xs] (|case xs ($Nil) - None$ + (V $None nil) ($Cons x xs*) (if (= idx 0) - (Some$ (Cons$ val xs*)) + (V $Some (V $Cons (T val xs*))) (|case (|list-put (dec idx) val xs*) - ($None) None$ - ($Some xs**) (Some$ (Cons$ x xs**))) + ($None) (V $None nil) + ($Some xs**) (V $Some (V $Cons (T x xs**)))) ))) - -(defn ensure-1 [m-value] - (|do [output m-value] - (|case output - ($Cons x ($Nil)) - (return x) - - _ - (fail "[Error] Can't expand to other than 1 element.")))) - -(defn cursor$ [file-name line-num column-num] - ($$ P file-name line-num column-num)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 4315ea75d..79d2c84f8 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -39,12 +39,8 @@ ;; [Utils/Compilers] (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[?form ?type] syntax] (|case ?form - (&a/$unit) - (&&lux/compile-unit compile-expression ?type) - (&a/$bool ?value) (&&lux/compile-bool compile-expression ?type ?value) @@ -60,11 +56,8 @@ (&a/$text ?value) (&&lux/compile-text compile-expression ?type ?value) - (&a/$prod left right) - (&&lux/compile-prod compile-expression ?type left right) - - (&a/$sum tag value) - (&&lux/compile-sum compile-expression ?type tag value) + (&a/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?type ?elems) (&a/$var (&/$Local ?idx)) (&&lux/compile-local compile-expression ?type ?idx) @@ -78,6 +71,9 @@ (&a/$apply ?fn ?args) (&&lux/compile-apply compile-expression ?type ?fn ?args) + (&a/$variant ?tag ?members) + (&&lux/compile-variant compile-expression ?type ?tag ?members) + (&a/$case ?value ?match) (&&case/compile-case compile-expression ?type ?value ?match) @@ -428,7 +424,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/$set-source (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from file-name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports @@ -475,7 +471,7 @@ ;; [Resources] (defn compile-program [program-module] (init!) - (|case ((&/map% compile-module (&/|list &/prelude-name program-module)) (&/init-state nil)) + (|case ((&/map% compile-module (&/|list "lux" program-module)) (&/init-state nil)) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index e327d1de4..1e5f3a024 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,33 +76,26 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [^MethodVisitor writer] (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature ))))) + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) + ;; (doto writer + ;; ;; X + ;; (.visitTypeInsn Opcodes/NEW ) ;; XW + ;; (.visitInsn ) ;; WXW + ;; (.visitInsn ) ;; WWXW + ;; (.visitInsn Opcodes/POP) ;; WWX + ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W + ;; ) + ) - wrap-boolean "java/lang/Boolean" "(Z)" - wrap-byte "java/lang/Byte" "(B)" - wrap-short "java/lang/Short" "(S)" - wrap-int "java/lang/Integer" "(I)" - wrap-long "java/lang/Long" "(J)" - wrap-float "java/lang/Float" "(F)" - wrap-double "java/lang/Double" "(D)" - wrap-char "java/lang/Character" "(C)" - ) - -(do-template [ ] - (defn [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST ) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" )))) - - unwrap-boolean "java/lang/Boolean" "Z" "booleanValue" - unwrap-byte "java/lang/Byte" "B" "byteValue" - unwrap-short "java/lang/Short" "S" "shortValue" - unwrap-int "java/lang/Integer" "I" "intValue" - unwrap-long "java/lang/Long" "J" "longValue" - unwrap-float "java/lang/Float" "F" "floatValue" - unwrap-double "java/lang/Double" "D" "doubleValue" - unwrap-char "java/lang/Character" "C" "charValue" + wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 + wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 + wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 + wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 + wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 + wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 + wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 + wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 ) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 48b35c83a..dc224f52e 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -58,7 +58,7 @@ (defn clean [state] "(-> Compiler (,))" - (let [needed-modules (->> state (&/$get-modules) &/|keys &/->seq set) + (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) outdated? #(-> ^File % .getName (string/replace &host/module-separator "/") (->> (contains? needed-modules)) not) outdate-files (->> &&/output-dir (new File) .listFiles seq (filter outdated?)) program-file (new File &&/output-package)] @@ -120,7 +120,7 @@ ;; (prn '_group _group) (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] ;; (prn '[_type _tags] [_type _tags]) - (&/P _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) @@ -132,10 +132,10 @@ (|do [_ (case _ann "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/S &/$TypeD def-value) &type/Type)) + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/S &/$ValueD (&/P &type/Macro def-value)) &type/Macro)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] (&a-module/declare-macro module _name))) "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 0a928a056..dd3258059 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -11,7 +11,7 @@ [template :refer [do-template]]) clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type] [lexer :as &lexer] [parser :as &parser] @@ -84,71 +84,63 @@ (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$UnitTestAC) + (&a-case/$TupleTestAC ?members) (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (-> (doto (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)) + (.visitInsn Opcodes/AALOAD) + (compile-match test $next $sub-else) + (.visitLabel $sub-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else) + (.visitLabel $next)) + (->> (|let [[idx test] idx+member + $next (new Label) + $sub-else (new Label)]) + (doseq [idx+member (->> ?members &/enumerate &/->seq)]))) (.visitInsn Opcodes/POP) (.visitJumpInsn Opcodes/GOTO $target)) - (&a-case/$ProdTestAC left right) - (let [$post-left (new Label) - $post-right (new Label) - $pre-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (compile-match left $post-left $pre-else) - (.visitLabel $post-left) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (compile-match right $post-right $pre-else) - (.visitLabel $post-right) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $pre-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else))) - - (&a-case/$SumTestAC ?tag ?count ?test) - (let [$value-then (new Label) - $pre-else (new Label)] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - (&&/unwrap-int) - (.visitLdcInsn (int ?tag)) - (.visitJumpInsn Opcodes/IF_ICMPNE $else) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (compile-match ?test $value-then $pre-else) - (.visitLabel $value-then) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $target) - (.visitLabel $pre-else) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else))) + (&a-case/$VariantTestAC ?tag ?count ?test) + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/AALOAD) + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") + (.visitJumpInsn Opcodes/IFEQ $else) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)) + (.visitInsn Opcodes/AALOAD) + (-> (doto (compile-match ?test $value-then $value-else) + (.visitLabel $value-then) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $target) + (.visitLabel $value-else) + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $else)) + (->> (let [$value-then (new Label) + $value-else (new Label)])))) ))) (defn ^:private separate-bodies [patterns] (|let [[_ mappings patterns*] (&/fold (fn [$id+mappings+=matches pattern+body] (|let [[$id mappings =matches] $id+mappings+=matches [pattern body] pattern+body] - ($$ &/P (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) - ($$ &/P 0 (&/|table) (&/|table)) + (&/T (inc $id) (&/|put $id body mappings) (&/|put $id pattern =matches)))) + (&/T 0 (&/|table) (&/|table)) patterns)] - (&/P mappings (&/|reverse patterns*)))) + (&/T mappings (&/|reverse patterns*)))) (defn ^:private compile-pattern-matching [^MethodVisitor writer compile mappings patterns $end] (let [entries (&/|map (fn [?branch+?body] (|let [[?branch ?body] ?branch+?body label (new Label)] - (&/P (&/P ?branch label) - (&/P label ?body)))) + (&/T (&/T ?branch label) + (&/T label ?body)))) mappings) mappings* (&/|map &/|first entries)] (doto writer diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index ead44085a..26ef73cb7 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,7 +52,7 @@ char-class "java.lang.Character"] (defn prepare-return! [^MethodVisitor *writer* *type*] (|case *type* - (&/$UnitT) + (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) (&/$DataT "boolean") @@ -421,14 +421,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -455,12 +455,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 10ee40839..83e294c1a 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -28,43 +28,27 @@ ClassWriter MethodVisitor))) -;; [Utils] -(defn ^:private array-of [^MethodVisitor *writer* type-name size] - (do (doto *writer* - (.visitLdcInsn (int size)) - (.visitTypeInsn Opcodes/ANEWARRAY type-name)) - (return nil))) - -(defn ^:private store-at [^MethodVisitor *writer* compile idx value] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - _ (compile value) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - ;; [Exports] -(defn compile-unit [compile *type*] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - (defn compile-bool [compile *type* ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) -(do-template [ ] +(do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn value) - ())]] + :let [_ (try (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) + (catch Exception e + (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] (return nil))) - compile-int &&/wrap-long - compile-real &&/wrap-double - compile-char &&/wrap-char + compile-int "java/lang/Long" "(J)V" long + compile-real "java/lang/Double" "(D)V" double + compile-char "java/lang/Character" "(C)V" char ) (defn compile-text [compile *type* ?value] @@ -72,28 +56,37 @@ :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-prod [compile *type* left right] - ;; (prn 'compile-prod (&type/show-type *type*) - ;; (&/adt->text left) - ;; (&/adt->text right)) +(defn compile-tuple [compile *type* ?elems] (|do [^MethodVisitor *writer* &/get-writer - _ (array-of *writer* "java/lang/Object" 2) - _ (store-at *writer* compile 0 left) - ;; :let [_ (prn 'compile-prod (&type/show-type *type*) left right)] - _ (store-at *writer* compile 1 right)] + :let [num-elems (&/|length ?elems) + _ (doto *writer* + (.visitLdcInsn (int num-elems)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] + _ (&/map2% (fn [idx elem] + (|do [:let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int idx)))] + ret (compile elem) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] + (return ret))) + (&/|range num-elems) ?elems)] (return nil))) -(defn compile-sum [compile *type* ?tag ?value] +(defn compile-variant [compile *type* ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer - _ (array-of *writer* "java/lang/Object" 2) :let [_ (doto *writer* + (.visitLdcInsn (int 2)) + (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") (.visitInsn Opcodes/DUP) (.visitLdcInsn (int 0)) - (.visitLdcInsn (int ?tag)) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE))] - _ (store-at *writer* compile 1 ?value)] + (.visitLdcInsn ?tag) + (&&/wrap-long) + (.visitInsn Opcodes/AASTORE) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int 1)))] + _ (compile ?value) + :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) (defn compile-local [compile *type* ?idx] @@ -138,7 +131,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$TypeD) ;; VVIT - (&&/wrap-int) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI @@ -165,7 +158,7 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 0)) ;; VVI (.visitLdcInsn &/$ValueD) ;; VVIT - (&&/wrap-int) + (&&/wrap-long) (.visitInsn Opcodes/AASTORE) ;; V (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index 50d8b0011..db73e8bb4 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -23,6 +23,6 @@ (return (&/|map (fn [pair] (|case pair [name [tags _]] - (&/P name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) - (&module/$get-types module))) + (&/T name (&/|map (fn [^objects tag] (aget tag 1)) tags)))) + (&/get$ &module/$types module))) )) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index cfaa9668b..7e2bc6961 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -9,86 +9,83 @@ (ns lux.compiler.type (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [|do return* return fail fail* |let |case $$]] + (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) [lux.analyser.base :as &a])) ;; [Utils] -(def ^:private unit$ - "Analysis" - (&/P (&/S &a/$unit nil) - &type/$Void)) - -(defn ^:private sum$ [tag body] - "(-> Int Analysis Analysis)" - (&/P (&/S &a/$sum (&/P tag body)) +(defn ^:private variant$ [tag body] + "(-> Text Analysis Analysis)" + (&/T (&/V &a/$variant (&/T tag body)) &type/$Void)) -(defn ^:private prod$ [left right] - "(-> Analysis Analysis Analysis)" - (&/P (&/S &a/$prod (&/P left right)) +(defn ^:private tuple$ [members] + "(-> (List Analysis) Analysis)" + (&/T (&/V &a/$tuple members) &type/$Void)) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/P (&/S &a/$text text) + (&/T (&/V &a/$text text) &type/$Void)) (def ^:private $Nil "Analysis" - (sum$ &/$Nil unit$)) + (variant$ &/$Nil (tuple$ (&/|list)))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" - (sum$ &/$Cons (prod$ head tail))) + (variant$ &/$Cons (tuple$ (&/|list head tail)))) ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type (&/$DataT ?class) - (sum$ &/$DataT (text$ ?class)) + (variant$ &/$DataT (text$ ?class)) - (&/$ProdT left right) - (sum$ &/$ProdT - (prod$ (->analysis left) - (->analysis right))) + (&/$TupleT ?members) + (variant$ &/$TupleT + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) - (&/$SumT left right) - (sum$ &/$SumT - (prod$ (->analysis left) - (->analysis right))) + (&/$VariantT ?members) + (variant$ &/$VariantT + (&/fold (fn [tail head] + (Cons$ (->analysis head) tail)) + $Nil + (&/|reverse ?members))) (&/$LambdaT ?input ?output) - (sum$ &/$LambdaT (prod$ (->analysis ?input) (->analysis ?output))) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) (&/$AllT ?env ?name ?arg ?body) - (sum$ &/$AllT - ($$ prod$ - (|case ?env - (&/$None) - (sum$ &/$None unit$) + (variant$ &/$AllT + (tuple$ (&/|list (|case ?env + (&/$None) + (variant$ &/$None (tuple$ (&/|list))) - (&/$Some ??env) - (sum$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (prod$ (text$ hlabel) - (->analysis htype)) - tail))) - $Nil - (&/|reverse ??env)))) - (text$ ?name) - (text$ ?arg) - (->analysis ?body))) + (&/$Some ??env) + (variant$ &/$Some + (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ??env)))) + (text$ ?name) + (text$ ?arg) + (->analysis ?body)))) (&/$BoundT ?name) - (sum$ &/$BoundT (text$ ?name)) + (variant$ &/$BoundT (text$ ?name)) (&/$AppT ?fun ?arg) - (sum$ &/$AppT (prod$ (->analysis ?fun) (->analysis ?arg))) + (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) (&/$NamedT [?module ?name] ?type) - (sum$ &/$NamedT (prod$ (prod$ (text$ ?module) (text$ ?name)) - (->analysis ?type))) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) + (->analysis ?type)))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index d77e9b31c..dfd4df23d 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,8 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/S &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base))) ))) (defn ^:private method->type [^Method method] @@ -76,7 +76,7 @@ (&/$LambdaT _ _) (->type-signature function-class) - (&/$VoidT) + (&/$TupleT (&/$Nil)) "V" (&/$NamedT ?name ?type) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 91693cc77..e848cc3fd 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -13,22 +13,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" ) ;; [Utils] @@ -58,19 +58,19 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/P meta (&/S $White_Space white-space))))) + (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/P meta (&/S $Comment comment))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") ;; :let [_ (prn 'immediate comment)] _ (&reader/read-text ")#")] - (return (&/P meta comment))) + (return (&/T meta comment))) (|do [;; :let [_ (prn 'pre/_0)] [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") ;; :let [_ (prn 'pre pre)] @@ -79,10 +79,10 @@ [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] ] - (return (&/P meta (str pre "#(" inner ")#" post)))))) + (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/P meta (&/S $Comment comment))))) + (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -91,7 +91,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/P meta (&/S token))))) + (return (&/V &/$Meta (&/T meta (&/V token)))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -105,13 +105,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/P meta (&/S $Char token))))) + (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/P meta (&/S $Text token))))) + (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -119,35 +119,35 @@ [_ local-token] (&reader/read-regex +ident-re+) ? (&module/exists? token)] (if ? - (return (&/P meta (&/P token local-token))) + (return (&/T meta (&/T token local-token))) (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] + (&module/dealias token))] (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/P meta (&/P unaliased local-token))))))) - (return (&/P meta (&/P "" token))) + (return (&/T meta (&/T unaliased local-token))))))) + (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") [_ token] (&reader/read-regex +ident-re+) module-name &/get-module-name] - (return (&/P meta (&/P module-name token)))) + (return (&/T meta (&/T module-name token)))) (|do [[meta _] (&reader/read-text ";") [_ token] (&reader/read-regex +ident-re+)] - (return (&/P meta (&/P &/prelude-name token)))) + (return (&/T meta (&/T "lux" token)))) ))) (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/P meta (&/S $Symbol ident))))) + (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/P meta (&/S $Tag ident))))) + (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/P meta (&/S nil))))) + (return (&/V &/$Meta (&/T meta (&/V nil)))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index c40221d63..eaa22db20 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -14,22 +14,22 @@ [lexer :as &lexer]))) ;; [Tags] -(deftags - ["White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace"] +(deftags "" + "White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace" ) ;; [Utils] @@ -38,8 +38,8 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - [meta [ _]] - (return (&/S (&/fold &/|++ (&/|list) elems))) + (&/$Meta meta [ _]) + (return (&/V (&/fold &/|++ (&/|list) elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -53,9 +53,9 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - [meta ($Close_Brace _)] + (&/$Meta meta ($Close_Brace _)) (if (even? (&/|length elems)) - (return (&/S &/$RecordS (&/|as-pairs elems))) + (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) _ @@ -64,7 +64,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [[meta token*] token]] + :let [(&/$Meta meta token*) token]] (|case token* ($White_Space _) (return (&/|list)) @@ -73,37 +73,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/P meta (&/S &/$BoolS (Boolean/parseBoolean ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) ($Int ?value) - (return (&/|list (&/P meta (&/S &/$IntS (Long/parseLong ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) ($Real ?value) - (return (&/|list (&/P meta (&/S &/$RealS (Double/parseDouble ?value))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) ($Char ^String ?value) - (return (&/|list (&/P meta (&/S &/$CharS (.charAt ?value 0))))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) ($Text ?value) - (return (&/|list (&/P meta (&/S &/$TextS ?value)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) ($Symbol ?ident) - (return (&/|list (&/P meta (&/S &/$SymbolS ?ident)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) ($Tag ?ident) - (return (&/|list (&/P meta (&/S &/$TagS ?ident)))) + (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/P meta syntax)))) + (return (&/|list (&/V &/$Meta (&/T meta syntax))))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 24a0bf94d..e3f95b5f9 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,18 +10,18 @@ (:require [clojure.string :as string] clojure.core.match clojure.core.match.array - [lux.base :as & :refer [deftags |do return* return fail fail* |let |case $$]])) + [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) ;; [Tags] -(deftags - ["No" - "Done" - "Yes"]) +(deftags "" + "No" + "Done" + "Yes") ;; [Utils] (defn ^:private with-line [body] (fn [state] - (|case (&/$get-source state) + (|case (&/get$ &/$source state) (&/$Nil) (fail* "[Reader Error] EOF") @@ -32,19 +32,19 @@ (fail* msg) ($Done output) - (return* (&/$set-source more state) + (return* (&/set$ &/$source more state) output) ($Yes output line*) - (return* (&/$set-source (&/Cons$ line* more) state) + (return* (&/set$ &/$source (&/|cons line* more) state) output)) ))) (defn ^:private with-lines [body] (fn [state] - (|case (body (&/$get-source state)) + (|case (body (&/get$ &/$source state)) (&/$Right reader* match) - (return* (&/$set-source reader* state) + (return* (&/set$ &/$source reader* state) match) (&/$Left msg) @@ -85,10 +85,10 @@ match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) match)) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) match) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) match)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) match) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex2 [regex] (with-line @@ -98,10 +98,10 @@ (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2))) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) (&/P tok1 tok2)) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Pattern failed: " regex)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) (&/T tok1 tok2))) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) (&/T tok1 tok2)) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Pattern failed: " regex)))))) (defn read-regex+ [regex] (with-lines @@ -110,7 +110,7 @@ reader* reader] (|case reader* (&/$Nil) - (&/S &/$Left "[Reader Error] EOF") + (&/V &/$Left "[Reader Error] EOF") (&/$Cons [[file-name line-num column-num] ^String line] reader**) @@ -120,10 +120,10 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/S &/$Right (&/P (&/Cons$ (&/P (&/cursor$ file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) reader**) - (&/P (&/cursor$ file-name line-num column-num) (str prefix match)))))) - (&/S &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) + (&/T (&/T file-name line-num column-num) (str prefix match)))))) + (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] (with-line @@ -133,10 +133,10 @@ (let [match-length (.length text) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) - (&/S $Done (&/P (&/cursor$ file-name line-num column-num) text)) - (&/S $Yes (&/P (&/P (&/cursor$ file-name line-num column-num) text) - (&/P (&/cursor$ file-name line-num column-num*) line))))) - (&/S $No (str "[Reader Error] Text failed: " text)))))) + (&/V $Done (&/T (&/T file-name line-num column-num) text)) + (&/V $Yes (&/T (&/T (&/T file-name line-num column-num) text) + (&/T (&/T file-name line-num column-num*) line))))) + (&/V $No (str "[Reader Error] Text failed: " text)))))) (def ^:private ^String +source-dir+ "input/") (defn from [^String file-name ^String file-content] @@ -144,7 +144,7 @@ file-name (.substring file-name (.length +source-dir+))] (&/|map (fn [line+line-num] (|let [[line-num line] line+line-num] - (&/P (&/cursor$ file-name (inc line-num) 0) + (&/T (&/T file-name (inc line-num) 0) line))) (&/|filter (fn [line+line-num] (|let [[line-num line] line+line-num] diff --git a/src/lux/type.clj b/src/lux/type.clj index 37f3a99d4..9f3adb036 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -10,7 +10,7 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case $$]])) + [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) (declare show-type) @@ -26,300 +26,302 @@ _ false)) -(def ^:private empty-env (&/Some$ &/Nil$)) -(def ^:private no-env &/None$) -(def Ident$ &/P) +(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) +(def ^:private no-env (&/V &/$None nil)) (defn Data$ [name] - (&/S &/$DataT name)) + (&/V &/$DataT name)) (defn Bound$ [name] - (&/S &/$BoundT name)) + (&/V &/$BoundT name)) (defn Var$ [id] - (&/S &/$VarT id)) + (&/V &/$VarT id)) (defn Lambda$ [in out] - (&/S &/$LambdaT (&/P in out))) + (&/V &/$LambdaT (&/T in out))) (defn App$ [fun arg] - (&/S &/$AppT (&/P fun arg))) -(defn Prod$ [left right] + (&/V &/$AppT (&/T fun arg))) +(defn Tuple$ [members] ;; (assert (|list? members)) - (&/S &/$ProdT (&/P left right))) -(defn Sum$ [left right] + (&/V &/$TupleT members)) +(defn Variant$ [members] ;; (assert (|list? members)) - (&/S &/$SumT (&/P left right))) + (&/V &/$VariantT members)) (defn All$ [env name arg body] - (&/S &/$AllT ($$ &/P env name arg body))) + (&/V &/$AllT (&/T env name arg body))) (defn Named$ [name type] - (&/S &/$NamedT (&/P name type))) + (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (Ident$ &/prelude-name "Bool") (Data$ "java.lang.Boolean"))) -(def Int (Named$ (Ident$ &/prelude-name "Int") (Data$ "java.lang.Long"))) -(def Real (Named$ (Ident$ &/prelude-name "Real") (Data$ "java.lang.Double"))) -(def Char (Named$ (Ident$ &/prelude-name "Char") (Data$ "java.lang.Character"))) -(def Text (Named$ (Ident$ &/prelude-name "Text") (Data$ "java.lang.String"))) -(def Unit (Named$ (Ident$ &/prelude-name "Unit") (&/S &/$UnitT nil))) -(def $Void (Named$ (Ident$ &/prelude-name "Void") (&/S &/$VoidT nil))) -(def Ident (Named$ (Ident$ &/prelude-name "Ident") (Prod$ Text Text))) + +(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) +(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) +(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) +(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) +(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) +(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO - (Named$ (Ident$ "lux/data" "IO") + (Named$ (&/T "lux/data" "IO") (All$ empty-env "IO" "a" (Lambda$ Unit (Bound$ "a"))))) (def List - (Named$ (Ident$ &/prelude-name "List") + (Named$ (&/T "lux" "List") (All$ empty-env "lux;List" "a" - (Sum$ - ;; lux;Nil - Unit - ;; lux;Cons - (Prod$ (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a"))) - )))) + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ "a") + (App$ (Bound$ "lux;List") + (Bound$ "a")))) + ))))) (def Maybe - (Named$ (Ident$ &/prelude-name "Maybe") + (Named$ (&/T "lux" "Maybe") (All$ empty-env "lux;Maybe" "a" - (Sum$ - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - )))) + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ "a") + ))))) (def Type - (Named$ (Ident$ &/prelude-name "Type") + (Named$ (&/T "lux" "Type") (let [Type (App$ (Bound$ "Type") (Bound$ "_")) TypeList (App$ List Type) - TypeEnv (App$ List (Prod$ Text Type)) - TypePair (Prod$ Type Type)] + TypeEnv (App$ List (Tuple$ (&/|list Text Type))) + TypePair (Tuple$ (&/|list Type Type))] (App$ (All$ empty-env "Type" "_" - ($$ Sum$ - ;; VoidT - Unit - ;; UnitT - Unit - ;; SumT - TypePair - ;; ProdT - TypePair - ;; DataT - Text - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - ($$ Prod$ (App$ Maybe TypeEnv) Text Text Type) - ;; AppT - TypePair - ;; NamedT - (Prod$ Ident Type) - )) + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Text + ;; VarT + Int + ;; ExT + Int + ;; AllT + (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) $Void)))) (def Bindings - (Named$ (Ident$ &/prelude-name "Bindings") + (Named$ (&/T "lux" "Bindings") (All$ empty-env "lux;Bindings" "k" (All$ no-env "" "v" - (Prod$ - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Prod$ (Bound$ "k") - (Bound$ "v")))))))) + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ "k") + (Bound$ "v")))))))))) (def Env - (Named$ (Ident$ &/prelude-name "Env") + (Named$ (&/T "lux" "Env") (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" (All$ no-env "" "v" - ($$ Prod$ - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - )))))) + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor - (Named$ (Ident$ &/prelude-name "Cursor") - ($$ Prod$ Text Int Int))) + (Named$ (&/T "lux" "Cursor") + (Tuple$ (&/|list Text Int Int)))) (def Meta - (Named$ (Ident$ &/prelude-name "Meta") + (Named$ (&/T "lux" "Meta") (All$ empty-env "lux;Meta" "m" (All$ no-env "" "v" - (Prod$ (Bound$ "m") - (Bound$ "v")))))) + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ "m") + (Bound$ "v"))))))))) (def AST* - (Named$ (Ident$ &/prelude-name "AST'") + (Named$ (&/T "lux" "AST'") (let [AST* (App$ (Bound$ "w") (App$ (Bound$ "lux;AST'") (Bound$ "w"))) AST*List (App$ List AST*)] (All$ empty-env "lux;AST'" "w" - ($$ Sum$ - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Prod$ AST* AST*)) - ))))) + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST - (Named$ (Ident$ &/prelude-name "AST") + (Named$ (&/T "lux" "AST") (let [w (App$ Meta Cursor)] (App$ w (App$ AST* w))))) (def ^:private ASTList (App$ List AST)) (def Either - (Named$ (Ident$ &/prelude-name "Either") + (Named$ (&/T "lux" "Either") (All$ empty-env "lux;Either" "l" (All$ no-env "" "r" - (Sum$ - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r")))))) + (Variant$ (&/|list + ;; &/$Left + (Bound$ "l") + ;; &/$Right + (Bound$ "r"))))))) (def StateE (All$ empty-env "lux;StateE" "s" (All$ no-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) - (Prod$ (Bound$ "s") - (Bound$ "a"))))))) + (Tuple$ (&/|list (Bound$ "s") + (Bound$ "a")))))))) (def Source - (Named$ (Ident$ &/prelude-name "Source") + (Named$ (&/T "lux" "Source") (App$ List (App$ (App$ Meta Cursor) Text)))) (def Host - (Named$ (Ident$ &/prelude-name "Host") - ($$ Prod$ - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") - ;; "lux;loader" - (Data$ "java.lang.ClassLoader") - ;; "lux;classes" - (Data$ "clojure.lang.Atom")))) + (Named$ (&/T "lux" "Host") + (Tuple$ + (&/|list + ;; "lux;writer" + (Data$ "org.objectweb.asm.ClassWriter") + ;; "lux;loader" + (Data$ "java.lang.ClassLoader") + ;; "lux;classes" + (Data$ "clojure.lang.Atom"))))) (def DefData* (All$ empty-env "lux;DefData'" "" - ($$ Sum$ - ;; "lux;ValueD" - (Prod$ Type Unit) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - ))) + (Variant$ (&/|list + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ "") + ;; "lux;AliasD" + Ident + )))) (def LuxVar - (Named$ (Ident$ &/prelude-name "LuxVar") - (Sum$ - ;; "lux;Local" - Int - ;; "lux;Global" - Ident))) + (Named$ (&/T "lux" "LuxVar") + (Variant$ (&/|list + ;; "lux;Local" + Int + ;; "lux;Global" + Ident)))) (def $Module (All$ empty-env "lux;$Module" "Compiler" - ($$ Prod$ - ;; "lux;module-aliases" - (App$ List (Prod$ Text Text)) - ;; "lux;defs" - (App$ List - (Prod$ Text - (Prod$ Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Prod$ Text - ($$ Prod$ Int - (App$ List Ident) - Type))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Prod$ Text - (Prod$ (App$ List Ident) - Type))) - ))) + (Tuple$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ "Compiler")) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) + )))) (def $Compiler - (Named$ (Ident$ &/prelude-name "Compiler") + (Named$ (&/T "lux" "Compiler") (App$ (All$ empty-env "lux;Compiler" "" - ($$ Prod$ - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Prod$ Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ ""))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Prod$ LuxVar Type))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - )) + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) $Void))) (def Macro - (Named$ (Ident$ &/prelude-name "Macro") + (Named$ (&/T "lux" "Macro") (Lambda$ ASTList (App$ (App$ StateE $Compiler) ASTList)))) (defn bound? [id] (fn [state] - (if-let [type (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [type (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type (&/$Some type*) (return* state true) @@ -330,7 +332,7 @@ (defn deref [id] (fn [state] - (if-let [type* (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [type* (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case type* (&/$Some type) (return* state type) @@ -341,37 +343,32 @@ (defn set-var [id type] (fn [state] - (if-let [tvar (->> state (&/$get-type-vars) (&/$get-mappings) (&/|get id))] + (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] (|case tvar (&/$Some bound) (fail* (str "[Type Error] Can't rebind type var: " id " | Current type: " (show-type bound))) (&/$None) - (return* (&/$update-type-vars (fn [ts] (&/$update-mappings #(&/|put id (&/Some$ type) %) - ts)) - state) + (return* (&/update$ &/$type-vars (fn [ts] (&/update$ &/$mappings #(&/|put id (&/V &/$Some type) %) + ts)) + state) nil)) - (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/$get-type-vars) (&/$get-mappings) &/|length)))))) + (fail* (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) &/|length)))))) ;; [Exports] ;; Type vars (def ^:private create-var (fn [state] - (let [id (->> state &/$get-type-vars &/$get-counter)] - (return* (&/$update-type-vars #(do ;; (prn 'create-var/_0 (&/adt->text %)) - ;; (prn 'create-var/_1 (&/adt->text (->> % (&/$update-counter inc)))) - ;; (prn 'create-var/_2 (&/adt->text (->> % - ;; (&/$update-counter inc) - ;; (&/$update-mappings (fn [ms] (&/|put id &/None$ ms)))))) - (->> % - (&/$update-counter inc) - (&/$update-mappings (fn [ms] (&/|put id &/None$ ms))))) - state) + (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter inc) + (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + state) id)))) (def existential (|do [seed &/gen-id] - (return (&/S &/$ExT seed)))) + (return (&/V &/$ExT seed)))) (declare clean*) (defn ^:private delete-var [id] @@ -393,19 +390,19 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/P ?id &/None$)) + (return (&/T ?id (&/V &/$None nil))) (return binding)) _ (|do [?type** (clean* id ?type*)] - (return (&/P ?id (&/Some$ ?type**))))) + (return (&/T ?id (&/V &/$Some ?type**))))) )))) - (->> state (&/$get-type-vars) (&/$get-mappings)))] + (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/$update-type-vars #(->> % - (&/$update-counter dec) - (&/$set-mappings (&/|remove id mappings*))) - state) + (return* (&/update$ &/$type-vars #(->> % + (&/update$ &/$counter dec) + (&/set$ &/$mappings (&/|remove id mappings*))) + state) nil))) state)))) @@ -438,15 +435,13 @@ =param (clean* ?tid ?param)] (return (App$ =lambda =param))) - (&/$SumT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (Sum$ =left =right))) - - (&/$ProdT ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (Prod$ =left =right))) + (&/$TupleT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Tuple$ =members))) + + (&/$VariantT ?members) + (|do [=members (&/map% (partial clean* ?tid) ?members)] + (return (Variant$ =members))) (&/$AllT ?env ?name ?arg ?body) (|do [=env (|case ?env @@ -456,9 +451,9 @@ (&/$Some ?env*) (|do [clean-env (&/map% (fn [[k v]] (|do [=v (clean* ?tid v)] - (return (&/P k =v)))) + (return (&/T k =v)))) ?env*)] - (return (&/Some$ clean-env)))) + (return (&/V &/$Some clean-env)))) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -478,36 +473,37 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/P ??out (&/Cons$ ?in ?args))) + (&/T ??out (&/|cons ?in ?args))) _ - (&/P type (&/|list)))) + (&/T type (&/|list)))) (defn ^:private unravel-app [fun-type] (|case fun-type (&/$AppT ?left ?right) (|let [[?fun-type ?args] (unravel-app ?left)] - (&/P ?fun-type (&/|++ ?args (&/|list ?right)))) + (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/P fun-type (&/|list)))) + (&/T fun-type (&/|list)))) (defn show-type [^objects type] (|case type - (&/$VoidT) - "(|)" - - (&/$UnitT) - "(,)" - (&/$DataT name) (str "(^ " name ")") - (&/$ProdT left right) - (str "(, " (show-type left) " " (show-type right) ")") - - (&/$SumT left right) - (str "(| " (show-type left) " " (show-type right) ")") + (&/$TupleT elems) + (if (&/|empty? elems) + "(,)" + (str "(, " (->> elems (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) + + (&/$VariantT cases) + (if (&/|empty? cases) + "(|)" + (str "(| " (->> cases + (&/|map show-type) + (&/|interpose " ") + (&/fold str "")) ")")) (&/$LambdaT input output) (|let [[?out ?ins] (unravel-fun type)] @@ -548,22 +544,18 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] - [(&/$UnitT) (&/$UnitT)] - true - - [(&/$VoidT) (&/$VoidT)] - true - [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) - [(&/$ProdT xleft xright) (&/$ProdT yleft yright)] - (and (type= xleft yleft) - (type= xright yright)) + [(&/$TupleT xelems) (&/$TupleT yelems)] + (&/fold2 (fn [old x y] (and old (type= x y))) + true + xelems yelems) - [(&/$SumT xleft xright) (&/$SumT yleft yright)] - (and (type= xleft yleft) - (type= xright yright)) + [(&/$VariantT xcases) (&/$VariantT ycases)] + (&/fold2 (fn [old x y] (and old (type= x y))) + true + xcases ycases) [(&/$LambdaT xinput xoutput) (&/$LambdaT yinput youtput)] (and (type= xinput yinput) @@ -615,17 +607,17 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - &/None$ + (&/V &/$None nil) (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) (type= a a*)) - (&/Some$ v*) + (&/V &/$Some v*) (fp-get k fixpoints*)) ))) (defn ^:private fp-put [k v fixpoints] - (&/Cons$ (&/P k v) fixpoints)) + (&/|cons (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) @@ -634,11 +626,11 @@ (defn beta-reduce [env type] (|case type - (&/$SumT ?left ?right) - (Sum$ (beta-reduce env ?left) (beta-reduce env ?right)) + (&/$VariantT ?members) + (Variant$ (&/|map (partial beta-reduce env) ?members)) - (&/$ProdT ?left ?right) - (Prod$ (beta-reduce env ?left) (beta-reduce env ?right)) + (&/$TupleT ?members) + (Tuple$ (&/|map (partial beta-reduce env) ?members)) (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) @@ -646,7 +638,7 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env (&/$None) - (All$ (&/Some$ env) ?local-name ?local-arg ?local-def) + (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) (&/$Some _) type) @@ -685,7 +677,7 @@ (apply-type ?type param) _ - (fail (str "[Type Error] Not a type function:\n" (show-type type-fn) "\n")))) + (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) (defn as-obj [class] (case class @@ -705,35 +697,30 @@ (def ^:private init-fixpoints (&/|list)) (defn ^:private check* [class-loader fixpoints expected actual] - ;; (prn 'check*/_0 (&/adt->text expected) (&/adt->text actual)) - ;; (prn 'check*/_1 (show-type expected) (show-type actual)) (if (clojure.lang.Util/identical expected actual) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (|case [expected actual] - [(&/$UnitT) (&/$UnitT)] - (return (&/P fixpoints nil)) - [(&/$VarT ?eid) (&/$VarT ?aid)] (if (.equals ^Object ?eid ?aid) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (|do [ebound (fn [state] (|case ((deref ?eid) state) (&/$Right state* ebound) - (return* state* (&/Some$ ebound)) + (return* state* (&/V &/$Some ebound)) (&/$Left _) - (return* state &/None$))) + (return* state (&/V &/$None nil)))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) - (return* state* (&/Some$ abound)) + (return* state* (&/V &/$Some abound)) (&/$Left _) - (return* state &/None$)))] + (return* state (&/V &/$None nil))))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] - (return (&/P fixpoints nil))) + (return (&/T fixpoints nil))) [(&/$Some etype) (&/$None _)] (check* class-loader fixpoints etype actual) @@ -748,7 +735,7 @@ (fn [state] (|case ((set-var ?id actual) state) (&/$Right state* _) - (return* state* (&/P fixpoints nil)) + (return* state* (&/T fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -759,7 +746,7 @@ (fn [state] (|case ((set-var ?id expected) state) (&/$Right state* _) - (return* state* (&/P fixpoints nil)) + (return* state* (&/T fixpoints nil)) (&/$Left _) ((|do [bound (deref ?id)] @@ -770,9 +757,9 @@ (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) + (|case [((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state)] (&/$Right state* output) (return* state* output) @@ -793,11 +780,11 @@ (&/$Left _) ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) [fixpoints** _] (check* class-loader fixpoints* A1 A2)] - (return (&/P fixpoints** nil))) + (return (&/T fixpoints** nil))) state)))) ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) ;; _ (check* class-loader fixpoints A1 A2)] - ;; (return (&/P fixpoints nil))) + ;; (return (&/T fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] @@ -812,14 +799,14 @@ e* (apply-type F2 A1) a* (apply-type F2 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/P fixpoints** nil))) + (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) ;; a* (apply-type F2 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/P fixpoints** nil))) + ;; (return (&/T fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] @@ -834,22 +821,22 @@ e* (apply-type F1 A1) a* (apply-type F1 A2) [fixpoints** _] (check* class-loader fixpoints* e* a*)] - (return (&/P fixpoints** nil))) + (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) ;; a* (apply-type F1 A2) ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] - ;; (return (&/P fixpoints** nil))) + ;; (return (&/T fixpoints** nil))) [(&/$AppT F A) _] - (let [fp-pair (&/P expected actual) + (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) (println 'FIXPOINTS (->> (&/|keys fixpoints) (&/|map (fn [pair] (|let [[e a] pair] - (str (show-type e) " :+: " + (str (show-type e) ":+:" (show-type a))))) (&/|interpose "\n\n") (&/fold str ""))) @@ -857,7 +844,7 @@ (|case (fp-get fp-pair fixpoints) (&/$Some ?) (if ? - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (check-error expected actual))) (&/$None) @@ -883,33 +870,39 @@ [(&/$DataT e!name) (&/$DataT "null")] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/P fixpoints nil))) + (return (&/T fixpoints nil))) [(&/$DataT e!name) (&/$DataT a!name)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] (if (or (.equals ^Object e!name a!name) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] (check* class-loader fixpoints* eO aO)) - [(&/$ProdT e!left e!right) (&/$ProdT a!left a!right)] - (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) - [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] - (return (&/P fixpoints** nil))) + [(&/$TupleT e!members) (&/$TupleT a!members)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!members a!members)] + (return (&/T fixpoints* nil))) - [(&/$SumT e!left e!right) (&/$SumT a!left a!right)] - (|do [[fixpoints* _] (check* class-loader fixpoints e!left a!left) - [fixpoints** _] (check* class-loader fixpoints* e!right a!right)] - (return (&/P fixpoints** nil))) + [(&/$VariantT e!cases) (&/$VariantT a!cases)] + (|do [fixpoints* (&/fold2% (fn [fp e a] + (|do [[fp* _] (check* class-loader fp e a)] + (return fp*))) + fixpoints + e!cases a!cases)] + (return (&/T fixpoints* nil))) [(&/$ExT e!id) (&/$ExT a!id)] (if (.equals ^Object e!id a!id) - (return (&/P fixpoints nil)) + (return (&/T fixpoints nil)) (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] @@ -918,9 +911,6 @@ [_ (&/$NamedT ?aname ?atype)] (check* class-loader fixpoints expected ?atype) - [_ (&/$VoidT)] - (return (&/P fixpoints nil)) - [_ _] (fail (check-error expected actual)) ))) @@ -947,7 +937,7 @@ (apply-lambda ?type param) _ - (fail (str "[Type Error] Not a function type:\n" (show-type func) "\n")) + (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) )) (defn actual-type [type] @@ -968,31 +958,20 @@ )) (defn variant-case [tag type] - ;; (prn 'variant-case tag (show-type type)) (|case type (&/$NamedT ?name ?type) (variant-case tag ?type) - (&/$SumT ?left ?right) - (case tag - 0 - (return ?left) - - 1 - (|case ?right - (&/$SumT ?left* _) - (return ?left*) - - _ - (return ?right)) + (&/$VariantT ?cases) + (|case (&/|at tag ?cases) + (&/$Some case-type) + (return case-type) - ;; else - (variant-case (dec tag) ?right)) + (&/$None) + (fail (str "[Type Error] Variant lacks case: " tag " | " (show-type type)))) _ - (fail (str "[Type Error] Type is not a variant: " (show-type type))) - ;; (assert false (str "[Type Error] Type is not a variant: " (show-type type))) - )) + (fail (str "[Type Error] Type is not a variant: " (show-type type))))) (defn type-name [type] "(-> Type (Lux Ident))" -- cgit v1.2.3 From d916be54994c8266f005744f7c3a61a36a39e31d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 07:01:33 -0400 Subject: Changed the license from EPL to MPL. --- src/lux.clj | 11 ++++------- src/lux/analyser.clj | 11 ++++------- src/lux/analyser/base.clj | 11 ++++------- src/lux/analyser/case.clj | 11 ++++------- src/lux/analyser/env.clj | 11 ++++------- src/lux/analyser/host.clj | 11 ++++------- src/lux/analyser/lambda.clj | 11 ++++------- src/lux/analyser/lux.clj | 11 ++++------- src/lux/analyser/module.clj | 11 ++++------- src/lux/analyser/record.clj | 11 ++++------- src/lux/base.clj | 11 ++++------- src/lux/compiler.clj | 11 ++++------- src/lux/compiler/base.clj | 11 ++++------- src/lux/compiler/cache.clj | 11 ++++------- src/lux/compiler/case.clj | 11 ++++------- src/lux/compiler/host.clj | 11 ++++------- src/lux/compiler/io.clj | 11 ++++------- src/lux/compiler/lambda.clj | 11 ++++------- src/lux/compiler/lux.clj | 11 ++++------- src/lux/compiler/module.clj | 11 ++++------- src/lux/compiler/package.clj | 11 ++++------- src/lux/compiler/type.clj | 11 ++++------- src/lux/host.clj | 11 ++++------- src/lux/lexer.clj | 11 ++++------- src/lux/optimizer.clj | 11 ++++------- src/lux/parser.clj | 11 ++++------- src/lux/reader.clj | 11 ++++------- src/lux/type.clj | 11 ++++------- 28 files changed, 112 insertions(+), 196 deletions(-) (limited to 'src') diff --git a/src/lux.clj b/src/lux.clj index 7e3627cd7..03d09ebba 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux (:gen-class) diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 8c88328f5..7e5024c40 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index fe1e0d55b..8c52748d7 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.base (:require clojure.core.match diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 483002adc..5987cbdf7 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.case (:require clojure.core.match diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 4e9dcd79f..666807586 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.env (:require clojure.core.match diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 64f297994..8ccfc5ace 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.host (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index aeb5a4814..819f07583 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.lambda (:require clojure.core.match diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index d241201f4..634769839 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.lux (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index d23953f5e..77630bafe 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.module (:refer-clojure :exclude [alias]) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 2b4b7e095..c6bfb0053 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.analyser.record (:require clojure.core.match diff --git a/src/lux/base.clj b/src/lux/base.clj index 6247524af..44459beb4 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.base (:require (clojure [template :refer [do-template]]) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 79d2c84f8..b8ffa825f 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler (:refer-clojure :exclude [compile]) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 1e5f3a024..b6efaada8 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.base (:require (clojure [template :refer [do-template]] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index dc224f52e..da7ce35e9 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.cache (:refer-clojure :exclude [load]) diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index dd3258059..5f9d6cd2d 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.case (:require (clojure [set :as set] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 26ef73cb7..0529ac900 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.host (:require (clojure [string :as string] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 0e7982a7f..e72f34a7b 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.io (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 136ec0cfc..8fefab156 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.lambda (:require (clojure [string :as string] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 83e294c1a..3aa25ac99 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.lux (:require (clojure [string :as string] diff --git a/src/lux/compiler/module.clj b/src/lux/compiler/module.clj index db73e8bb4..b4b041049 100644 --- a/src/lux/compiler/module.clj +++ b/src/lux/compiler/module.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.module (:require (clojure [string :as string] diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj index 40639e85a..b1468e540 100644 --- a/src/lux/compiler/package.clj +++ b/src/lux/compiler/package.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.package (:require [clojure.core.match :as M :refer [matchv]] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 7e2bc6961..4b43673cc 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.compiler.type (:require clojure.core.match diff --git a/src/lux/host.clj b/src/lux/host.clj index dfd4df23d..3d61eec6a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.host (:require (clojure [string :as string] diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index e848cc3fd..6f5f2250d 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.lexer (:require [clojure.template :refer [do-template]] diff --git a/src/lux/optimizer.clj b/src/lux/optimizer.clj index 65dc4eb0d..1325a2e7d 100644 --- a/src/lux/optimizer.clj +++ b/src/lux/optimizer.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.optimizer (:require [lux.analyser :as &analyser])) diff --git a/src/lux/parser.clj b/src/lux/parser.clj index eaa22db20..9436eebc3 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.parser (:require [clojure.template :refer [do-template]] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index e3f95b5f9..aa845c09d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.reader (:require [clojure.string :as string] diff --git a/src/lux/type.clj b/src/lux/type.clj index 9f3adb036..f65fdbf12 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -1,10 +1,7 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; The use and distribution terms for this software are covered by the -;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) -;; which can be found in the file epl-v10.html at the root of this distribution. -;; By using this software in any fashion, you are agreeing to be bound by -;; the terms of this license. -;; You must not remove this notice, or any other, from this software. +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. (ns lux.type (:refer-clojure :exclude [deref apply merge bound?]) -- cgit v1.2.3 From a10d922283a9256f0f0015d9d00a0c549b1891cb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 17:58:32 -0400 Subject: The environments of AllT types are no longer stored inside a Maybe. --- src/lux/compiler/type.clj | 18 ++++++----------- src/lux/type.clj | 49 +++++++++++++++++------------------------------ 2 files changed, 24 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 4b43673cc..54a7c5e0c 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -60,18 +60,12 @@ (&/$AllT ?env ?name ?arg ?body) (variant$ &/$AllT - (tuple$ (&/|list (|case ?env - (&/$None) - (variant$ &/$None (tuple$ (&/|list))) - - (&/$Some ??env) - (variant$ &/$Some - (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) - $Nil - (&/|reverse ??env)))) + (tuple$ (&/|list (&/fold (fn [tail head] + (|let [[hlabel htype] head] + (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) + tail))) + $Nil + (&/|reverse ?env)) (text$ ?name) (text$ ?arg) (->analysis ?body)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f65fdbf12..bcef74475 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,8 +23,7 @@ _ false)) -(def ^:private empty-env (&/V &/$Some (&/V &/$Nil nil))) -(def ^:private no-env (&/V &/$None nil)) +(def ^:private empty-env (&/V &/$Nil nil)) (defn Data$ [name] (&/V &/$DataT name)) (defn Bound$ [name] @@ -106,7 +105,7 @@ ;; ExT Int ;; AllT - (Tuple$ (&/|list (App$ Maybe TypeEnv) Text Text Type)) + (Tuple$ (&/|list TypeEnv Text Text Type)) ;; AppT TypePair ;; NamedT @@ -117,7 +116,7 @@ (def Bindings (Named$ (&/T "lux" "Bindings") (All$ empty-env "lux;Bindings" "k" - (All$ no-env "" "v" + (All$ empty-env "" "v" (Tuple$ (&/|list ;; "lux;counter" Int @@ -131,7 +130,7 @@ (let [bindings (App$ (App$ Bindings (Bound$ "k")) (Bound$ "v"))] (All$ empty-env "lux;Env" "k" - (All$ no-env "" "v" + (All$ empty-env "" "v" (Tuple$ (&/|list ;; "lux;name" @@ -151,7 +150,7 @@ (def Meta (Named$ (&/T "lux" "Meta") (All$ empty-env "lux;Meta" "m" - (All$ no-env "" "v" + (All$ empty-env "" "v" (Variant$ (&/|list ;; &/$Meta (Tuple$ (&/|list (Bound$ "m") @@ -197,7 +196,7 @@ (def Either (Named$ (&/T "lux" "Either") (All$ empty-env "lux;Either" "l" - (All$ no-env "" "r" + (All$ empty-env "" "r" (Variant$ (&/|list ;; &/$Left (Bound$ "l") @@ -206,7 +205,7 @@ (def StateE (All$ empty-env "lux;StateE" "s" - (All$ no-env "" "a" + (All$ empty-env "" "a" (Lambda$ (Bound$ "s") (App$ (App$ Either Text) (Tuple$ (&/|list (Bound$ "s") @@ -441,16 +440,10 @@ (return (Variant$ =members))) (&/$AllT ?env ?name ?arg ?body) - (|do [=env (|case ?env - (&/$None) - (return ?env) - - (&/$Some ?env*) - (|do [clean-env (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?env*)] - (return (&/V &/$Some clean-env)))) + (|do [=env (&/map% (fn [[k v]] + (|do [=v (clean* ?tid v)] + (return (&/T k =v)))) + ?env) body* (clean* ?tid ?body)] (return (All$ =env ?name ?arg body*))) @@ -634,10 +627,10 @@ (&/$AllT ?local-env ?local-name ?local-arg ?local-def) (|case ?local-env - (&/$None) - (All$ (&/V &/$Some env) ?local-name ?local-arg ?local-def) + (&/$Nil) + (All$ env ?local-name ?local-arg ?local-def) - (&/$Some _) + _ type) (&/$LambdaT ?input ?output) @@ -655,16 +648,10 @@ (defn apply-type [type-fn param] (|case type-fn (&/$AllT local-env local-name local-arg local-def) - (let [local-env* (|case local-env - (&/$None) - (&/|table) - - (&/$Some local-env*) - local-env*)] - (return (beta-reduce (->> local-env* - (&/|put local-name type-fn) - (&/|put local-arg param)) - local-def))) + (return (beta-reduce (->> local-env + (&/|put local-name type-fn) + (&/|put local-arg param)) + local-def)) (&/$AppT F A) (|do [type-fn* (apply-type F A)] -- cgit v1.2.3 From 8de225f98aaed212bf3b683208bff5c6ab85a835 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 28 Aug 2015 22:46:12 -0400 Subject: - Changed the name of AllT (for-all type) to UnivQ (universal quantification). - UnivQ no longer stores the environment as key-val pairs with Text names, but instead stores it as type-lists with variables accessed via an index through a (updated) BoundT. - UnivQ no longer stores the name of the type-fun, not the name of the type-arg. --- src/lux/analyser/case.clj | 44 +++-- src/lux/analyser/env.clj | 4 +- src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 63 +++---- src/lux/analyser/module.clj | 2 +- src/lux/base.clj | 37 ++-- src/lux/compiler/type.clj | 19 +- src/lux/reader.clj | 4 +- src/lux/type.clj | 445 +++++++++++++++++++++----------------------- 9 files changed, 290 insertions(+), 330 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 5987cbdf7..829b5b6d8 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -48,7 +48,7 @@ (fail "##9##")))] (resolve-type type*)) - (&/$AllT _aenv _aname _aarg _abody) + (&/$UnivQ _) ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] @@ -61,42 +61,46 @@ _ (&type/actual-type type))) +(defn update-up-frame [frame] + (|let [[_env _idx _var] frame] + (&/T _env (+ 2 _idx) _var))) + (defn adjust-type* [up type] - "(-> (List (, (Maybe (Env Text Type)) Text Text Type)) Type (Lux Type))" + "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" ;; (prn 'adjust-type* (&type/show-type type)) (|case type - (&/$AllT _aenv _aname _aarg _abody) + (&/$UnivQ _aenv _abody) (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/|cons (&/T _aenv _aname _aarg $var) up) =type)))) + (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) (&/$TupleT ?members) (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] (&type/clean* _avar _abody)))) type up)] (return (&type/Tuple$ (&/|map (fn [v] (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + (|let [[_aenv _aidx _avar] ena] + (&/V &/$UnivQ (&/T _aenv _abody)))) v up)) ?members*)))) (&/$VariantT ?members) (|do [(&/$VariantT ?members*) (&/fold% (fn [_abody ena] - (|let [[_aenv _aname _aarg (&/$VarT _avar)] ena] - (|do [_ (&type/set-var _avar (&/V &/$BoundT _aarg))] + (|let [[_aenv _aidx (&/$VarT _avar)] ena] + (|do [_ (&type/set-var _avar (&/V &/$BoundT _aidx))] (&type/clean* _avar _abody)))) type up)] (return (&/V &/$VariantT (&/|map (fn [v] (&/fold (fn [_abody ena] - (|let [[_aenv _aname _aarg _avar] ena] - (&/V &/$AllT (&/T _aenv _aname _aarg _abody)))) + (|let [[_aenv _aidx _avar] ena] + (&/V &/$UnivQ (&/T _aenv _abody)))) v up)) ?members*)))) @@ -169,7 +173,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) + (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] (return (&/T (&/|list) =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] @@ -192,7 +196,7 @@ (|do [[=tests =kont] (&/fold (fn [kont* vm] (|let [[v m] vm] (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/|cons =test =tests) =kont))))) + (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] (return (&/T (&/|list) =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] @@ -242,7 +246,7 @@ (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] (|do [pattern+body (analyse-pattern value-type pattern (&&/analyse-1 analyse exo-type body))] - (return (&/|cons pattern+body patterns)))) + (return (&/Cons$ pattern+body patterns)))) (let [compare-kv #(.compareTo ^String (aget ^objects %1 0) ^String (aget ^objects %2 0))] (defn ^:private merge-total [struct test+body] @@ -258,31 +262,31 @@ (return (&/V $BoolTotal (&/T total? (&/|list ?value)))) [($BoolTotal total? ?values) ($BoolTestAC ?value)] - (return (&/V $BoolTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $BoolTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($IntTestAC ?value)] (return (&/V $IntTotal (&/T total? (&/|list ?value)))) [($IntTotal total? ?values) ($IntTestAC ?value)] - (return (&/V $IntTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $IntTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($RealTestAC ?value)] (return (&/V $RealTotal (&/T total? (&/|list ?value)))) [($RealTotal total? ?values) ($RealTestAC ?value)] - (return (&/V $RealTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $RealTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($CharTestAC ?value)] (return (&/V $CharTotal (&/T total? (&/|list ?value)))) [($CharTotal total? ?values) ($CharTestAC ?value)] - (return (&/V $CharTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $CharTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TextTestAC ?value)] (return (&/V $TextTotal (&/T total? (&/|list ?value)))) [($TextTotal total? ?values) ($TextTestAC ?value)] - (return (&/V $TextTotal (&/T total? (&/|cons ?value ?values)))) + (return (&/V $TextTotal (&/T total? (&/Cons$ ?value ?values)))) [($DefaultTotal total?) ($TupleTestAC ?tests)] (|do [structs (&/map% (fn [t] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 666807586..66478eecc 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -22,7 +22,7 @@ =return (body (&/update$ &/$envs (fn [stack] (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] - (&/|cons (&/update$ &/$locals #(->> % + (&/Cons$ (&/update$ &/$locals #(->> % (&/update$ &/$counter inc) (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) (&/|head stack)) @@ -31,7 +31,7 @@ (|case =return (&/$Right ?state ?value) (return* (&/update$ &/$envs (fn [stack*] - (&/|cons (&/update$ &/$locals #(->> % + (&/Cons$ (&/update$ &/$locals #(->> % (&/update$ &/$counter dec) (&/set$ &/$mappings old-mappings)) (&/|head stack*)) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 8ccfc5ace..098dc89df 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -313,7 +313,7 @@ (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/|cons (&/T ";this" ?super-class) + (&/Cons$ (&/T ";this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 634769839..c3f7622b8 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -42,7 +42,7 @@ (return (&/|list (&/T (&/V &&/$tuple =elems) exo-type)))) - (&/$AllT _) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -90,7 +90,7 @@ (&/$None) (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) - (&/$AllT _) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -98,41 +98,20 @@ _ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) -;; (defn analyse-variant [analyse exo-type ident ?values] -;; (|do [exo-type* (|case exo-type -;; (&/$VarT ?id) -;; (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] -;; (&type/actual-type exo-type*)) -;; (|do [_ (&type/set-var ?id &type/Type)] -;; (&type/actual-type &type/Type)))) - -;; _ -;; (&type/actual-type exo-type))] -;; (|case exo-type* -;; (&/$VariantT ?cases) -;; (|do [?tag (&&/resolved-ident ident)] -;; (if-let [vtype (&/|get ?tag ?cases)] -;; (|do [=value (analyse-variant-body analyse vtype ?values)] -;; (return (&/|list (&/T (&/V &&/$variant (&/T ?tag =value)) -;; exo-type)))) -;; (fail (str "[Analyser Error] There is no case " ?tag " for variant type " (&type/show-type exo-type*))))) - -;; (&/$AllT _) -;; (&type/with-var -;; (fn [$var] -;; (|do [exo-type** (&type/apply-type exo-type* $var)] -;; (analyse-variant analyse exo-type** ident ?values)))) - -;; _ -;; (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] + ;; (when @&type/!flag + ;; (prn 'analyse-record (&type/show-type exo-type) + ;; (&/->seq (&/|map (fn [pair] + ;; (|let [[k v] pair] + ;; (str (&/show-ast k) " " (&/show-ast v)))) + ;; ?elems)))) (|do [exo-type* (|case exo-type (&/$VarT ?id) (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) - (&/$AllT _) + (&/$UnivQ _) (|do [$var &type/existential =type (&type/apply-type exo-type $var)] (&type/actual-type =type)) @@ -148,7 +127,7 @@ (return ?table) _ - (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*)))) + (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*) "\n" (&type/show-type exo-type)))) _ (&/assert! (= (&/|length types) (&/|length ?elems)) (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) members (&&record/order-record ?elems) @@ -221,13 +200,13 @@ (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/|cons (&/get$ &/$name %2) %1) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) (&/|map #(&/get$ &/$name %) outer) (&/|reverse inner))) [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] (|let [[register new-inner] register+new-inner [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T register* (&/|cons frame* new-inner)))) + (&/T register* (&/Cons$ frame* new-inner)))) (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) @@ -255,7 +234,7 @@ (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* - (&/$AllT _aenv _aname _aarg _abody) + (&/$UnivQ _) ;; (|do [$var &type/existential ;; type* (&type/apply-type ?fun-type* $var)] ;; (analyse-apply* analyse exo-type type* ?args)) @@ -268,7 +247,7 @@ (|do [? (&type/bound? ?id) type** (if ? (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (&/V &/$BoundT _aarg))] + (|do [_ (&type/set-var ?id (&/V &/$BoundT 1))] (&type/clean $var =output-t)))] (return (&/T type** =args))) )))) @@ -276,7 +255,7 @@ (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) =arg (&&/analyse-1 analyse ?input-t ?arg)] - (return (&/T =output-t (&/|cons =arg =args)))) + (return (&/T =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] ;; (|do [ (&type/deref ?id-t)]) @@ -332,7 +311,7 @@ (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type - (&/$AllT _) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var)] @@ -353,7 +332,7 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type - (&/$AllT _env _self _arg _body) + (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type* (&type/apply-type exo-type $var) @@ -376,12 +355,12 @@ (|do [?? (&type/bound? ?_id)] ;; (return (&/T _expr exo-type)) (if ?? - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))) + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) (return (&/T _expr exo-type))) ) _ - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id ":" _arg " " (&type/show-type dtype))))) + (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) (return (&/T _expr exo-type)))))))) _ @@ -395,8 +374,8 @@ (defn analyse-def [analyse compile-token ?name ?value] ;; (prn 'analyse-def/BEGIN ?name) - ;; (when (= "PList/Dict" ?name) - ;; (prn 'DEF ?name (&/show-ast ?value))) + ;; (when (= "monoid$" ?name) + ;; (reset! &type/!flag true)) (|do [module-name &/get-module-name ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))] ? (&&module/defined? module-name ?name)] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 77630bafe..6eca13b44 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -41,7 +41,7 @@ (return* (&/update$ &/$modules (fn [ms] (&/|update current-module - (fn [m] (&/update$ $imports (partial &/|cons module) m)) + (fn [m] (&/update$ $imports (partial &/Cons$ module) m)) ms)) state) nil)))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 44459beb4..5444c6c81 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -54,7 +54,7 @@ "BoundT" "VarT" "ExT" - "AllT" + "UnivQ" "AppT" "NamedT") @@ -285,9 +285,6 @@ (reverse (partition 2 steps)))) ;; [Resources/Combinators] -(defn |cons [head tail] - (V $Cons (T head tail))) - (defn |++ [xs ys] (|case xs ($Nil) @@ -348,7 +345,7 @@ ($Cons x xs*) (if (p x) (|let [[pre post] (|split-with p xs*)] - (T (|cons x pre) post)) + (T (Cons$ x pre) post)) (T (V $Nil nil) xs)))) (defn |contains? [k table] @@ -383,7 +380,7 @@ (|list init) ($Cons x xs*) - (|cons init (folds f (f init x) xs*)))) + (Cons$ init (folds f (f init x) xs*)))) (defn |length [xs] (fold (fn [acc _] (inc acc)) 0 xs)) @@ -417,7 +414,7 @@ (|list) ($Cons [k v] plist*) - (|cons k (|keys plist*)))) + (Cons$ k (|keys plist*)))) (defn |vals [plist] (|case plist @@ -425,7 +422,7 @@ (|list) ($Cons [k v] plist*) - (|cons v (|vals plist*)))) + (Cons$ v (|vals plist*)))) (defn |interpose [sep xs] (|case xs @@ -449,7 +446,7 @@ ys ( f xs*)] (return ( y ys))))) - map% |cons + map% Cons$ flat-map% |++) (defn list-join [xss] @@ -465,7 +462,7 @@ (defn |reverse [xs] (fold (fn [tail head] - (|cons head tail)) + (Cons$ head tail)) (|list) xs)) @@ -501,7 +498,7 @@ (defn repeat% [monad] (try-all% (|list (|do [head monad tail (repeat% monad)] - (return (|cons head tail))) + (return (Cons$ head tail))) (return (|list))))) (defn exhaust% [step] @@ -677,11 +674,11 @@ (defn ->list [seq] (if (empty? seq) (|list) - (|cons (first seq) (->list (rest seq))))) + (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) - (|cons x (|repeat (dec n) x)) + (Cons$ x (|repeat (dec n) x)) (|list))) (def get-module-name @@ -707,7 +704,7 @@ (defn with-scope [name body] (fn [state] - (let [output (body (update$ $envs #(|cons (env name) %) state))] + (let [output (body (update$ $envs #(Cons$ (env name) %) state))] (|case output ($Right state* datum) (return* (update$ $envs |tail state*) datum) @@ -723,7 +720,7 @@ (return (->> top (get$ $inner-closures) str)))] (fn [state] (let [body* (with-scope closure-name body)] - (run-state body* (update$ $envs #(|cons (update$ $inner-closures inc (|head %)) + (run-state body* (update$ $envs #(Cons$ (update$ $inner-closures inc (|head %)) (|tail %)) state)))))) @@ -789,10 +786,10 @@ ($Meta _ ($TagS ?module ?tag)) (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?ident)) + ($Meta _ ($SymbolS ?module ?name)) (if (.equals "" ?module) - ?ident - (str ?module ";" ?ident)) + ?name + (str ?module ";" ?name)) ($Meta _ ($TupleS ?elems)) (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") @@ -832,7 +829,7 @@ [($Cons x xs*) ($Cons y ys*)] (|do [z (f x y) zs (map2% f xs* ys*)] - (return (|cons z zs))) + (return (Cons$ z zs))) [($Nil) ($Nil)] (return (V $Nil nil)) @@ -843,7 +840,7 @@ (defn map2 [f xs ys] (|case [xs ys] [($Cons x xs*) ($Cons y ys*)] - (|cons (f x y) (map2 f xs* ys*)) + (Cons$ (f x y) (map2 f xs* ys*)) [_ _] (V $Nil nil))) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 54a7c5e0c..0d0300844 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -21,6 +21,11 @@ (&/T (&/V &a/$tuple members) &type/$Void)) +(defn ^:private int$ [value] + "(-> Int Analysis)" + (&/T (&/V &a/$int value) + &type/$Void)) + (defn ^:private text$ [text] "(-> Text Analysis)" (&/T (&/V &a/$text text) @@ -58,20 +63,16 @@ (&/$LambdaT ?input ?output) (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - (&/$AllT ?env ?name ?arg ?body) - (variant$ &/$AllT + (&/$UnivQ ?env ?body) + (variant$ &/$UnivQ (tuple$ (&/|list (&/fold (fn [tail head] - (|let [[hlabel htype] head] - (Cons$ (tuple$ (&/|list (text$ hlabel) (->analysis htype))) - tail))) + (Cons$ (->analysis head) tail)) $Nil (&/|reverse ?env)) - (text$ ?name) - (text$ ?arg) (->analysis ?body)))) - (&/$BoundT ?name) - (variant$ &/$BoundT (text$ ?name)) + (&/$BoundT ?idx) + (variant$ &/$BoundT (int$ ?idx)) (&/$AppT ?fun ?arg) (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) diff --git a/src/lux/reader.clj b/src/lux/reader.clj index aa845c09d..0fcb5097b 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -33,7 +33,7 @@ output) ($Yes output line*) - (return* (&/set$ &/$source (&/|cons line* more) state) + (return* (&/set$ &/$source (&/Cons$ line* more) state) output)) ))) @@ -117,7 +117,7 @@ column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (recur (str prefix match "\n") reader**) - (&/V &/$Right (&/T (&/|cons (&/T (&/T file-name line-num column-num*) line) + (&/V &/$Right (&/T (&/Cons$ (&/T (&/T file-name line-num column-num*) line) reader**) (&/T (&/T file-name line-num column-num) (str prefix match)))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index bcef74475..2b06553c3 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -40,8 +40,8 @@ (defn Variant$ [members] ;; (assert (|list? members)) (&/V &/$VariantT members)) -(defn All$ [env name arg body] - (&/V &/$AllT (&/T env name arg body))) +(defn Univ$ [env body] + (&/V &/$UnivQ (&/T env body))) (defn Named$ [name type] (&/V &/$NamedT (&/T name type))) @@ -57,91 +57,90 @@ (def IO (Named$ (&/T "lux/data" "IO") - (All$ empty-env "IO" "a" - (Lambda$ Unit (Bound$ "a"))))) + (Univ$ empty-env + (Lambda$ Unit (Bound$ 1))))) (def List (Named$ (&/T "lux" "List") - (All$ empty-env "lux;List" "a" - (Variant$ (&/|list - ;; lux;Nil - Unit - ;; lux;Cons - (Tuple$ (&/|list (Bound$ "a") - (App$ (Bound$ "lux;List") - (Bound$ "a")))) - ))))) + (Univ$ empty-env + (Variant$ (&/|list + ;; lux;Nil + Unit + ;; lux;Cons + (Tuple$ (&/|list (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1)))) + ))))) (def Maybe (Named$ (&/T "lux" "Maybe") - (All$ empty-env "lux;Maybe" "a" - (Variant$ (&/|list - ;; lux;None - Unit - ;; lux;Some - (Bound$ "a") - ))))) + (Univ$ empty-env + (Variant$ (&/|list + ;; lux;None + Unit + ;; lux;Some + (Bound$ 1) + ))))) (def Type (Named$ (&/T "lux" "Type") - (let [Type (App$ (Bound$ "Type") (Bound$ "_")) + (let [Type (App$ (Bound$ 0) (Bound$ 1)) TypeList (App$ List Type) - TypeEnv (App$ List (Tuple$ (&/|list Text Type))) TypePair (Tuple$ (&/|list Type Type))] - (App$ (All$ empty-env "Type" "_" - (Variant$ (&/|list - ;; DataT - Text - ;; VariantT - TypeList - ;; TupleT - TypeList - ;; LambdaT - TypePair - ;; BoundT - Text - ;; VarT - Int - ;; ExT - Int - ;; AllT - (Tuple$ (&/|list TypeEnv Text Text Type)) - ;; AppT - TypePair - ;; NamedT - (Tuple$ (&/|list Ident Type)) - ))) + (App$ (Univ$ empty-env + (Variant$ (&/|list + ;; DataT + Text + ;; VariantT + TypeList + ;; TupleT + TypeList + ;; LambdaT + TypePair + ;; BoundT + Int + ;; VarT + Int + ;; ExT + Int + ;; UnivQ + (Tuple$ (&/|list TypeList Type)) + ;; AppT + TypePair + ;; NamedT + (Tuple$ (&/|list Ident Type)) + ))) $Void)))) (def Bindings (Named$ (&/T "lux" "Bindings") - (All$ empty-env "lux;Bindings" "k" - (All$ empty-env "" "v" - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ "k") - (Bound$ "v")))))))))) + (Univ$ empty-env + (Univ$ empty-env + (Tuple$ (&/|list + ;; "lux;counter" + Int + ;; "lux;mappings" + (App$ List + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1)))))))))) (def Env (Named$ (&/T "lux" "Env") - (let [bindings (App$ (App$ Bindings (Bound$ "k")) - (Bound$ "v"))] - (All$ empty-env "lux;Env" "k" - (All$ empty-env "" "v" - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) + (let [bindings (App$ (App$ Bindings (Bound$ 3)) + (Bound$ 1))] + (Univ$ empty-env + (Univ$ empty-env + (Tuple$ + (&/|list + ;; "lux;name" + Text + ;; "lux;inner-closures" + Int + ;; "lux;locals" + bindings + ;; "lux;closure" + bindings + ))))))) (def Cursor (Named$ (&/T "lux" "Cursor") @@ -149,42 +148,42 @@ (def Meta (Named$ (&/T "lux" "Meta") - (All$ empty-env "lux;Meta" "m" - (All$ empty-env "" "v" - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ "m") - (Bound$ "v"))))))))) + (Univ$ empty-env + (Univ$ empty-env + (Variant$ (&/|list + ;; &/$Meta + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1))))))))) (def AST* (Named$ (&/T "lux" "AST'") - (let [AST* (App$ (Bound$ "w") - (App$ (Bound$ "lux;AST'") - (Bound$ "w"))) + (let [AST* (App$ (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1))) AST*List (App$ List AST*)] - (All$ empty-env "lux;AST'" "w" - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) + (Univ$ empty-env + (Variant$ (&/|list + ;; &/$BoolS + Bool + ;; &/$IntS + Int + ;; &/$RealS + Real + ;; &/$CharS + Char + ;; &/$TextS + Text + ;; &/$SymbolS + Ident + ;; &/$TagS + Ident + ;; &/$FormS + AST*List + ;; &/$TupleS + AST*List + ;; &/$RecordS + (App$ List (Tuple$ (&/|list AST* AST*)))) + ))))) (def AST (Named$ (&/T "lux" "AST") @@ -195,21 +194,21 @@ (def Either (Named$ (&/T "lux" "Either") - (All$ empty-env "lux;Either" "l" - (All$ empty-env "" "r" - (Variant$ (&/|list - ;; &/$Left - (Bound$ "l") - ;; &/$Right - (Bound$ "r"))))))) + (Univ$ empty-env + (Univ$ empty-env + (Variant$ (&/|list + ;; &/$Left + (Bound$ 3) + ;; &/$Right + (Bound$ 1))))))) (def StateE - (All$ empty-env "lux;StateE" "s" - (All$ empty-env "" "a" - (Lambda$ (Bound$ "s") - (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ "s") - (Bound$ "a")))))))) + (Univ$ empty-env + (Univ$ empty-env + (Lambda$ (Bound$ 3) + (App$ (App$ Either Text) + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1)))))))) (def Source (Named$ (&/T "lux" "Source") @@ -229,17 +228,17 @@ (Data$ "clojure.lang.Atom"))))) (def DefData* - (All$ empty-env "lux;DefData'" "" - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ "") - ;; "lux;AliasD" - Ident - )))) + (Univ$ empty-env + (Variant$ (&/|list + ;; "lux;ValueD" + (Tuple$ (&/|list Type Unit)) + ;; "lux;TypeD" + Type + ;; "lux;MacroD" + (Bound$ 1) + ;; "lux;AliasD" + Ident + )))) (def LuxVar (Named$ (&/T "lux" "LuxVar") @@ -250,63 +249,63 @@ Ident)))) (def $Module - (All$ empty-env "lux;$Module" "Compiler" - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ "Compiler")) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) + (Univ$ empty-env + (Tuple$ + (&/|list + ;; "lux;module-aliases" + (App$ List (Tuple$ (&/|list Text Text))) + ;; "lux;defs" + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Bool + (App$ DefData* + (Lambda$ ASTList + (App$ (App$ StateE (Bound$ 1)) + ASTList)))))))) + ;; "lux;imports" + (App$ List Text) + ;; "lux;tags" + ;; (List (, Text (, Int (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list Int + (App$ List Ident) + Type))))) + ;; "lux;types" + ;; (List (, Text (, (List Ident) Type))) + (App$ List + (Tuple$ (&/|list Text + (Tuple$ (&/|list (App$ List Ident) + Type))))) + )))) (def $Compiler (Named$ (&/T "lux" "Compiler") - (App$ (All$ empty-env "lux;Compiler" "" - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ "lux;Compiler") (Bound$ "")))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) + (App$ (Univ$ empty-env + (Tuple$ + (&/|list + ;; "lux;source" + Source + ;; "lux;cursor" + Cursor + ;; "lux;modules" + (App$ List (Tuple$ (&/|list Text + (App$ $Module (App$ (Bound$ 0) (Bound$ 1)))))) + ;; "lux;envs" + (App$ List + (App$ (App$ Env Text) + (Tuple$ (&/|list LuxVar Type)))) + ;; "lux;types" + (App$ (App$ Bindings Int) Type) + ;; "lux;expected" + Type + ;; "lux;seed" + Int + ;; "lux;eval?" + Bool + ;; "lux;host" + Host + ))) $Void))) (def Macro @@ -439,13 +438,10 @@ (|do [=members (&/map% (partial clean* ?tid) ?members)] (return (Variant$ =members))) - (&/$AllT ?env ?name ?arg ?body) - (|do [=env (&/map% (fn [[k v]] - (|do [=v (clean* ?tid v)] - (return (&/T k =v)))) - ?env) + (&/$UnivQ ?env ?body) + (|do [=env (&/map% (partial clean* ?tid) ?env) body* (clean* ?tid ?body)] - (return (All$ =env ?name ?arg body*))) + (return (Univ$ =env body*))) _ (return type) @@ -463,7 +459,7 @@ (|case type (&/$LambdaT ?in ?out) (|let [[??out ?args] (unravel-fun ?out)] - (&/T ??out (&/|cons ?in ?args))) + (&/T ??out (&/Cons$ ?in ?args))) _ (&/T type (&/|list)))) @@ -505,26 +501,16 @@ (&/$ExT ?id) (str "⟨" ?id "⟩") - (&/$BoundT name) - name + (&/$BoundT idx) + (str idx) (&/$AppT _ _) (|let [[?call-fun ?call-args] (unravel-app type)] (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - (&/$AllT ?env ?name ?arg ?body) - (if (= "" ?name) - (let [[args body] (loop [args (list ?arg) - body* ?body] - (|case body* - (&/$AllT ?env* ?name* ?arg* ?body*) - (recur (cons ?arg* args) ?body*) - - _ - [args body*]))] - (str "(All " ?name " [" (->> args reverse (interpose " ") (reduce str "")) "] " (show-type body) ")")) - ?name) - + (&/$UnivQ ?env ?body) + (str "(All " (show-type ?body) ")") + (&/$NamedT ?name ?type) (&/ident->text ?name) @@ -554,8 +540,8 @@ [(&/$VarT xid) (&/$VarT yid)] (.equals ^Object xid yid) - [(&/$BoundT xname) (&/$BoundT yname)] - (.equals ^Object xname yname) + [(&/$BoundT xidx) (&/$BoundT yidx)] + (= xidx yidx) [(&/$ExT xid) (&/$ExT yid)] (.equals ^Object xid yid) @@ -563,24 +549,8 @@ [(&/$AppT xlambda xparam) (&/$AppT ylambda yparam)] (and (type= xlambda ylambda) (type= xparam yparam)) - [(&/$AllT xenv xname xarg xbody) (&/$AllT yenv yname yarg ybody)] - (and (.equals ^Object xname yname) - (.equals ^Object xarg yarg) - ;; (matchv ::M/objects [xenv yenv] - ;; [[&/$None _] [&/$None _]] - ;; true - - ;; [[&/$Some xenv*] [&/$Some yenv*]] - ;; (&/fold (fn [old bname] - ;; (and old - ;; (type= (&/|get bname xenv*) (&/|get bname yenv*)))) - ;; (= (&/|length xenv*) (&/|length yenv*)) - ;; (&/|keys xenv*)) - - ;; [_ _] - ;; false) - (type= xbody ybody) - ) + [(&/$UnivQ xenv xbody) (&/$UnivQ yenv ybody)] + (type= xbody ybody) [(&/$NamedT ?xname ?xtype) _] (type= ?xtype y) @@ -607,14 +577,18 @@ ))) (defn ^:private fp-put [k v fixpoints] - (&/|cons (&/T k v) fixpoints)) + (&/Cons$ (&/T k v) fixpoints)) (defn ^:private check-error [expected actual] (str "[Type Checker]\nExpected: " (show-type expected) "\n\nActual: " (show-type actual) "\n")) +;; (def !flag (atom false)) + (defn beta-reduce [env type] + ;; (when @!flag + ;; (prn 'beta-reduce (show-type type))) (|case type (&/$VariantT ?members) (Variant$ (&/|map (partial beta-reduce env) ?members)) @@ -625,10 +599,10 @@ (&/$AppT ?type-fn ?type-arg) (App$ (beta-reduce env ?type-fn) (beta-reduce env ?type-arg)) - (&/$AllT ?local-env ?local-name ?local-arg ?local-def) + (&/$UnivQ ?local-env ?local-def) (|case ?local-env (&/$Nil) - (All$ env ?local-name ?local-arg ?local-def) + (Univ$ env ?local-def) _ type) @@ -636,21 +610,26 @@ (&/$LambdaT ?input ?output) (Lambda$ (beta-reduce env ?input) (beta-reduce env ?output)) - (&/$BoundT ?name) - (if-let [bound (&/|get ?name env)] + (&/$BoundT ?idx) + (|case (&/|at ?idx env) + (&/$Some bound) (beta-reduce env bound) - type) + + _ + (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) _ type )) (defn apply-type [type-fn param] + ;; (when @!flag + ;; (prn 'apply-type (show-type type-fn) (show-type param))) (|case type-fn - (&/$AllT local-env local-name local-arg local-def) + (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/|put local-name type-fn) - (&/|put local-arg param)) + (&/Cons$ param) + (&/Cons$ type-fn)) local-def)) (&/$AppT F A) @@ -839,13 +818,13 @@ (|do [actual* (apply-type F A)] (check* class-loader fixpoints expected actual*)) - [(&/$AllT _) _] + [(&/$UnivQ _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] (check* class-loader fixpoints expected* actual)))) - [_ (&/$AllT _)] + [_ (&/$UnivQ _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] @@ -910,7 +889,7 @@ (|do [_ (check* init-fixpoints input param)] (return output)) - (&/$AllT _) + (&/$UnivQ _) (with-var (fn [$var] (|do [func* (apply-type func $var) -- cgit v1.2.3 From cc928a8675cb35dabd4a4957ab6612b70f015d58 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 18:12:27 -0400 Subject: - Removed the (unnecessary) lux/data/cont module. - Removed the (unnecessary) lux/data/error module and moved it's structures to lux/data/either. - Implemented the \slots destructurer for records. - Implemented quicksort for lists as the "sort" function in lux/data/list. - Added tags for the Cursor type. --- src/lux/compiler/io.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index e72f34a7b..93be57f17 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -12,4 +12,4 @@ (let [file (new java.io.File path)] (if (.exists file) (return (slurp file)) - (fail (str "[I/O] File doesn't exist: " path))))) + (fail (str "[I/O Error] File doesn't exist: " path))))) -- cgit v1.2.3 From 253d5a4a3f7ef5d42c467733e394a28d18a4d9b3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 19:39:10 -0400 Subject: - Added some compiler optimizations. - Removed the (unnecessary) lux/control/dict & lux/control/stack modules. - The "Meta" type is now a record instead of a variant. --- src/lux/analyser.clj | 314 ++++++++++++++++++++++---------------------- src/lux/analyser/case.clj | 8 +- src/lux/analyser/host.clj | 56 ++++---- src/lux/analyser/lux.clj | 6 - src/lux/analyser/record.clj | 4 +- src/lux/base.clj | 24 ++-- src/lux/lexer.clj | 18 +-- src/lux/parser.clj | 26 ++-- src/lux/type.clj | 10 +- 9 files changed, 229 insertions(+), 237 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 7e5024c40..3ff214ee0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -20,16 +20,16 @@ ;; [Utils] (defn ^:private parse-handler [[catch+ finally+] token] (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_catch")) - (&/$Cons (&/$Meta _ (&/$TextS ?ex-class)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ex-arg)) - (&/$Cons ?catch-body - (&/$Nil))))))) + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_catch")] + (&/$Cons [_ (&/$TextS ?ex-class)] + (&/$Cons [_ (&/$SymbolS "" ?ex-arg)] + (&/$Cons ?catch-body + (&/$Nil))))))] (return (&/T (&/|++ catch+ (&/|list (&/T ?ex-class ?ex-arg ?catch-body))) finally+)) - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_finally")) - (&/$Cons ?finally-body - (&/$Nil))))) + [meta (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_finally")] + (&/$Cons ?finally-body + (&/$Nil))))] (return (&/T catch+ (&/V &/$Some ?finally-body))) _ @@ -37,7 +37,7 @@ (defn ^:private parse-tag [ast] (|case ast - (&/$Meta _ (&/$TagS "" name)) + [_ (&/$TagS "" name)] (return name) _ @@ -46,44 +46,44 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new-array")) - (&/$Cons (&/$Meta _ (&/$SymbolS _ ?class)) - (&/$Cons (&/$Meta _ (&/$IntS ?length)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] + (&/$Cons [_ (&/$SymbolS _ ?class)] + (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) (&&host/analyse-jvm-new-array analyse ?class ?length) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aastore")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_aaload")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array - (&/$Cons (&/$Meta _ (&/$IntS ?idx)) + (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) (&&host/analyse-jvm-aaload analyse ?array ?idx) ;; Classes & interfaces - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_class")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TextS ?super-class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?interfaces)) - (&/$Cons (&/$Meta _ (&/$TupleS ?fields)) - (&/$Cons (&/$Meta _ (&/$TupleS ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_interface")) - (&/$Cons (&/$Meta _ (&/$TextS ?name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?supers)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] + (&/$Cons [_ (&/$TextS ?name)] + (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) ;; Programs - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_program")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] + (&/$Cons [_ (&/$SymbolS "" ?args)] (&/$Cons ?body (&/$Nil))))) (&&host/analyse-jvm-program analyse compile-token ?args ?body) @@ -94,86 +94,86 @@ (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_d2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-d2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2i analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_f2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_f2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-f2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2b")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2b")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2b analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2c")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2c")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2c analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2l")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2l")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2l analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_i2s")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_i2s")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-i2s analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2d")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2d")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2d analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2f")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2f")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2f analyse exo-type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_l2i")) (&/$Cons ?value (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) ;; Bitwise operators - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iand")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ior")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ixor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ishr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_land")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-land analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lxor")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshl")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lshr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lushr")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) _ @@ -182,106 +182,106 @@ (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Objects - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_null?")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_null?")] (&/$Cons ?object (&/$Nil)))) (&&host/analyse-jvm-null? analyse exo-type ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_instanceof")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_instanceof")] + (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?object (&/$Nil))))) (&&host/analyse-jvm-instanceof analyse exo-type ?class ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_new")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Nil))))) (&&host/analyse-jvm-getstatic analyse exo-type ?class ?field) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_getfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Nil)))))) (&&host/analyse-jvm-getfield analyse exo-type ?class ?field ?object) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putstatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putstatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?value (&/$Nil)))))) (&&host/analyse-jvm-putstatic analyse exo-type ?class ?field ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_putfield")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?field)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?field)] (&/$Cons ?object (&/$Cons ?value (&/$Nil))))))) (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokestatic")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokevirtual")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokeinterface")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_invokespecial")) - (&/$Cons (&/$Meta _ (&/$TextS ?class)) - (&/$Cons (&/$Meta _ (&/$TextS ?method)) - (&/$Cons (&/$Meta _ (&/$TupleS ?classes)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] + (&/$Cons [_ (&/$TextS ?class)] + (&/$Cons [_ (&/$TextS ?method)] + (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons ?object - (&/$Cons (&/$Meta _ (&/$TupleS ?args)) + (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) ;; Exceptions - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_try")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_throw")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] (&/$Cons ?ex (&/$Nil)))) (&&host/analyse-jvm-throw analyse exo-type ?ex) ;; Syncronization/monitos - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorenter")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorenter")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorenter analyse exo-type ?monitor) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_monitorexit")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_monitorexit")] (&/$Cons ?monitor (&/$Nil)))) (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) @@ -292,53 +292,53 @@ (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Float arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fdiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fdiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fdiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_frem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_frem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-frem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_feq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_feq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-feq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_flt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_flt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-flt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_fgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-fgt analyse exo-type ?x ?y) ;; Double arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ddiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ddiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ddiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_drem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_drem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-drem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_deq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_deq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-deq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dlt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dlt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dlt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_dgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-dgt analyse exo-type ?x ?y) _ @@ -348,63 +348,63 @@ (|case token ;; Host special forms ;; Characters - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ceq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ceq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ceq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_clt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_clt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-clt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_cgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-cgt analyse exo-type ?x ?y) ;; Integer arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_iadd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iadd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-iadd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_isub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_isub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-isub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_imul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_imul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-imul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_idiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_idiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-idiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_irem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_irem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-irem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ieq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ieq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ieq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ilt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ilt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ilt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_igt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_igt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-igt analyse exo-type ?x ?y) ;; Long arithmetic - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ladd")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ladd")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ladd analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lsub")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lsub")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lsub analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lmul")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lmul")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lmul analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_ldiv")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ldiv")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-ldiv analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lrem")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lrem")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lrem analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_leq")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_leq")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-leq analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_llt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_llt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-llt analyse exo-type ?x ?y) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_jvm_lgt")) (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lgt")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) (&&host/analyse-jvm-lgt analyse exo-type ?x ?y) _ @@ -415,60 +415,60 @@ (&/$SymbolS ?ident) (&&lux/analyse-symbol analyse exo-type ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_case")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_case")] (&/$Cons ?value ?branches))) (&&lux/analyse-case analyse exo-type ?value ?branches) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_lambda")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?self)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?arg)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_lambda")] + (&/$Cons [_ (&/$SymbolS "" ?self)] + (&/$Cons [_ (&/$SymbolS "" ?arg)] (&/$Cons ?body (&/$Nil)))))) (&&lux/analyse-lambda analyse exo-type ?self ?arg ?body) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_def")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_def")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-def analyse compile-token ?name ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-macro")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-macro")] + (&/$Cons [_ (&/$SymbolS "" ?name)] (&/$Nil)))) (&&lux/analyse-declare-macro analyse compile-token ?name) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_declare-tags")) - (&/$Cons (&/$Meta _ (&/$TupleS tags)) - (&/$Cons (&/$Meta _ (&/$SymbolS "" type-name)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_declare-tags")] + (&/$Cons [_ (&/$TupleS tags)] + (&/$Cons [_ (&/$SymbolS "" type-name)] (&/$Nil))))) (|do [tags* (&/map% parse-tag tags)] (&&lux/analyse-declare-tags tags* type-name)) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_import")) - (&/$Cons (&/$Meta _ (&/$TextS ?path)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_import")] + (&/$Cons [_ (&/$TextS ?path)] (&/$Nil)))) (&&lux/analyse-import analyse compile-module compile-token ?path) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-check analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_:!")) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_:!")] (&/$Cons ?type (&/$Cons ?value (&/$Nil))))) (&&lux/analyse-coerce analyse eval! exo-type ?type ?value) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_export")) - (&/$Cons (&/$Meta _ (&/$SymbolS "" ?ident)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_export")] + (&/$Cons [_ (&/$SymbolS "" ?ident)] (&/$Nil)))) (&&lux/analyse-export analyse compile-token ?ident) - (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS _ "_lux_alias")) - (&/$Cons (&/$Meta _ (&/$TextS ?alias)) - (&/$Cons (&/$Meta _ (&/$TextS ?module)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_lux_alias")] + (&/$Cons [_ (&/$TextS ?alias)] + (&/$Cons [_ (&/$TextS ?module)] (&/$Nil))))) (&&lux/analyse-alias analyse compile-token ?alias ?module) @@ -525,7 +525,7 @@ (defn ^:private analyse-basic-ast [analyse eval! compile-module compile-token exo-type token] ;; (prn 'analyse-basic-ast (&/show-ast token)) (|case token - (&/$Meta meta ?token) + [meta ?token] (fn [state] (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) (catch Error e @@ -559,13 +559,13 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] ;; (prn 'analyse-ast (&/show-ast token)) - (&/with-cursor (aget token 1 0) + (&/with-cursor (aget token 0) (&/with-expected-type exo-type (|case token - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$IntS idx)) ?values))) + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - (&/$Meta meta (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) ?values))) + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] [module tag-name] (&/normalize ?ident) ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] @@ -574,7 +574,7 @@ ] (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - (&/$Meta meta (&/$FormS (&/$Cons ?fn ?args))) + [meta (&/$FormS (&/$Cons ?fn ?args))] (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) (&/$Right state* =fn) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 829b5b6d8..e86d55497 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -39,7 +39,7 @@ ;; [Utils] (def ^:private unit - (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list))))) + (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list)))) (defn ^:private resolve-type [type] (|case type @@ -126,7 +126,7 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [(&/$Meta _ pattern*) pattern] + (|let [[_ pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type @@ -221,7 +221,7 @@ ] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) - (&/$FormS (&/$Cons (&/$Meta _ (&/$TagS ?ident)) + (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] [=module =name] (&&/resolved-ident ?ident) @@ -237,7 +237,7 @@ 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/V &/$Meta (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values))) kont)) + (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont)) ;; :let [_ (println "#15")] ] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 098dc89df..796b2d147 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -17,7 +17,7 @@ ;; [Utils] (defn ^:private extract-text [text] (|case text - (&/$Meta _ (&/$TextS ?text)) + [_ (&/$TextS ?text)] (return ?text) _ @@ -221,28 +221,28 @@ (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] (|case modif - (&/$Meta _ (&/$TextS "public")) + [_ (&/$TextS "public")] (return (assoc so-far :visibility "public")) - (&/$Meta _ (&/$TextS "private")) + [_ (&/$TextS "private")] (return (assoc so-far :visibility "private")) - (&/$Meta _ (&/$TextS "protected")) + [_ (&/$TextS "protected")] (return (assoc so-far :visibility "protected")) - (&/$Meta _ (&/$TextS "static")) + [_ (&/$TextS "static")] (return (assoc so-far :static? true)) - (&/$Meta _ (&/$TextS "final")) + [_ (&/$TextS "final")] (return (assoc so-far :final? true)) - (&/$Meta _ (&/$TextS "abstract")) + [_ (&/$TextS "abstract")] (return (assoc so-far :abstract? true)) - (&/$Meta _ (&/$TextS "synchronized")) + [_ (&/$TextS "synchronized")] (return (assoc so-far :concurrency "synchronized")) - (&/$Meta _ (&/$TextS "volatile")) + [_ (&/$TextS "volatile")] (return (assoc so-far :concurrency "volatile")) _ @@ -272,10 +272,10 @@ (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] (|case ?field - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?field-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?field-type)) - (&/$Cons (&/$Meta _ (&/$TupleS ?field-modifiers)) - (&/$Nil)))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name :modifiers =field-modifiers @@ -286,17 +286,17 @@ ?fields) =methods (&/map% (fn [?method] (|case ?method - [?idx (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?method-output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?method-modifiers)) - (&/$Cons ?method-body - (&/$Nil))))))))] + [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?method-inputs)] + (&/$Cons [_ (&/$TextS ?method-output)] + (&/$Cons [_ (&/$TupleS ?method-modifiers)] + (&/$Cons ?method-body + (&/$Nil)))))))]] (|do [=method-inputs (&/map% (fn [minput] (|case minput - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$SymbolS "" ?input-name)) - (&/$Cons (&/$Meta _ (&/$TextS ?input-type)) - (&/$Nil))))) + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] + (&/$Cons [_ (&/$TextS ?input-type)] + (&/$Nil))))] (return (&/T ?input-name ?input-type)) _ @@ -331,11 +331,11 @@ (|do [=supers (&/map% extract-text ?supers) =methods (&/map% (fn [method] (|case method - (&/$Meta _ (&/$FormS (&/$Cons (&/$Meta _ (&/$TextS ?method-name)) - (&/$Cons (&/$Meta _ (&/$TupleS ?inputs)) - (&/$Cons (&/$Meta _ (&/$TextS ?output)) - (&/$Cons (&/$Meta _ (&/$TupleS ?modifiers)) - (&/$Nil))))))) + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] + (&/$Cons [_ (&/$TupleS ?inputs)] + (&/$Cons [_ (&/$TextS ?output)] + (&/$Cons [_ (&/$TupleS ?modifiers)] + (&/$Nil))))))] (|do [=inputs (&/map% extract-text ?inputs) =modifiers (analyse-modifiers ?modifiers)] (return {:name ?method-name @@ -361,7 +361,7 @@ =finally (|case [?finally] (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] + (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index c3f7622b8..375c82f27 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -26,11 +26,6 @@ =type (&type/clean $var ?type)] (return (&/T ?item =type)))))) -(defn ^:private with-cursor [cursor form] - (|case form - (&/$Meta _ syntax) - (&/V &/$Meta (&/T cursor syntax)))) - ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [exo-type* (&type/actual-type exo-type)] @@ -275,7 +270,6 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [macro-expansion* (&/|map (partial with-cursor form-cursor) macro-expansion)] ;; :let [_ (when (or (= "defsig" (aget real-name 1)) ;; ;; (= "type" (aget real-name 1)) ;; ;; (= &&/$struct r-name) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index c6bfb0053..8b70bbcb4 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -133,7 +133,7 @@ (&/$Nil) (return (&/|list)) - (&/$Cons [(&/$Meta _ (&/$TagS tag1)) _] _) + (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1)] (&&module/tag-group module name)) @@ -141,7 +141,7 @@ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv - [(&/$Meta _ (&/$TagS k)) v] + [[_ (&/$TagS k)] v] (|do [=k (&&/resolved-ident k)] (return (&/T (&/ident->text =k) v))) diff --git a/src/lux/base.clj b/src/lux/base.clj index 5444c6c81..b99437a2c 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -23,10 +23,6 @@ "None" "Some") -;; Meta -(deftags "" - "Meta") - ;; Either (deftags "" "Left" @@ -768,40 +764,40 @@ (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast - ($Meta _ ($BoolS ?value)) + [_ ($BoolS ?value)] (pr-str ?value) - ($Meta _ ($IntS ?value)) + [_ ($IntS ?value)] (pr-str ?value) - ($Meta _ ($RealS ?value)) + [_ ($RealS ?value)] (pr-str ?value) - ($Meta _ ($CharS ?value)) + [_ ($CharS ?value)] (pr-str ?value) - ($Meta _ ($TextS ?value)) + [_ ($TextS ?value)] (str "\"" ?value "\"") - ($Meta _ ($TagS ?module ?tag)) + [_ ($TagS ?module ?tag)] (str "#" ?module ";" ?tag) - ($Meta _ ($SymbolS ?module ?name)) + [_ ($SymbolS ?module ?name)] (if (.equals "" ?module) ?name (str ?module ";" ?name)) - ($Meta _ ($TupleS ?elems)) + [_ ($TupleS ?elems)] (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - ($Meta _ ($RecordS ?elems)) + [_ ($RecordS ?elems)] (str "{" (->> ?elems (|map (fn [elem] (|let [[k v] elem] (str (show-ast k) " " (show-ast v))))) (|interpose " ") (fold str "")) "}") - ($Meta _ ($FormS ?elems)) + [_ ($FormS ?elems)] (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") _ diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 6f5f2250d..4c7741769 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -55,12 +55,12 @@ ;; [Lexers] (def ^:private lex-white-space (|do [[meta white-space] (&reader/read-regex #"^(\s+)")] - (return (&/V &/$Meta (&/T meta (&/V $White_Space white-space)))))) + (return (&/T meta (&/V $White_Space white-space))))) (def ^:private lex-single-line-comment (|do [_ (&reader/read-text "##") [meta comment] (&reader/read-regex #"^(.*)$")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/T meta (&/V $Comment comment))))) (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") @@ -79,7 +79,7 @@ (return (&/T meta (str pre "#(" inner ")#" post)))))) ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] - (return (&/V &/$Meta (&/T meta (&/V $Comment comment)))))) + (return (&/T meta (&/V $Comment comment))))) (def ^:private lex-comment (&/try-all% (&/|list lex-single-line-comment @@ -88,7 +88,7 @@ (do-template [ ] (def (|do [[meta token] (&reader/read-regex )] - (return (&/V &/$Meta (&/T meta (&/V token)))))) + (return (&/T meta (&/V token))))) ^:private lex-bool $Bool #"^(true|false)" ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" @@ -102,13 +102,13 @@ (|do [[_ char] (&reader/read-regex #"^(.)")] (return char)))) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Char token)))))) + (return (&/T meta (&/V $Char token))))) (def ^:private lex-text (|do [[meta _] (&reader/read-text "\"") token (lex-text-body nil) _ (&reader/read-text "\"")] - (return (&/V &/$Meta (&/T meta (&/V $Text token)))))) + (return (&/T meta (&/V $Text token))))) (def ^:private lex-ident (&/try-all% (&/|list (|do [[meta token] (&reader/read-regex +ident-re+)] @@ -134,17 +134,17 @@ (def ^:private lex-symbol (|do [[meta ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Symbol ident)))))) + (return (&/T meta (&/V $Symbol ident))))) (def ^:private lex-tag (|do [[meta _] (&reader/read-text "#") [_ ident] lex-ident] - (return (&/V &/$Meta (&/T meta (&/V $Tag ident)))))) + (return (&/T meta (&/V $Tag ident))))) (do-template [ ] (def (|do [[meta _] (&reader/read-text )] - (return (&/V &/$Meta (&/T meta (&/V nil)))))) + (return (&/T meta (&/V nil))))) ^:private lex-open-paren "(" $Open_Paren ^:private lex-close-paren ")" $Close_Paren diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 9436eebc3..2609bf9a5 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -35,7 +35,7 @@ (|do [elems (&/repeat% parse) token &lexer/lex] (|case token - (&/$Meta meta [ _]) + [meta [ _]] (return (&/V (&/fold &/|++ (&/|list) elems))) _ @@ -50,7 +50,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - (&/$Meta meta ($Close_Brace _)) + [meta ($Close_Brace _)] (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -61,7 +61,7 @@ ;; [Interface] (def parse (|do [token &lexer/lex - :let [(&/$Meta meta token*) token]] + :let [[meta token*] token]] (|case token* ($White_Space _) (return (&/|list)) @@ -70,37 +70,37 @@ (return (&/|list)) ($Bool ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value)))))) + (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) ($Int ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$IntS (Long/parseLong ?value)))))) + (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value))))) ($Real ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$RealS (Double/parseDouble ?value)))))) + (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))) ($Char ^String ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$CharS (.charAt ?value 0)))))) + (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0))))) ($Text ?value) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TextS ?value))))) + (return (&/|list (&/T meta (&/V &/$TextS ?value)))) ($Symbol ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$SymbolS ?ident))))) + (return (&/|list (&/T meta (&/V &/$SymbolS ?ident)))) ($Tag ?ident) - (return (&/|list (&/V &/$Meta (&/T meta (&/V &/$TagS ?ident))))) + (return (&/|list (&/T meta (&/V &/$TagS ?ident)))) ($Open_Paren _) (|do [syntax (parse-form parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/T meta syntax)))) ($Open_Bracket _) (|do [syntax (parse-tuple parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/T meta syntax)))) ($Open_Brace _) (|do [syntax (parse-record parse)] - (return (&/|list (&/V &/$Meta (&/T meta syntax))))) + (return (&/|list (&/T meta syntax)))) _ (fail "[Parser Error] Unknown lexer token.") diff --git a/src/lux/type.clj b/src/lux/type.clj index 2b06553c3..36590ddd2 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -150,10 +150,8 @@ (Named$ (&/T "lux" "Meta") (Univ$ empty-env (Univ$ empty-env - (Variant$ (&/|list - ;; &/$Meta - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1))))))))) + (Tuple$ (&/|list (Bound$ 3) + (Bound$ 1))))))) (def AST* (Named$ (&/T "lux" "AST'") @@ -520,6 +518,10 @@ (defn type= [x y] (or (clojure.lang.Util/identical x y) (let [output (|case [x y] + [(&/$NamedT [?xmodule ?xname] ?xtype) (&/$NamedT [?ymodule ?yname] ?ytype)] + (and (= ?xmodule ?ymodule) + (= ?xname ?yname)) + [(&/$DataT xname) (&/$DataT yname)] (.equals ^Object xname yname) -- cgit v1.2.3 From 196f56b83ed357169efb75b864f81f26c10641f1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 29 Aug 2015 23:17:27 -0400 Subject: - Remove the (unnec) "All'" and "->'" macros. - Improved the "struct" macro so that (once again) it doesn't ask for the prefixes of the members. - Added tests for the lux.reader namespace. --- src/lux/compiler.clj | 2 +- src/lux/reader.clj | 27 +++++++++++++-------------- 2 files changed, 14 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index b8ffa825f..694c6bfc4 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -421,7 +421,7 @@ (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from file-name file-content) state)) + (&/set$ &/$source (&reader/from name file-content) state)) (&/$Right ?state _) (&/run-state (|do [defs &a-module/defs imports &a-module/imports diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 0fcb5097b..af6c1ecc3 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -48,7 +48,6 @@ (fail* msg) ))) -;; [Exports] (defn ^:private re-find! [^java.util.regex.Pattern regex column ^String line] (let [matcher (doto (.matcher regex line) (.region column (.length line)) @@ -72,6 +71,7 @@ (.group matcher 1) (.group matcher 2))))) +;; [Exports] (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] @@ -125,7 +125,6 @@ (defn read-text [^String text] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-text [file-name line-num column-num text line]) (if (.startsWith line text column-num) (let [match-length (.length text) column-num* (+ column-num match-length)] @@ -135,15 +134,15 @@ (&/T (&/T file-name line-num column-num*) line))))) (&/V $No (str "[Reader Error] Text failed: " text)))))) -(def ^:private ^String +source-dir+ "input/") -(defn from [^String file-name ^String file-content] - (let [lines (&/->list (string/split-lines file-content)) - file-name (.substring file-name (.length +source-dir+))] - (&/|map (fn [line+line-num] - (|let [[line-num line] line+line-num] - (&/T (&/T file-name (inc line-num) 0) - line))) - (&/|filter (fn [line+line-num] - (|let [[line-num line] line+line-num] - (not= "" line))) - (&/enumerate lines))))) +(defn from [^String name ^String source-code] + (->> source-code + (string/split-lines) + (&/->list) + (&/enumerate) + (&/|filter (fn [line+line-num] + (|let [[line-num line] line+line-num] + (not= "" line)))) + (&/|map (fn [line+line-num] + (|let [[line-num line] line+line-num] + (&/T (&/T name (inc line-num) 0) + line)))))) -- cgit v1.2.3 From 817d244adff361104ae0aa6ce53efe6c2bc07552 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 Aug 2015 18:36:17 -0400 Subject: - Added unit-tests for lexer. - Fixed a bug when lexing multi-line comments. --- src/lux/lexer.clj | 20 ++++++-------------- src/lux/reader.clj | 27 +++++++++------------------ 2 files changed, 15 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index 4c7741769..b3a47f3e0 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -64,20 +64,12 @@ (defn ^:private lex-multi-line-comment [_] (|do [_ (&reader/read-text "#(") - [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex #"(?is)^(?!#\()(.*?(?=\)#))") - ;; :let [_ (prn 'immediate comment)] - _ (&reader/read-text ")#")] + [meta comment] (&/try-all% (&/|list (|do [[meta comment] (&reader/read-regex+ #"(?is)^(?!#\()((?!\)#).)*")] (return (&/T meta comment))) - (|do [;; :let [_ (prn 'pre/_0)] - [meta pre] (&reader/read-regex+ #"(?is)^(.*?)(#\(|$)") - ;; :let [_ (prn 'pre pre)] - [_ inner] (lex-multi-line-comment nil) - ;; :let [_ (prn 'inner inner)] - [_ post] (&reader/read-regex #"(?is)^(.+?(?=\)#))") - ;; :let [_ (prn 'post post (str pre "#(" inner ")#" post))] - ] + (|do [[meta pre] (&reader/read-regex+ #"(?is)^((?!#\().)*") + [_ ($Comment inner)] (lex-multi-line-comment nil) + [_ post] (&reader/read-regex+ #"(?is)^((?!\)#).)*")] (return (&/T meta (str pre "#(" inner ")#" post)))))) - ;; :let [_ (prn 'lex-multi-line-comment (str comment ")#"))] _ (&reader/read-text ")#")] (return (&/T meta (&/V $Comment comment))))) @@ -91,8 +83,8 @@ (return (&/T meta (&/V token))))) ^:private lex-bool $Bool #"^(true|false)" - ^:private lex-int $Int #"^(-?0|-?[1-9][0-9]*)" - ^:private lex-real $Real #"^-?(-?0\.[0-9]+|-?[1-9][0-9]*\.[0-9]+)" + ^:private lex-int $Int #"^-?(0|[1-9][0-9]*)" + ^:private lex-real $Real #"^-?(0\.[0-9]+|[1-9][0-9]*\.[0-9]+)" ) (def ^:private lex-char diff --git a/src/lux/reader.clj b/src/lux/reader.clj index af6c1ecc3..7b1559f07 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -55,13 +55,6 @@ (when (.find matcher) (.group matcher 0)))) -(defn ^:private re-find1! [^java.util.regex.Pattern regex column ^String line] - (let [matcher (doto (.matcher regex line) - (.region column (.length line)) - (.useAnchoringBounds true))] - (when (.find matcher) - (.group matcher 1)))) - (defn ^:private re-find3! [^java.util.regex.Pattern regex column ^String line] (let [matcher (doto (.matcher regex line) (.region column (.length line)) @@ -75,11 +68,8 @@ (defn read-regex [regex] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-regex [file-name line-num column-num regex line]) - (if-let [^String match (do ;; (prn '[regex line] [regex line]) - (re-find! regex column-num line))] - (let [;; _ (prn 'match match) - match-length (.length match) + (if-let [^String match (re-find! regex column-num line)] + (let [match-length (.length match) column-num* (+ column-num match-length)] (if (= column-num* (.length line)) (&/V $Done (&/T (&/T file-name line-num column-num) match)) @@ -90,7 +80,6 @@ (defn read-regex2 [regex] (with-line (fn [file-name line-num column-num ^String line] - ;; (prn 'read-regex2 [file-name line-num column-num regex line]) (if-let [[^String match tok1 tok2] (re-find3! regex column-num line)] (let [match-length (.length match) column-num* (+ column-num match-length)] @@ -111,15 +100,17 @@ (&/$Cons [[file-name line-num column-num] ^String line] reader**) - (if-let [^String match (do ;; (prn 'read-regex+ regex line) - (re-find1! regex column-num line))] + (if-let [^String match (re-find! regex column-num line)] (let [match-length (.length match) - column-num* (+ column-num match-length)] + column-num* (+ column-num match-length) + prefix* (if (= 0 column-num) + (str prefix "\n" match) + (str prefix match))] (if (= column-num* (.length line)) - (recur (str prefix match "\n") reader**) + (recur prefix* reader**) (&/V &/$Right (&/T (&/Cons$ (&/T (&/T file-name line-num column-num*) line) reader**) - (&/T (&/T file-name line-num column-num) (str prefix match)))))) + (&/T (&/T file-name line-num column-num) prefix*))))) (&/V &/$Left (str "[Reader Error] Pattern failed: " regex)))))))) (defn read-text [^String text] -- cgit v1.2.3 From a0533814cbc3b4b59850f97e9e72abc8bb83ff57 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 30 Aug 2015 20:07:37 -0400 Subject: - Added call/cc to lux/codata/lazy. - Added some minor compiler optimizations. --- src/lux/analyser.clj | 55 ++++++++++++++++++++++++----------------------- src/lux/analyser/case.clj | 2 +- src/lux/compiler/lux.clj | 12 +++++------ 3 files changed, 34 insertions(+), 35 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 3ff214ee0..552ccd77d 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -559,33 +559,34 @@ (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] ;; (prn 'analyse-ast (&/show-ast token)) - (&/with-cursor (aget token 0) - (&/with-expected-type exo-type - (|case token - [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) - - [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) - - [meta (&/$FormS (&/$Cons ?fn ?args))] - (fn [state] - (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) - (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) - - _ - ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) - - _ - (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token))))) + (|let [[cursor _] token] + (&/with-cursor cursor + (&/with-expected-type exo-type + (|case token + [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + + [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] + (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] + [module tag-name] (&/normalize ?ident) + ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] + idx (&&module/tag-index module tag-name) + ;; :let [_ (println 'analyse-ast/_2 idx)] + ] + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + + [meta (&/$FormS (&/$Cons ?fn ?args))] + (fn [state] + (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) + (&/$Right state* =fn) + (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + + _ + ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) + + _ + (analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token)))))) ;; [Resources] (defn analyse [eval! compile-module compile-token] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index e86d55497..7a1ec4860 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -233,7 +233,7 @@ ;; :let [_ (println "#13")] case-type (&type/variant-case idx value-type*) ;; :let [_ (println "#14" (&type/show-type case-type))] - [=test =kont] (case (&/|length ?values) + [=test =kont] (case (int (&/|length ?values)) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 3aa25ac99..6a02ed21d 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -34,13 +34,11 @@ (do-template [ ] (defn [compile *type* value] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (try (doto *writer* - (.visitTypeInsn Opcodes/NEW ) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESPECIAL "" )) - (catch Exception e - (assert false (prn-str ' (alength value) (aget value 0) (aget value 1)))))]] + :let [_ (doto *writer* + (.visitTypeInsn Opcodes/NEW ) + (.visitInsn Opcodes/DUP) + (.visitLdcInsn ( value)) + (.visitMethodInsn Opcodes/INVOKESPECIAL "" ))]] (return nil))) compile-int "java/lang/Long" "(J)V" long -- cgit v1.2.3 From 1857af8628216353c4fa0b75a921d66b266aa0b9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 31 Aug 2015 12:35:50 -0400 Subject: - Found a compromise with the issue of certain definitions clashing with each other when saving the class files in case-insensitive file-systems (https://github.com/LuxLang/lux/issues/8). The names of certain definitions were changed slightly to avoid clashes and the compiler throws an error if the names end up clashing prior to saving the .class file. --- src/lux/compiler/base.clj | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index b6efaada8..edb1441ca 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -46,9 +46,12 @@ (def tag-group-separator "\n") ;; [Utils] -(defn ^:private write-file [^String file ^bytes data] - (with-open [stream (BufferedOutputStream. (FileOutputStream. file))] - (.write stream data))) +(defn ^:private write-file [^String file-name ^bytes data] + (let [;; file-name (.toLowerCase file-name) + ] + (do (assert (not (.exists (File. file-name))) (str "Can't overwrite file: " file-name)) + (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] + (.write stream data))))) (defn ^:private write-output [module name data] (let [module* (&host/->module-class module) -- cgit v1.2.3 From 7f0aa70c6115f9321e13f0452d724b9b40c3f981 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 31 Aug 2015 15:54:45 -0400 Subject: - Compiler no longer allows an alias to be reused for another module when importing. - Compiler now cleans the module's .class files prior to compiling to avoid keeping old .class files around. --- src/lux/analyser/module.clj | 28 +++++++++++++++------------- src/lux/compiler.clj | 3 ++- 2 files changed, 17 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 6eca13b44..8c27fc08d 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -137,19 +137,6 @@ (return* state (->> state (&/get$ &/$modules) (&/|contains? name))))) -(defn alias [module alias reference] - (fn [state] - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - #(&/update$ $module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) - nil))) - (defn dealias [name] (|do [current-module &/get-module-name] (fn [state] @@ -157,6 +144,21 @@ (return* state real-name) (fail* (str "Unknown alias: " name)))))) +(defn alias [module alias reference] + (fn [state] + (if-let [real-name (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $module-aliases) (&/|get alias))] + (fail* (str "Can't re-use alias \"" alias "\" @ " module)) + (return* (->> state + (&/update$ &/$modules + (fn [ms] + (&/|update module + #(&/update$ $module-aliases + (fn [aliases] + (&/|put alias reference aliases)) + %) + ms)))) + nil)))) + (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 694c6bfc4..e16a84b20 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -408,7 +408,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) -- cgit v1.2.3 From 2cfaf65019015ffe34fba5d5a723b94350cd4e84 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 11:18:26 -0400 Subject: - Added a macro to write recursive types. - Corrected some code that still involved the old names for the list macros. - Corrected some code in the pattern-matcher analyser to it fails properly when encountering invalid pattern-syntax. --- src/lux/analyser/case.clj | 3 +++ 1 file changed, 3 insertions(+) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7a1ec4860..f302088d9 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -241,6 +241,9 @@ ;; :let [_ (println "#15")] ] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) + + _ + (fail (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) ))) (defn ^:private analyse-branch [analyse exo-type value-type pattern body patterns] -- cgit v1.2.3 From e085c8c685b1e22827443a43d6f20b5ab6e72d6a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 1 Sep 2015 16:48:54 -0400 Subject: - Fixed the implementation of the Rec macro, which forgot to do application on Void to achieve "recursion". - Introduced ExQ types into the type-system (still pending work on inference). --- src/lux/base.clj | 1 + src/lux/type.clj | 2 ++ 2 files changed, 3 insertions(+) (limited to 'src') diff --git a/src/lux/base.clj b/src/lux/base.clj index b99437a2c..4db1d26bc 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -51,6 +51,7 @@ "VarT" "ExT" "UnivQ" + "ExQ" "AppT" "NamedT") diff --git a/src/lux/type.clj b/src/lux/type.clj index 36590ddd2..82eab3dd4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -105,6 +105,8 @@ Int ;; UnivQ (Tuple$ (&/|list TypeList Type)) + ;; ExQ + (Tuple$ (&/|list TypeList Type)) ;; AppT TypePair ;; NamedT -- cgit v1.2.3 From a0eb061edbbb8bca666add620e4c82c4f3bc5fdc Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 2 Sep 2015 08:11:14 -0400 Subject: - Added a new (albeit small) I/O library with host-dependent functions. --- src/lux/analyser/host.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 796b2d147..c6c5cb39b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -358,7 +358,7 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - =finally (|case [?finally] + =finally (|case ?finally (&/$None) (return (&/V &/$None nil)) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] -- cgit v1.2.3 From 455018ec68f2c127db489048351bc48f3982fe23 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 01:03:19 -0400 Subject: - Expanded the standard library. - Fixed some minor bugs. - Added the updated code for the parser (forgot to add it to a previous commit). --- src/lux/parser.clj | 49 +++++++++++++++---------------------------------- src/lux/type.clj | 6 +++--- 2 files changed, 18 insertions(+), 37 deletions(-) (limited to 'src') diff --git a/src/lux/parser.clj b/src/lux/parser.clj index 2609bf9a5..dbd6ca2c5 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -10,25 +10,6 @@ (lux [base :as & :refer [deftags |do return fail |case]] [lexer :as &lexer]))) -;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" - ) - ;; [Utils] (do-template [ ] (defn [parse] @@ -41,8 +22,8 @@ _ (fail (str "[Parser Error] Unbalanced " "."))))) - ^:private parse-form $Close_Paren "parantheses" &/$FormS - ^:private parse-tuple $Close_Bracket "brackets" &/$TupleS + ^:private parse-form &lexer/$Close_Paren "parantheses" &/$FormS + ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$TupleS ) (defn ^:private parse-record [parse] @@ -50,7 +31,7 @@ token &lexer/lex :let [elems (&/fold &/|++ (&/|list) elems*)]] (|case token - [meta ($Close_Brace _)] + [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) (return (&/V &/$RecordS (&/|as-pairs elems))) (fail (str "[Parser Error] Records must have an even number of elements."))) @@ -63,42 +44,42 @@ (|do [token &lexer/lex :let [[meta token*] token]] (|case token* - ($White_Space _) + (&lexer/$White_Space _) (return (&/|list)) - ($Comment _) + (&lexer/$Comment _) (return (&/|list)) - ($Bool ?value) + (&lexer/$Bool ?value) (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) - ($Int ?value) + (&lexer/$Int ?value) (return (&/|list (&/T meta (&/V &/$IntS (Long/parseLong ?value))))) - ($Real ?value) + (&lexer/$Real ?value) (return (&/|list (&/T meta (&/V &/$RealS (Double/parseDouble ?value))))) - ($Char ^String ?value) + (&lexer/$Char ^String ?value) (return (&/|list (&/T meta (&/V &/$CharS (.charAt ?value 0))))) - ($Text ?value) + (&lexer/$Text ?value) (return (&/|list (&/T meta (&/V &/$TextS ?value)))) - ($Symbol ?ident) + (&lexer/$Symbol ?ident) (return (&/|list (&/T meta (&/V &/$SymbolS ?ident)))) - ($Tag ?ident) + (&lexer/$Tag ?ident) (return (&/|list (&/T meta (&/V &/$TagS ?ident)))) - ($Open_Paren _) + (&lexer/$Open_Paren _) (|do [syntax (parse-form parse)] (return (&/|list (&/T meta syntax)))) - ($Open_Bracket _) + (&lexer/$Open_Bracket _) (|do [syntax (parse-tuple parse)] (return (&/|list (&/T meta syntax)))) - ($Open_Brace _) + (&lexer/$Open_Brace _) (|do [syntax (parse-record parse)] (return (&/|list (&/T meta syntax)))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 82eab3dd4..8300d470c 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -724,9 +724,9 @@ (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)] + (|case ((|do [F2 (deref ?aid)] + (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + state) (&/$Right state* output) (return* state* output) -- cgit v1.2.3 From 514d03851b20c2f8b818ee26194a93515a685ae5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 19:52:07 -0400 Subject: - Added type-inference when constructing tuples. --- src/lux/analyser.clj | 7 +++-- src/lux/analyser/base.clj | 4 +-- src/lux/analyser/host.clj | 10 +++---- src/lux/analyser/lux.clj | 66 ++++++++++++++++++++++++++--------------------- src/lux/compiler/lux.clj | 4 +-- src/lux/type.clj | 12 ++++++++- 6 files changed, 60 insertions(+), 43 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 552ccd77d..fbc360628 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -529,8 +529,11 @@ (fn [state] (|case (try ((aba1 analyse eval! compile-module compile-token exo-type ?token) state) (catch Error e - (prn e) - (assert false (prn-str 'analyse-basic-ast (&/show-ast token))))) + (prn 'analyse-basic-ast/Error-1 e) + (prn 'analyse-basic-ast/Error-2 (&/show-ast token)) + (prn 'analyse-basic-ast/Error-3 (&type/show-type exo-type)) + (throw e)) + ) (&/$Right state* output) (return* state* output) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 8c52748d7..414d005f1 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -126,9 +126,9 @@ ) ;; [Exports] -(defn expr-type [syntax+] +(defn expr-type* [syntax+] (|let [[_ type] syntax+] - (return type))) + type)) (defn analyse-1 [analyse exo-type elem] (|do [output (analyse exo-type elem)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index c6c5cb39b..0b333ce07 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -209,14 +209,12 @@ (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] (|do [=array (analyse-1+ analyse ?array) - =elem (analyse-1+ analyse ?elem) - =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) =array-type))))) + =elem (analyse-1+ analyse ?elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) (&&/expr-type* =array)))))) (defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (analyse-1+ analyse ?array) - =array-type (&&/expr-type =array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) =array-type))))) + (|do [=array (analyse-1+ analyse ?array)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) (&&/expr-type* =array)))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 375c82f27..62202c1c9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -28,23 +28,31 @@ ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] (return (&/|list (&/T (&/V &&/$tuple =elems) exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-tuple analyse exo-type** ?elems)))) - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) - - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))) + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values @@ -206,8 +214,7 @@ (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) (&/|list)) (&/|reverse inner) scopes)] - ((|do [btype (&&/expr-type =local) - _ (&type/check exo-type btype)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] (return (&/|list =local))) (&/set$ &/$envs (&/|++ inner* outer) state)))) )))) @@ -271,8 +278,8 @@ macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] ;; :let [_ (when (or (= "defsig" (aget real-name 1)) - ;; ;; (= "type" (aget real-name 1)) - ;; ;; (= &&/$struct r-name) + ;; ;; (= "..?" (aget real-name 1)) + ;; ;; (= "try$" (aget real-name 1)) ;; ) ;; (->> (&/|map &/show-ast macro-expansion) ;; (&/|interpose "\n") @@ -297,8 +304,7 @@ _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") =value (analyse-1+ analyse ?value) - =value-type (&&/expr-type =value) - =match (&&case/analyse-branches analyse exo-type =value-type (&/|as-pairs ?branches))] + =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) @@ -376,11 +382,10 @@ (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (analyse-1+ analyse ?value)) - =value-type (&&/expr-type =value)] + (analyse-1+ analyse ?value))] (|case =value [(&&/$var (&/$Global ?r-module ?r-name)) _] - (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name =value-type) + (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] @@ -412,16 +417,17 @@ _ (&&module/declare-tags module-name tags def-type)] (return (&/|list)))) -(defn analyse-import [analyse compile-module compile-token ?path] +(defn analyse-import [analyse compile-module compile-token path] + ;; (prn 'analyse-import path) (|do [module-name &/get-module-name - _ (if (= module-name ?path) - (fail (str "[Analyser Error] Module can't import itself: " ?path)) + _ (if (= module-name path) + (fail (str "[Analyser Error] Module can't import itself: " path)) (return nil))] (&/save-module - (|do [already-compiled? (&&module/exists? ?path) - ;; :let [_ (prn 'analyse-import module-name ?path already-compiled?)] - _ (&&module/add-import ?path) - _ (&/when% (not already-compiled?) (compile-module ?path))] + (|do [already-compiled? (&&module/exists? path) + ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] + _ (&&module/add-import path) + _ (&/when% (not already-compiled?) (compile-module path))] (return (&/|list)))))) (defn analyse-export [analyse compile-token name] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index 6a02ed21d..c17d10494 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -176,8 +176,8 @@ ))) (defn compile-def [compile ?name ?body] - (|do [=value-type (&a/expr-type ?body) - :let [def-type (cond (&type/type= &type/Type =value-type) + (|do [:let [=value-type (&a/expr-type* ?body) + def-type (cond (&type/type= &type/Type =value-type) "type" :else diff --git a/src/lux/type.clj b/src/lux/type.clj index 8300d470c..f067867d8 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -395,7 +395,7 @@ (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] (return* (&/update$ &/$type-vars #(->> % - (&/update$ &/$counter dec) + ;; (&/update$ &/$counter dec) (&/set$ &/$mappings (&/|remove id mappings*))) state) nil))) @@ -949,3 +949,13 @@ _ (fail (str "[Type Error] Type is not named: " (show-type type))) )) + +(defn unknown? [type] + "(-> Type (Lux Bool))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (return (not ?))) + + _ + (return false))) -- cgit v1.2.3 From 77aae538ed0d128e291292b5defe80967d181be9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 6 Sep 2015 20:37:10 -0400 Subject: - Added the (untested) inference of tuple destructuring. - Removed several (unnecessary) type annotations. --- src/lux/analyser/base.clj | 8 +++++++ src/lux/analyser/case.clj | 60 ++++++++++++++++++++++++++++++----------------- src/lux/analyser/lux.clj | 18 ++++---------- src/lux/type.clj | 13 ++++++++-- 4 files changed, 62 insertions(+), 37 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 414d005f1..7f7980e76 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -139,6 +139,14 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1+ [analyse ?token] + (&type/with-var + (fn [$var] + (|do [=expr (analyse-1 analyse $var ?token) + :let [[?item ?type] =expr] + =type (&type/clean $var ?type)] + (return (&/T ?item =type)))))) + (defn resolved-ident [ident] (|let [[?module ?name] ident] (|do [module* (if (.equals "" ?module) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f302088d9..3b12270c2 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -184,11 +184,7 @@ (&/$RecordS pairs) (|do [?members (&&record/order-record pairs) - ;; :let [_ (prn 'PRE (&type/show-type value-type))] - value-type* (adjust-type value-type) - ;; :let [_ (prn 'POST (&type/show-type value-type*))] - ;; value-type* (resolve-type value-type) - ] + value-type* (adjust-type value-type)] (|case value-type* (&/$TupleT ?member-types) (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) @@ -333,6 +329,15 @@ (return (&/V $VariantTotal (&/T total? structs)))) )))) +(defn check-totality+ [check-totality] + (fn [?token] + (&type/with-var + (fn [$var] + (|do [=output (check-totality $var ?token) + ?type (&type/deref+ $var) + =type (&type/clean $var ?type)] + (return (&/T =output =type))))))) + (defn ^:private check-totality [value-type struct] ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct @@ -340,34 +345,45 @@ (return ?total) ($BoolTotal ?total ?values) - (return (or ?total - (= #{true false} (set (&/->seq ?values))))) + (|do [_ (&type/check value-type &type/Bool)] + (return (or ?total + (= #{true false} (set (&/->seq ?values)))))) ($IntTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Int)] + (return ?total)) ($RealTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Real)] + (return ?total)) ($CharTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Char)] + (return ?total)) ($TextTotal ?total _) - (return ?total) + (|do [_ (&type/check value-type &type/Text)] + (return ?total)) ($TupleTotal ?total ?structs) - (if ?total - (return true) - (|do [value-type* (resolve-type value-type)] - (|case value-type* - (&/$TupleT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - (check-totality ?member sub-struct)) - ?structs ?members)] - (return (&/fold #(and %1 %2) true totals))) + (|do [unknown? (&type/unknown? value-type)] + (if unknown? + (|do [=structs (&/map% (check-totality+ check-totality) ?structs) + _ (&type/check value-type (&/V &/$TupleT (&/|map &/|second =structs)))] + (return (or ?total + (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) + (if ?total + (return true) + (|do [value-type* (resolve-type value-type)] + (|case value-type* + (&/$TupleT ?members) + (|do [totals (&/map2% (fn [sub-struct ?member] + (check-totality ?member sub-struct)) + ?structs ?members)] + (return (&/fold #(and %1 %2) true totals))) - _ - (fail "[Pattern-maching Error] Tuple is not total.")))) + _ + (fail "[Pattern-maching Error] Tuple is not total.")))))) ($VariantTotal ?total ?structs) (if ?total diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 62202c1c9..3a9b822ca 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,19 +18,11 @@ [module :as &&module] [record :as &&record]))) -(defn ^:private analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] - =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) - ;; [Exports] (defn analyse-tuple [analyse exo-type ?elems] (|do [unknown? (&type/unknown? exo-type)] (if unknown? - (|do [=elems (&/map% #(|do [=analysis (analyse-1+ analyse %)] + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] (return =analysis)) ?elems) _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] @@ -52,7 +44,7 @@ (analyse-tuple analyse exo-type** ?elems)))) _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*)))))))) + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type)))))))) (defn ^:private analyse-variant-body [analyse exo-type ?values] (|do [output (|case ?values @@ -303,7 +295,7 @@ (|do [:let [num-branches (&/|length ?branches)] _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") - =value (analyse-1+ analyse ?value) + =value (&&/analyse-1+ analyse ?value) =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) @@ -382,7 +374,7 @@ (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) (|do [=value (&/with-scope ?name - (analyse-1+ analyse ?value))] + (&&/analyse-1+ analyse ?value))] (|case =value [(&&/$var (&/$Global ?r-module ?r-name)) _] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) @@ -452,6 +444,6 @@ (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (analyse-1+ analyse ?value)] + =value (&&/analyse-1+ analyse ?value)] (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) ==type))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index f067867d8..5fbc33de2 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -336,6 +336,14 @@ (fail* (str "[Type Error] Unbound type-var: " id))) (fail* (str "[Type Error] Unknown type-var: " id))))) +(defn deref+ [type] + (|case type + (&/$VarT id) + (deref id) + + _ + (fail (str "[Type Error] Type is not a variable: " (show-type type))))) + (defn set-var [id type] (fn [state] (if-let [tvar (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings) (&/|get id))] @@ -914,8 +922,9 @@ (|do [type* (apply-type ?all ?param)] (actual-type type*)) - (&/$VarT ?id) - (deref ?id) + (&/$VarT id) + (|do [=type (deref id)] + (actual-type =type)) (&/$NamedT ?name ?type) (actual-type ?type) -- cgit v1.2.3 From 08584c8d9a462ce0bd3ffb6d9535ecb3f7043289 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 7 Sep 2015 01:33:53 -0400 Subject: - Type checking of polymorphic functions now relies on ExT types to guarantee that type-variables don't unify to anything, instead of relying on VarT types. - Fixed some bugs in the standard library due to improper behavior of the type-checker. - The analysis and pattern-matching code for records now reuses that of tuples. --- src/lux/analyser.clj | 6 ++ src/lux/analyser/case.clj | 26 +------- src/lux/analyser/lux.clj | 161 ++++++++++++++++++++++++---------------------- src/lux/type.clj | 14 +++- 4 files changed, 105 insertions(+), 102 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index fbc360628..9a57191f5 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -532,6 +532,12 @@ (prn 'analyse-basic-ast/Error-1 e) (prn 'analyse-basic-ast/Error-2 (&/show-ast token)) (prn 'analyse-basic-ast/Error-3 (&type/show-type exo-type)) + (|case ((&type/deref+ exo-type) state) + (&/$Right [_state _exo-type]) + (prn 'analyse-basic-ast/Error-4 (&type/show-type _exo-type)) + + _ + (prn 'analyse-basic-ast/Error-4 'YOLO)) (throw e)) ) (&/$Right state* output) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 3b12270c2..f2afdb0e9 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -49,14 +49,9 @@ (resolve-type type*)) (&/$UnivQ _) - ;; (&type/actual-type _abody) (|do [$var &type/existential =type (&type/apply-type type $var)] (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type type $var)] - ;; (&type/actual-type =type)))) _ (&type/actual-type type))) @@ -126,7 +121,7 @@ (adjust-type* (&/|list) type)) (defn ^:private analyse-pattern [value-type pattern kont] - (|let [[_ pattern*] pattern] + (|let [[meta pattern*] pattern] (|case pattern* (&/$SymbolS "" name) (|do [=kont (&env/with-local name value-type @@ -183,23 +178,8 @@ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs) - value-type* (adjust-type value-type)] - (|case value-type* - (&/$TupleT ?member-types) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require record[" (&/|length ?member-types) "]. Given record[" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/Cons$ =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T (&/|list) =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont)))) - - _ - (fail "[Pattern-matching Error] Record requires record-type."))) + (|do [?members (&&record/order-record pairs)] + (analyse-pattern value-type (&/T meta (&/V &/$TupleS ?members)) kont)) (&/$TagS ?ident) (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 3a9b822ca..f22cc6c9a 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -44,19 +44,39 @@ (analyse-tuple analyse exo-type** ?elems)))) _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) (&type/show-type exo-type)))))))) + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ))))) -(defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [output (|case ?values - (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) - - (&/$Cons ?value (&/$Nil)) - (analyse exo-type ?value) +(defn with-attempt [m-value on-error] + (fn [state] + (|case (m-value state) + (&/$Left msg) + ((on-error msg) state) + + output + output))) - _ - (analyse-tuple analyse exo-type ?values) - )] +(defn ^:private analyse-variant-body [analyse exo-type ?values] + (|do [output (with-attempt + (|case ?values + (&/$Nil) + (analyse-tuple analyse exo-type (&/|list)) + + (&/$Cons ?value (&/$Nil)) + (analyse exo-type ?value) + + _ + (analyse-tuple analyse exo-type ?values)) + (fn [err] + (fail (str err "\n" + 'analyse-variant-body " " (&type/show-type exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + ;; (assert false + ;; (str err "\n" + ;; 'analyse-variant-body " " (&type/show-type exo-type) + ;; " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) + ))] (|case output (&/$Cons x (&/$Nil)) (return x) @@ -78,7 +98,13 @@ (&/$VariantT ?cases) (|case (&/|at idx ?cases) (&/$Some vtype) - (|do [=value (analyse-variant-body analyse vtype ?values)] + (|do [=value (with-attempt + (analyse-variant-body analyse vtype ?values) + (fn [err] + (|do [_exo-type (&type/deref+ exo-type)] + (fail (str err "\n" + 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) exo-type)))) @@ -95,41 +121,8 @@ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - ;; (when @&type/!flag - ;; (prn 'analyse-record (&type/show-type exo-type) - ;; (&/->seq (&/|map (fn [pair] - ;; (|let [[k v] pair] - ;; (str (&/show-ast k) " " (&/show-ast v)))) - ;; ?elems)))) - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - - (&/$UnivQ _) - (|do [$var &type/existential - =type (&type/apply-type exo-type $var)] - (&type/actual-type =type)) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [=type (&type/apply-type exo-type $var)] - ;; (&type/actual-type =type)))) - - _ - (&type/actual-type exo-type)) - types (|case exo-type* - (&/$TupleT ?table) - (return ?table) - - _ - (fail (str "[Analyser Error] The type of a record must be a record-type:\n" (&type/show-type exo-type*) "\n" (&type/show-type exo-type)))) - _ (&/assert! (= (&/|length types) (&/|length ?elems)) - (str "[Analyser Error] Record length mismatch. Expected: " (&/|length types) "; actual: " (&/|length ?elems))) - members (&&record/order-record ?elems) - =members (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - types members)] - (return (&/|list (&/T (&/V &&/$tuple =members) exo-type))))) + (|do [members (&&record/order-record ?elems)] + (analyse-tuple analyse exo-type members))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -222,7 +215,10 @@ ;; (prn 'analyse-apply* (aget fun-type 0)) (|case ?args (&/$Nil) - (|do [_ (&type/check exo-type fun-type)] + (|do [;; :let [_ (prn 'analyse-apply*/_0 (&type/show-type exo-type) (&type/show-type fun-type))] + _ (&type/check exo-type fun-type) + ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))] + ] (return (&/T fun-type (&/|list)))) (&/$Cons ?arg ?args*) @@ -248,7 +244,12 @@ (&/$LambdaT ?input-t ?output-t) (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&&/analyse-1 analyse ?input-t ?arg)] + =arg (with-attempt + (&&/analyse-1 analyse ?input-t ?arg) + (fn [err] + (fail (str err "\n" + 'analyse-apply* " " (&type/show-type exo-type) " " (&type/show-type ?fun-type*) + " " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))] (return (&/T =output-t (&/Cons$ =arg =args)))) ;; [[&/$VarT ?id-t]] @@ -325,35 +326,39 @@ (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type* (&type/apply-type exo-type $var) - [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (|case $var - (&/$VarT ?id) - (|do [? (&type/bound? ?id)] - (if ? - (|do [dtype (&type/deref ?id) - ;; dtype* (&type/actual-type dtype) - ] - (|case dtype - (&/$BoundT ?vname) - (return (&/T _expr exo-type)) - - (&/$ExT _) - (return (&/T _expr exo-type)) - - (&/$VarT ?_id) - (|do [?? (&type/bound? ?_id)] - ;; (return (&/T _expr exo-type)) - (if ?? - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) - (return (&/T _expr exo-type))) - ) - - _ - (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) - (return (&/T _expr exo-type)))))))) + (|do [$var &type/existential + exo-type* (&type/apply-type exo-type $var) + [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] + (return (&/T _expr exo-type))) + ;; (&type/with-var + ;; (fn [$var] + ;; (|do [exo-type* (&type/apply-type exo-type $var) + ;; [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] + ;; (|case $var + ;; (&/$VarT ?id) + ;; (|do [? (&type/bound? ?id)] + ;; (if ? + ;; (|do [dtype (&type/deref ?id) + ;; ;; dtype* (&type/actual-type dtype) + ;; ] + ;; (|case dtype + ;; (&/$BoundT ?vname) + ;; (return (&/T _expr exo-type)) + + ;; (&/$ExT _) + ;; (return (&/T _expr exo-type)) + + ;; (&/$VarT ?_id) + ;; (|do [?? (&type/bound? ?_id)] + ;; ;; (return (&/T _expr exo-type)) + ;; (if ?? + ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) + ;; (return (&/T _expr exo-type))) + ;; ) + + ;; _ + ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) + ;; (return (&/T _expr exo-type)))))))) _ (|do [exo-type* (&type/actual-type exo-type)] diff --git a/src/lux/type.clj b/src/lux/type.clj index 5fbc33de2..889d4fc47 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -342,7 +342,9 @@ (deref id) _ - (fail (str "[Type Error] Type is not a variable: " (show-type type))))) + ;; (assert false (str "[Type Error] Type is not a variable: " (show-type type))) + (fail (str "[Type Error] Type is not a variable: " (show-type type))) + )) (defn set-var [id type] (fn [state] @@ -370,6 +372,7 @@ id)))) (def existential + ;; (Lux Type) (|do [seed &/gen-id] (return (&/V &/$ExT seed)))) @@ -650,6 +653,9 @@ (&/$NamedT ?name ?type) (apply-type ?type param) + + (&/$ExT id) + (return (App$ type-fn param)) _ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) @@ -728,6 +734,11 @@ (check* class-loader fixpoints expected bound)) state))) + [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] + (if (= eid aid) + (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)] @@ -757,6 +768,7 @@ [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)] ;; (return (&/T fixpoints nil))) -- cgit v1.2.3 From 7194d9277594662e12c3536044e2251e39a6da4f Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 8 Sep 2015 10:13:31 -0400 Subject: - A few minor fixes in the standard library. - The "impl" methods in lambda classes are now marked "final" --- src/lux/compiler/lambda.clj | 69 +++++++++++++++++++------------------- src/lux/compiler/lux.clj | 80 +++++++++++++++++++++++---------------------- src/lux/type.clj | 64 ++++++++++++++++++++---------------- 3 files changed, 112 insertions(+), 101 deletions(-) (limited to 'src') 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- 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--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- 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--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 "" "()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 "" "()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) -- cgit v1.2.3 From dbbd680d0a47c64eeb2627d458c22e8ea16206d5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 9 Sep 2015 18:36:22 -0400 Subject: - Added type inference for functions. - Fixed a bug wherein the "case" macro ignored tokens when receiving uneven inputs. --- src/lux/analyser/host.clj | 43 +++++++++------ src/lux/analyser/lux.clj | 130 +++++++++++++++++++++++++++++----------------- src/lux/compiler/type.clj | 3 ++ src/lux/type.clj | 16 +++++- 4 files changed, 124 insertions(+), 68 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 0b333ce07..9a05a6695 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -49,6 +49,29 @@ _ type)) +(defn ^:private as-otype [tname] + (case tname + "boolean" "java.lang.Boolean" + "byte" "java.lang.Byte" + "short" "java.lang.Short" + "int" "java.lang.Integer" + "long" "java.lang.Long" + "float" "java.lang.Float" + "double" "java.lang.Double" + "char" "java.lang.Character" + ;; else + tname + )) + +(defn ^:private as-otype+ [type] + "(-> Type Type)" + (|case type + (&/$DataT tname) + (&/V &/$DataT (as-otype tname)) + + _ + type)) + ;; [Resources] (do-template [ ] (let [input-type (&/V &/$DataT ) @@ -144,7 +167,7 @@ =classes ?args) :let [output-type =return] - _ (&type/check exo-type output-type)] + _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type ?class ?object] @@ -163,7 +186,7 @@ =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] - _ (&type/check exo-type output-type)] + _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual @@ -181,7 +204,7 @@ (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) =classes ?args) :let [output-type =return] - _ (&type/check exo-type output-type)] + _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type ?object] @@ -252,20 +275,6 @@ :concurrency nil} modifiers)) -(defn ^:private as-otype [tname] - (case tname - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - tname - )) - (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] (|do [=interfaces (&/map% extract-text ?interfaces) =fields (&/map% (fn [?field] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index f22cc6c9a..39eda451f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -301,27 +301,80 @@ (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&type/Univ$ env (embed-inferred-input input output*)) + + _ + (&type/Lambda$ input output))) + (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) - ;; (|do [$var &type/existential - ;; exo-type** (&type/apply-type exo-type* $var)] - ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) - - (&/$LambdaT ?arg-t ?return-t) - (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) - - _ - (fail (str "[Analyser Error] Functions require function types: " - (&type/show-type exo-type*)))))) + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/deref id)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (&type/with-var + (fn [$input] + (&type/with-var + (fn [$output] + (|do [[lambda-analysis lambda-type] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) + =input (&type/resolve-type $input) + =output (&type/resolve-type $output) + inferred-type (|case =input + (&/$VarT iid) + (|do [:let [=input* (&type/Bound$ (->> (count-univq =output) (* 2) (+ 1)))] + _ (&type/set-var iid =input*) + =output* (&type/clean $input =output) + =output** (&type/clean $output =output*)] + (return (&type/Univ$ (&/|list) (embed-inferred-input =input* =output**)))) + + _ + (|do [=output* (&type/clean $input =output) + =output** (&type/clean $output =output*)] + (return (embed-inferred-input =input =output**)))) + _ (&type/check exo-type inferred-type) + ] + (return (&/T lambda-analysis inferred-type))) + )))))) + + _ + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) + ;; (|do [$var &type/existential + ;; exo-type** (&type/apply-type exo-type* $var)] + ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + + (&/$LambdaT ?arg-t ?return-t) + (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* + ?arg ?arg-t + (&&/analyse-1 analyse ?return-t ?body))] + (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + + + + _ + (fail (str "[Analyser Error] Functions require function types: " + (&type/show-type exo-type*))))) + )) (defn analyse-lambda** [analyse exo-type ?self ?arg ?body] (|case exo-type @@ -330,35 +383,14 @@ exo-type* (&type/apply-type exo-type $var) [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] (return (&/T _expr exo-type))) - ;; (&type/with-var - ;; (fn [$var] - ;; (|do [exo-type* (&type/apply-type exo-type $var) - ;; [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - ;; (|case $var - ;; (&/$VarT ?id) - ;; (|do [? (&type/bound? ?id)] - ;; (if ? - ;; (|do [dtype (&type/deref ?id) - ;; ;; dtype* (&type/actual-type dtype) - ;; ] - ;; (|case dtype - ;; (&/$BoundT ?vname) - ;; (return (&/T _expr exo-type)) - - ;; (&/$ExT _) - ;; (return (&/T _expr exo-type)) - - ;; (&/$VarT ?_id) - ;; (|do [?? (&type/bound? ?_id)] - ;; ;; (return (&/T _expr exo-type)) - ;; (if ?? - ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))) - ;; (return (&/T _expr exo-type))) - ;; ) - - ;; _ - ;; (fail (str "[Analyser Error] Can't use type-var in any type-specific way inside polymorphic functions: " ?id " " (&type/show-type dtype))))) - ;; (return (&/T _expr exo-type)))))))) + + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (|do [exo-type* (&type/actual-type exo-type)] + (analyse-lambda* analyse exo-type* ?self ?arg ?body)) + ;; Inference + (analyse-lambda* analyse exo-type ?self ?arg ?body))) _ (|do [exo-type* (&type/actual-type exo-type)] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 0d0300844..d75f6afef 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -80,4 +80,7 @@ (&/$NamedT [?module ?name] ?type) (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) (->analysis ?type)))) + + _ + (assert false (&type/show-type type)) )) diff --git a/src/lux/type.clj b/src/lux/type.clj index 4672b18d4..3b7349fca 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -26,8 +26,8 @@ (def ^:private empty-env (&/V &/$Nil nil)) (defn Data$ [name] (&/V &/$DataT name)) -(defn Bound$ [name] - (&/V &/$BoundT name)) +(defn Bound$ [idx] + (&/V &/$BoundT idx)) (defn Var$ [id] (&/V &/$VarT id)) (defn Lambda$ [in out] @@ -986,3 +986,15 @@ _ (return false))) + +(defn resolve-type [type] + "(-> Type (Lux Type))" + (|case type + (&/$VarT id) + (|do [? (bound? id)] + (if ? + (deref id) + (return type))) + + _ + (return type))) -- cgit v1.2.3 From c0613f6fb6d225c022c306ce70c8b18c0ec9cf71 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 10 Sep 2015 20:03:14 -0400 Subject: - Implemented inference for constructing records. --- src/lux/analyser.clj | 2 +- src/lux/analyser/base.clj | 9 ++- src/lux/analyser/case.clj | 4 +- src/lux/analyser/lux.clj | 146 ++++++++++++++++++++++++++--------------- src/lux/analyser/module.clj | 31 ++++----- src/lux/analyser/record.clj | 154 ++++++-------------------------------------- 6 files changed, 139 insertions(+), 207 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 9a57191f5..d17eeea2a 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -499,7 +499,7 @@ (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) (&/$TupleS ?elems) - (&&lux/analyse-tuple analyse exo-type ?elems) + (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) (&/$RecordS ?elems) (&&lux/analyse-record analyse exo-type ?elems) diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 7f7980e76..e27b2e42e 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -130,15 +130,18 @@ (|let [[_ type] syntax+] type)) -(defn analyse-1 [analyse exo-type elem] - (|do [output (analyse exo-type elem)] - (|case output +(defn cap-1 [action] + (|do [result action] + (|case result (&/$Cons x (&/$Nil)) (return x) _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) +(defn analyse-1 [analyse exo-type elem] + (cap-1 (analyse exo-type elem))) + (defn analyse-1+ [analyse ?token] (&type/with-var (fn [$var] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index f2afdb0e9..7226b98e4 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -178,8 +178,8 @@ (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) (&/$RecordS pairs) - (|do [?members (&&record/order-record pairs)] - (analyse-pattern value-type (&/T meta (&/V &/$TupleS ?members)) kont)) + (|do [[rec-members rec-type] (&&record/order-record pairs)] + (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont)) (&/$TagS ?ident) (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 39eda451f..a6f41c9fd 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -18,35 +18,84 @@ [module :as &&module] [record :as &&record]))) +;; [Utils] +(defn ^:private count-univq [type] + "(-> Type Int)" + (|case type + (&/$UnivQ env type*) + (inc (count-univq type*)) + + _ + 0)) + +(defn ^:private next-bound-type [type] + "(-> Type Type)" + (&type/Bound$ (->> (count-univq type) (* 2) (+ 1)))) + +(defn ^:private embed-inferred-input [input output] + "(-> Type Type Type)" + (|case output + (&/$UnivQ env output*) + (&type/Univ$ env (embed-inferred-input input output*)) + + _ + (&type/Lambda$ input output))) + ;; [Exports] -(defn analyse-tuple [analyse exo-type ?elems] - (|do [unknown? (&type/unknown? exo-type)] - (if unknown? - (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] - (return =analysis)) - ?elems) - _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$TupleT ?members) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) - - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-tuple analyse exo-type** ?elems)))) +(defn analyse-tuple [analyse ?exo-type ?elems] + (|case ?exo-type + (&/$Left exo-type) + (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))] + exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + =var (&type/resolve-type $var) + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type tuple-type)] + _ (&type/set-var iid =var*) + tuple-type* (&type/clean $var tuple-type)] + (return (&type/Univ$ (&/|list) tuple-type*))) + + _ + (&type/clean $var tuple-type))] + (return (&/|list (&/T tuple-analysis inferred-type)))))) - _ - (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ))))) + _ + (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) + + (&/$Right exo-type) + (|do [unknown? (&type/unknown? exo-type)] + (if unknown? + (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] + (return =analysis)) + ?elems) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + (|do [exo-type* (&type/actual-type exo-type)] + (|case exo-type* + (&/$TupleT ?members) + (|do [=elems (&/map2% (fn [elem-t elem] + (&&/analyse-1 analyse elem-t elem)) + ?members ?elems)] + (return (&/|list (&/T (&/V &&/$tuple =elems) + exo-type)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var) + [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + (return (&/|list (&/T tuple-analysis exo-type)))) + + _ + (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) + )))))) (defn with-attempt [m-value on-error] (fn [state] @@ -61,13 +110,13 @@ (|do [output (with-attempt (|case ?values (&/$Nil) - (analyse-tuple analyse exo-type (&/|list)) + (analyse-tuple analyse (&/V &/$Right exo-type) (&/|list)) (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) _ - (analyse-tuple analyse exo-type ?values)) + (analyse-tuple analyse (&/V &/$Right exo-type) ?values)) (fn [err] (fail (str err "\n" 'analyse-variant-body " " (&type/show-type exo-type) @@ -121,8 +170,19 @@ (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) (defn analyse-record [analyse exo-type ?elems] - (|do [members (&&record/order-record ?elems)] - (analyse-tuple analyse exo-type members))) + (|do [[rec-members rec-type] (&&record/order-record ?elems)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if ? + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + (|do [[tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + _ (&type/check exo-type tuple-type)] + (return (&/|list (&/T tuple-analysis exo-type)))))) + + _ + (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) + ))) (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) @@ -301,24 +361,6 @@ (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) exo-type))))) -(defn ^:private count-univq [type] - "(-> Type Int)" - (|case type - (&/$UnivQ env type*) - (inc (count-univq type*)) - - _ - 0)) - -(defn ^:private embed-inferred-input [input output] - "(-> Type Type Type)" - (|case output - (&/$UnivQ env output*) - (&type/Univ$ env (embed-inferred-input input output*)) - - _ - (&type/Lambda$ input output))) - (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|case exo-type (&/$VarT id) @@ -336,7 +378,7 @@ =output (&type/resolve-type $output) inferred-type (|case =input (&/$VarT iid) - (|do [:let [=input* (&type/Bound$ (->> (count-univq =output) (* 2) (+ 1)))] + (|do [:let [=input* (next-bound-type =output)] _ (&type/set-var iid =input*) =output* (&type/clean $input =output) =output** (&type/clean $output =output*)] @@ -424,7 +466,9 @@ (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - _ (println 'DEF (str module-name ";" ?name))]] + [def-analysis def-type] =value + _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) + )]] (return (&/|list))))) )))) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 8c27fc08d..aaed26a7a 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -343,20 +343,17 @@ nil)) (fail* (str "[Lux Error] Unknown module: " module)))))) -(defn tag-index [module tag-name] - "(-> Text Text (Lux Int))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags 0)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) - -(defn tag-group [module tag-name] - "(-> Text Text (Lux (List Ident)))" - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [^objects idx+tags (&/|get tag-name (&/get$ $tags =module))] - (return* state (aget idx+tags 1)) - (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) - (fail* (str "[Module Error] Unknown module: " module))))) +(do-template [ ] + (defn [module tag-name] + + (fn [state] + (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] + (if-let [^objects idx+tags+type (&/|get tag-name (&/get$ $tags =module))] + (return* state (aget idx+tags+type )) + (fail* (str "[Module Error] Unknown tag: " (&/ident->text (&/T module tag-name))))) + (fail* (str "[Module Error] Unknown module: " module))))) + + tag-index 0 "(-> Text Text (Lux Int))" + tag-group 1 "(-> Text Text (Lux (List Ident)))" + tag-type 2 "(-> Text Text (Lux Type))" + ) diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 8b70bbcb4..0f860888b 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -6,139 +6,26 @@ (ns lux.analyser.record (:require clojure.core.match clojure.core.match.array - (lux [base :as & :refer [deftags |let |do return fail |case]]) + (lux [base :as & :refer [deftags |let |do return fail |case]] + [type :as &type]) (lux.analyser [base :as &&] [module :as &&module]))) -;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) - ;; [Exports] (defn order-record [pairs] "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" - (|do [tag-group (|case pairs - (&/$Nil) - (return (&/|list)) - - (&/$Cons [[_ (&/$TagS tag1)] _] _) - (|do [[module name] (&&/resolved-ident tag1)] - (&&module/tag-group module name)) - - _ - (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) + (|do [[tag-group tag-type] (|case pairs + (&/$Nil) + (return (&/T (&/|list) &type/Unit)) + + (&/$Cons [[_ (&/$TagS tag1)] _] _) + (|do [[module name] (&&/resolved-ident tag1) + tags (&&module/tag-group module name) + type (&&module/tag-type module name)] + (return (&/T tags type))) + + _ + (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags.")) =pairs (&/map% (fn [kv] (|case kv [[_ (&/$TagS k)] v] @@ -147,9 +34,10 @@ _ (fail "[Analyser Error] Wrong syntax for records. Odd elements must be tags."))) - pairs)] - (&/map% (fn [tag] - (if-let [member (&/|get tag =pairs)] - (return member) - (fail (str "[Analyser Error] Unknown tag: " tag)))) - (&/|map &/ident->text tag-group)))) + pairs) + =members (&/map% (fn [tag] + (if-let [member (&/|get tag =pairs)] + (return member) + (fail (str "[Analyser Error] Unknown tag: " tag)))) + (&/|map &/ident->text tag-group))] + (return (&/T =members tag-type)))) -- cgit v1.2.3 From d74df875db45cdbe67d7de2fbbf0c971cc570881 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Thu, 10 Sep 2015 23:44:25 -0400 Subject: - Added inference during construction of variants. --- src/lux/analyser.clj | 31 +++++++++----- src/lux/analyser/base.clj | 5 +++ src/lux/analyser/lux.clj | 106 +++++++++++++++++++++++++++++++--------------- 3 files changed, 98 insertions(+), 44 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index d17eeea2a..a9689a9d0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -43,6 +43,23 @@ _ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) +(defn analyse-variant+ [analyser exo-type ident values] + (|do [[module tag-name] (&/normalize ident) + idx (&&module/tag-index module tag-name)] + (|case exo-type + (&/$VarT id) + (|do [? (&type/bound? id)] + (if (or ? (&&/type-tag? module tag-name)) + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + (|do [wanted-type (&&module/tag-type module tag-name) + [variant-analysis variant-type] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + _ (&type/check exo-type variant-type)] + (return (&/|list (&/T variant-analysis exo-type)))))) + + _ + (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) + ))) + (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays @@ -505,9 +522,7 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (|do [[module tag-name] (&/normalize ?ident) - idx (&&module/tag-index module tag-name)] - (&&lux/analyse-variant analyse exo-type idx (&/|list))) + (analyse-variant+ analyse exo-type ?ident (&/|list)) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) @@ -573,16 +588,10 @@ (&/with-expected-type exo-type (|case token [meta (&/$FormS (&/$Cons [_ (&/$IntS idx)] ?values))] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values) + (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) (&/V &/$Right exo-type) idx ?values) [meta (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values))] - (|do [;; :let [_ (println 'analyse-ast/_0 (&/ident->text ?ident))] - [module tag-name] (&/normalize ?ident) - ;; :let [_ (println 'analyse-ast/_1 (&/ident->text (&/T module tag-name)))] - idx (&&module/tag-index module tag-name) - ;; :let [_ (println 'analyse-ast/_2 idx)] - ] - (&&lux/analyse-variant (partial analyse-ast eval! compile-module compile-token) exo-type idx ?values)) + (analyse-variant+ (partial analyse-ast eval! compile-module compile-token) exo-type ?ident ?values) [meta (&/$FormS (&/$Cons ?fn ?args))] (fn [state] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index e27b2e42e..1507a3a76 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -156,3 +156,8 @@ &/get-module-name (return ?module))] (return (&/T module* ?name))))) + +(let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] + (defn type-tag? [module name] + (and (= "lux" module) + (contains? tag-names name)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index a6f41c9fd..b8239d1a9 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -133,41 +133,75 @@ _ (fail "[Analyser Error] Can't expand to other than 1 element.")))) -(defn analyse-variant [analyse exo-type idx ?values] - (|do [exo-type* (|case exo-type - (&/$VarT ?id) - (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - (|do [_ (&type/set-var ?id &type/Type)] - (&type/actual-type &type/Type)))) - - _ - (&type/actual-type exo-type))] - (|case exo-type* - (&/$VariantT ?cases) - (|case (&/|at idx ?cases) - (&/$Some vtype) - (|do [=value (with-attempt - (analyse-variant-body analyse vtype ?values) - (fn [err] - (|do [_exo-type (&type/deref+ exo-type)] - (fail (str err "\n" - 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) - " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) +(defn analyse-variant [analyse ?exo-type idx ?values] + (|case ?exo-type + (&/$Left exo-type) + (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))] + exo-type* (&type/actual-type exo-type) + ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))] + ] + (|case exo-type* + (&/$UnivQ _) + (&type/with-var + (fn [$var] + (|do [exo-type** (&type/apply-type exo-type* $var) + ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] + [variant-analysis variant-type] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] + =var (&type/resolve-type $var) + ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] + inferred-type (|case =var + (&/$VarT iid) + (|do [:let [=var* (next-bound-type variant-type)] + _ (&type/set-var iid =var*) + variant-type* (&type/clean $var variant-type)] + (return (&type/Univ$ (&/|list) variant-type*))) - (&/$None) - (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + _ + (&type/clean $var variant-type)) + ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] + ] + (return (&/|list (&/T variant-analysis inferred-type)))))) - (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse exo-type** idx ?values)))) - - _ - (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*)))))) + _ + (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) + + (&/$Right exo-type) + ;; [_ exo-type] + (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))] + exo-type* (|case exo-type + (&/$VarT ?id) + (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] + (&type/actual-type exo-type*)) + (|do [_ (&type/set-var ?id &type/Type)] + (&type/actual-type &type/Type)))) + + _ + (&type/actual-type exo-type))] + (|case exo-type* + (&/$VariantT ?cases) + (|case (&/|at idx ?cases) + (&/$Some vtype) + (|do [=value (with-attempt + (analyse-variant-body analyse vtype ?values) + (fn [err] + (|do [_exo-type (&type/deref+ exo-type)] + (fail (str err "\n" + 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] + (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) + exo-type)))) + + (&/$None) + (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) + + (&/$UnivQ _) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-variant analyse (&/V &/$Right exo-type**) idx ?values)) + + _ + (fail (str "[Analyser Error] Can't create a variant if the expected type is " (&type/show-type exo-type*))))))) (defn analyse-record [analyse exo-type ?elems] (|do [[rec-members rec-type] (&&record/order-record ?elems)] @@ -465,6 +499,12 @@ _ (do ;; (println 'DEF (str module-name ";" ?name)) (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + ;; _ (if (and (= "lux" module-name) + ;; (= "Type" ?name)) + ;; (|do [newly-defined-Type + ;; :let [_ (&type/redefine-type! newly-defined-Type)]] + ;; (return nil)) + ;; (return nil)) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) [def-analysis def-type] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) -- cgit v1.2.3 From 5a26c40dc215dfb22a77cad28455deff28ca9976 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 11 Sep 2015 19:46:30 -0400 Subject: - Implemented the with-open macro. - Cleaned-up a bit the tag-generation macro "deftags". --- src/lux/analyser/base.clj | 226 ++++++++++++++++++++++---------------------- src/lux/analyser/case.clj | 36 +++---- src/lux/analyser/module.clj | 13 +-- src/lux/base.clj | 127 +++++++++++++------------ src/lux/lexer.clj | 32 +++---- src/lux/reader.clj | 8 +- 6 files changed, 221 insertions(+), 221 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 1507a3a76..0bb40c71b 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -10,120 +10,118 @@ [type :as &type]))) ;; [Tags] -(deftags "" - "bool" - "int" - "real" - "char" - "text" - "variant" - "tuple" - "apply" - "case" - "lambda" - "ann" - "def" - "declare-macro" - "var" - "captured" - - "jvm-getstatic" - "jvm-getfield" - "jvm-putstatic" - "jvm-putfield" - "jvm-invokestatic" - "jvm-instanceof" - "jvm-invokevirtual" - "jvm-invokeinterface" - "jvm-invokespecial" - "jvm-null?" - "jvm-null" - "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" - "jvm-class" - "jvm-interface" - "jvm-try" - "jvm-throw" - "jvm-monitorenter" - "jvm-monitorexit" - "jvm-program" - - "jvm-iadd" - "jvm-isub" - "jvm-imul" - "jvm-idiv" - "jvm-irem" - "jvm-ieq" - "jvm-ilt" - "jvm-igt" - - "jvm-ceq" - "jvm-clt" - "jvm-cgt" - - "jvm-ladd" - "jvm-lsub" - "jvm-lmul" - "jvm-ldiv" - "jvm-lrem" - "jvm-leq" - "jvm-llt" - "jvm-lgt" - - "jvm-fadd" - "jvm-fsub" - "jvm-fmul" - "jvm-fdiv" - "jvm-frem" - "jvm-feq" - "jvm-flt" - "jvm-fgt" - - "jvm-dadd" - "jvm-dsub" - "jvm-dmul" - "jvm-ddiv" - "jvm-drem" - "jvm-deq" - "jvm-dlt" - "jvm-dgt" - - "jvm-d2f" - "jvm-d2i" - "jvm-d2l" - - "jvm-f2d" - "jvm-f2i" - "jvm-f2l" - - "jvm-i2b" - "jvm-i2c" - "jvm-i2d" - "jvm-i2f" - "jvm-i2l" - "jvm-i2s" - - "jvm-l2d" - "jvm-l2f" - "jvm-l2i" - - "jvm-iand" - "jvm-ior" - "jvm-ixor" - "jvm-ishl" - "jvm-ishr" - "jvm-iushr" - - "jvm-land" - "jvm-lor" - "jvm-lxor" - "jvm-lshl" - "jvm-lshr" - "jvm-lushr" - - ) +(deftags + ["bool" + "int" + "real" + "char" + "text" + "variant" + "tuple" + "apply" + "case" + "lambda" + "ann" + "def" + "declare-macro" + "var" + "captured" + + "jvm-getstatic" + "jvm-getfield" + "jvm-putstatic" + "jvm-putfield" + "jvm-invokestatic" + "jvm-instanceof" + "jvm-invokevirtual" + "jvm-invokeinterface" + "jvm-invokespecial" + "jvm-null?" + "jvm-null" + "jvm-new" + "jvm-new-array" + "jvm-aastore" + "jvm-aaload" + "jvm-class" + "jvm-interface" + "jvm-try" + "jvm-throw" + "jvm-monitorenter" + "jvm-monitorexit" + "jvm-program" + + "jvm-iadd" + "jvm-isub" + "jvm-imul" + "jvm-idiv" + "jvm-irem" + "jvm-ieq" + "jvm-ilt" + "jvm-igt" + + "jvm-ceq" + "jvm-clt" + "jvm-cgt" + + "jvm-ladd" + "jvm-lsub" + "jvm-lmul" + "jvm-ldiv" + "jvm-lrem" + "jvm-leq" + "jvm-llt" + "jvm-lgt" + + "jvm-fadd" + "jvm-fsub" + "jvm-fmul" + "jvm-fdiv" + "jvm-frem" + "jvm-feq" + "jvm-flt" + "jvm-fgt" + + "jvm-dadd" + "jvm-dsub" + "jvm-dmul" + "jvm-ddiv" + "jvm-drem" + "jvm-deq" + "jvm-dlt" + "jvm-dgt" + + "jvm-d2f" + "jvm-d2i" + "jvm-d2l" + + "jvm-f2d" + "jvm-f2i" + "jvm-f2l" + + "jvm-i2b" + "jvm-i2c" + "jvm-i2d" + "jvm-i2f" + "jvm-i2l" + "jvm-i2s" + + "jvm-l2d" + "jvm-l2f" + "jvm-l2i" + + "jvm-iand" + "jvm-ior" + "jvm-ixor" + "jvm-ishl" + "jvm-ishr" + "jvm-iushr" + + "jvm-land" + "jvm-lor" + "jvm-lxor" + "jvm-lshl" + "jvm-lshr" + "jvm-lushr"]) ;; [Exports] (defn expr-type* [syntax+] diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 7226b98e4..a0f07cdce 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -15,26 +15,26 @@ [record :as &&record]))) ;; [Tags] -(deftags "" - "DefaultTotal" - "BoolTotal" - "IntTotal" - "RealTotal" - "CharTotal" - "TextTotal" - "TupleTotal" - "VariantTotal" +(deftags + ["DefaultTotal" + "BoolTotal" + "IntTotal" + "RealTotal" + "CharTotal" + "TextTotal" + "TupleTotal" + "VariantTotal"] ) -(deftags "" - "StoreTestAC" - "BoolTestAC" - "IntTestAC" - "RealTestAC" - "CharTestAC" - "TextTestAC" - "TupleTestAC" - "VariantTestAC" +(deftags + ["StoreTestAC" + "BoolTestAC" + "IntTestAC" + "RealTestAC" + "CharTestAC" + "TextTestAC" + "TupleTestAC" + "VariantTestAC"] ) ;; [Utils] diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index aaed26a7a..6740d6515 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -14,12 +14,13 @@ [host :as &host]))) ;; [Utils] -(deftags "" - "module-aliases" - "defs" - "imports" - "tags" - "types") +(deftags + ["module-aliases" + "defs" + "imports" + "tags" + "types"]) + (def ^:private +init+ (&/T ;; "lux;module-aliases" (&/|table) diff --git a/src/lux/base.clj b/src/lux/base.clj index 4db1d26bc..c0f28f519 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -9,93 +9,94 @@ clojure.core.match.array)) ;; [Tags] -(defmacro deftags [prefix & names] +(defmacro deftags [names] + (assert (vector? names)) `(do ~@(for [[name idx] (map vector names (range (count names)))] `(def ~(symbol (str "$" name)) ~idx)))) ;; List -(deftags "" - "Nil" - "Cons") +(deftags + ["Nil" + "Cons"]) ;; Maybe -(deftags "" - "None" - "Some") +(deftags + ["None" + "Some"]) ;; Either -(deftags "" - "Left" - "Right") +(deftags + ["Left" + "Right"]) ;; AST -(deftags "" - "BoolS" - "IntS" - "RealS" - "CharS" - "TextS" - "SymbolS" - "TagS" - "FormS" - "TupleS" - "RecordS") +(deftags + ["BoolS" + "IntS" + "RealS" + "CharS" + "TextS" + "SymbolS" + "TagS" + "FormS" + "TupleS" + "RecordS"]) ;; Type -(deftags "" - "DataT" - "VariantT" - "TupleT" - "LambdaT" - "BoundT" - "VarT" - "ExT" - "UnivQ" - "ExQ" - "AppT" - "NamedT") +(deftags + ["DataT" + "VariantT" + "TupleT" + "LambdaT" + "BoundT" + "VarT" + "ExT" + "UnivQ" + "ExQ" + "AppT" + "NamedT"]) ;; Vars -(deftags "lux;" - "Local" - "Global") +(deftags + ["Local" + "Global"]) ;; Definitions -(deftags "lux;" - "ValueD" - "TypeD" - "MacroD" - "AliasD") +(deftags + ["ValueD" + "TypeD" + "MacroD" + "AliasD"]) ;; Binding -(deftags "" - "counter" - "mappings") +(deftags + ["counter" + "mappings"]) ;; Env -(deftags "" - "name" - "inner-closures" - "locals" - "closure") +(deftags + ["name" + "inner-closures" + "locals" + "closure"]) ;; Host -(deftags "" - "writer" - "loader" - "classes") +(deftags + ["writer" + "loader" + "classes"]) ;; Compiler -(deftags "" - "source" - "cursor" - "modules" - "envs" - "type-vars" - "expected" - "seed" - "eval?" - "host") +(deftags + ["source" + "cursor" + "modules" + "envs" + "type-vars" + "expected" + "seed" + "eval?" + "host"]) ;; [Exports] (def datum-field "_datum") diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index b3a47f3e0..fd694c51c 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -10,22 +10,22 @@ [lux.analyser.module :as &module])) ;; [Tags] -(deftags "" - "White_Space" - "Comment" - "Bool" - "Int" - "Real" - "Char" - "Text" - "Symbol" - "Tag" - "Open_Paren" - "Close_Paren" - "Open_Bracket" - "Close_Bracket" - "Open_Brace" - "Close_Brace" +(deftags + ["White_Space" + "Comment" + "Bool" + "Int" + "Real" + "Char" + "Text" + "Symbol" + "Tag" + "Open_Paren" + "Close_Paren" + "Open_Bracket" + "Close_Bracket" + "Open_Brace" + "Close_Brace"] ) ;; [Utils] diff --git a/src/lux/reader.clj b/src/lux/reader.clj index 7b1559f07..751df7e6d 100644 --- a/src/lux/reader.clj +++ b/src/lux/reader.clj @@ -10,10 +10,10 @@ [lux.base :as & :refer [deftags |do return* return fail fail* |let |case]])) ;; [Tags] -(deftags "" - "No" - "Done" - "Yes") +(deftags + ["No" + "Done" + "Yes"]) ;; [Utils] (defn ^:private with-line [body] -- cgit v1.2.3 From 5148900e02c8e05808afc8a3ec7fc51a901bcc7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 11 Sep 2015 22:16:58 -0400 Subject: - Abandoned the old format for classes of having module names separated by underscores, and now using slashes and putting submodules inside the directories of their parent modules. --- src/lux/analyser/module.clj | 2 +- src/lux/compiler.clj | 2 +- src/lux/compiler/base.clj | 8 ++++---- src/lux/compiler/cache.clj | 17 ++++++++--------- src/lux/compiler/package.clj | 18 +++++++++++++----- src/lux/host.clj | 13 ++++++++----- 6 files changed, 35 insertions(+), 25 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 6740d6515..97365ba08 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -204,7 +204,7 @@ [exported? (&/$ValueD ?type _)] ((|do [_ (&type/check &type/Macro ?type) ^ClassLoader loader &/loader - :let [macro (-> (.loadClass loader (str (&host/->module-class module) "." (&/normalize-name name))) + :let [macro (-> (.loadClass loader (str (&host/->class-name module) "." (&/normalize-name name))) (.getField &/datum-field) (.get nil))]] (fn [state*] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index e16a84b20..da9896bd5 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -392,7 +392,7 @@ .visitEnd))] _ (&&/save-class! (str id) bytecode) loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host/->module-class module) "." id)) + (-> (.loadClass ^ClassLoader loader (str (&host/->class-name module) "." id)) (.getField &/eval-field) (.get nil) return)))) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index edb1441ca..7c1297aad 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -26,8 +26,8 @@ ;; [Constants] (def ^String version "0.3") (def ^String input-dir "source") -(def ^String output-dir "target/jvm") -(def ^String output-package (str output-dir "/program.jar")) +(def ^String output-dir "target/jvm/") +(def ^String output-package (str output-dir "program.jar")) (def ^String function-class "lux/Function") ;; Formats @@ -55,7 +55,7 @@ (defn ^:private write-output [module name data] (let [module* (&host/->module-class module) - module-dir (str output-dir "/" module*)] + module-dir (str output-dir module*)] (.mkdirs (File. module-dir)) (write-file (str module-dir "/" name ".class") data))) @@ -69,7 +69,7 @@ module &/get-module-name loader &/loader !classes &/classes - :let [real-name (str (&host/->module-class module) "." name) + :let [real-name (str (&host/->class-name module) "." name) _ (swap! !classes assoc real-name bytecode) _ (when (not eval?) (write-output module name bytecode)) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index da7ce35e9..e47da2678 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -32,11 +32,9 @@ (defn ^:private clean-file [^File file] "(-> File (,))" - (if (.isDirectory file) - (do (doseq [f (seq (.listFiles file))] - (clean-file f)) - (.delete file)) - (.delete file))) + (doseq [f (seq (.listFiles file)) + :when (not (.isDirectory f))] + (.delete f))) (defn ^:private get-field [^String field-name ^Class class] "(-> Text Class Object)" @@ -45,12 +43,12 @@ ;; [Resources] (defn cached? [module] "(-> Text Bool)" - (.exists (new File (str &&/output-dir "/" (&host/->module-class module) "/_.class")))) + (.exists (new File (str &&/output-dir (&host/->module-class module) "/" &/module-class-name ".class")))) (defn delete [module] "(-> Text (Lux (,)))" (fn [state] - (do (clean-file (new File (str &&/output-dir "/" (&host/->module-class module)))) + (do (clean-file (new File (str &&/output-dir (&host/->module-class module)))) (return* state nil)))) (defn clean [state] @@ -80,8 +78,8 @@ (return true) (if (cached? module) (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->module-class module) - module-path (str &&/output-dir "/" module*) + (let [module* (&host/->class-name module) + module-path (str &&/output-dir module) class-name (str module* "._") ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) (&&/load-class! loader class-name))] @@ -98,6 +96,7 @@ (&/->list imports)))] (if (->> loads &/->seq (every? true?)) (do (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) :let [file-name (.getName file)] :when (not= "_.class" file-name)] (let [real-name (second (re-find #"^(.*)\.class$" file-name)) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj index b1468e540..4f703f5d1 100644 --- a/src/lux/compiler/package.clj +++ b/src/lux/compiler/package.clj @@ -30,6 +30,7 @@ (defn ^:private write-class! [^String path ^File file ^JarOutputStream out] "(-> Text File JarOutputStream Unit)" + ;; (prn 'write-class! path file) (with-open [in (new BufferedInputStream (new FileInputStream file))] (let [buffer (byte-array (* 10 kilobyte))] (doto out @@ -42,11 +43,18 @@ )) )) -(defn ^:private write-module! [^File file ^JarOutputStream out] - "(-> File JarOutputStream Unit)" - (let [module-name (.getName file)] - (doseq [$class (.listFiles file)] - (write-class! module-name $class out)))) +(let [output-dir-size (.length &&/output-dir)] + (defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) + ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) + inner-files (.listFiles file) + inner-modules (filter #(.isDirectory %) inner-files) + inner-classes (filter #(not (.isDirectory %)) inner-files)] + (doseq [$class inner-classes] + (write-class! module-name $class out)) + (doseq [$module inner-modules] + (write-module! $module out))))) ;; [Resources] (defn package [module] diff --git a/src/lux/host.clj b/src/lux/host.clj index 3d61eec6a..2290f2f0a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -10,12 +10,15 @@ clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) - (:import (java.lang.reflect Field Method Modifier))) + (:import (java.lang.reflect Field Method Modifier) + java.util.regex.Pattern)) ;; [Constants] (def prefix "lux.") (def function-class (str prefix "Function")) -(def module-separator "_") +(def module-separator "/") +(def class-name-separator ".") +(def class-separator "/") ;; [Utils] (defn ^:private class->type [^Class class] @@ -35,13 +38,13 @@ ;; [Resources] (defn ^String ->class [class] - (string/replace class #"\." "/")) + (string/replace class (-> class-name-separator Pattern/quote re-pattern) class-separator)) (defn ^String ->class-name [module] - (string/replace module #"/" ".")) + (string/replace module (-> module-separator Pattern/quote re-pattern) class-name-separator)) (defn ^String ->module-class [module-name] - (string/replace module-name #"/" module-separator)) + (string/replace module-name (-> module-separator Pattern/quote re-pattern) class-separator)) (def ->package ->module-class) -- cgit v1.2.3 From 5fd179352bbf25bbe4000ae51132fd5553ba256a Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 15:06:14 -0400 Subject: - Primitive data-types can now be parameterized by other types. --- src/lux/analyser/host.clj | 48 +++++++------- src/lux/analyser/lux.clj | 12 ++-- src/lux/compiler/host.clj | 18 ++--- src/lux/compiler/type.clj | 62 ++++++++---------- src/lux/host.clj | 7 +- src/lux/type.clj | 164 +++++++++++++++++++++------------------------- 6 files changed, 145 insertions(+), 166 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9a05a6695..610f3c660 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -34,7 +34,7 @@ (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token - [_ (&/$DataT _)] + [_ (&/$DataT _ _)] (return nil) _ @@ -43,8 +43,8 @@ (defn ^:private as-object [type] "(-> Type Type)" (|case type - (&/$DataT class) - (&/V &/$DataT (&type/as-obj class)) + (&/$DataT class params) + (&type/Data$ (&type/as-obj class) params) _ type)) @@ -66,16 +66,16 @@ (defn ^:private as-otype+ [type] "(-> Type Type)" (|case type - (&/$DataT tname) - (&/V &/$DataT (as-otype tname)) + (&/$DataT name params) + (&type/Data$ (as-otype name) params) _ type)) ;; [Resources] (do-template [ ] - (let [input-type (&/V &/$DataT ) - output-type (&/V &/$DataT )] + (let [input-type (&type/Data$ (&/|list)) + output-type (&type/Data$ (&/|list))] (defn [analyse exo-type ?x ?y] (|do [=x (&&/analyse-1 analyse input-type ?x) =y (&&/analyse-1 analyse input-type ?y) @@ -160,10 +160,10 @@ =classes (&/map% extract-text ?classes) =return (&host/lookup-static-method class-loader ?class ?method =classes) ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class]] + ;; [[&/$DataT _return-class (&/|list)]] ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&/V &/$DataT _class) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class (&/|list)) _arg)) =classes ?args) :let [output-type =return] @@ -182,8 +182,8 @@ (|do [class-loader &/loader =classes (&/map% extract-text ?classes) =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) + =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] @@ -199,9 +199,9 @@ =return (if (= "" ?method) (return &type/Unit) (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&/V &/$DataT ?class) ?object) + =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&/V &/$DataT ?c) ?o)) + (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) =classes ?args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] @@ -215,19 +215,19 @@ (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&/V &/$DataT "null")] + (|do [:let [output-type (&type/Data$ "null" (&/|list))] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] (|do [=classes (&/map% extract-text ?classes) =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&/V &/$DataT ?class)] + :let [output-type (&type/Data$ ?class (&/|list))] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) (defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&/V &/$DataT ?class) + (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&type/Data$ ?class (&/|list)) (&/V &/$Nil nil))))))) (defn analyse-jvm-aastore [analyse ?array ?idx ?elem] @@ -313,11 +313,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&/V &/$DataT (as-otype itype)) + (&&env/with-local iname (&type/Data$ (as-otype itype) (&/|list)) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&/V &/$DataT (as-otype ?method-output)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) (&/|list)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/Cons$ (&/T ";this" ?super-class) @@ -360,7 +360,7 @@ (|do [:let [[?catches ?finally] ?catches+?finally] =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&/V &/$DataT ?ex-class) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class (&/|list)) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) @@ -374,7 +374,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&/V &/$DataT "java.lang.Throwable") _type)] + _ (&type/check (&type/Data$ "java.lang.Throwable" (&/|list)) _type)] (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] @@ -390,9 +390,9 @@ ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ (&/|list))] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -417,9 +417,9 @@ ) (do-template [ ] - (let [output-type (&/V &/$DataT )] + (let [output-type (&type/Data$ (&/|list))] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&/V &/$DataT ) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index b8239d1a9..6205adccb 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -364,7 +364,7 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [_ (when (or (= "defsig" (aget real-name 1)) + ;; :let [_ (when (or (= "zip" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) ;; ) @@ -431,13 +431,9 @@ (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type (&/$UnivQ _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var)] - (analyse-lambda* analyse exo-type** ?self ?arg ?body)))) - ;; (|do [$var &type/existential - ;; exo-type** (&type/apply-type exo-type* $var)] - ;; (analyse-lambda* analyse exo-type** ?self ?arg ?body)) + (|do [$var &type/existential + exo-type** (&type/apply-type exo-type* $var)] + (analyse-lambda* analyse exo-type** ?self ?arg ?body)) (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 0529ac900..db54af8ac 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -52,31 +52,31 @@ (&/$TupleT (&/$Nil)) (.visitInsn *writer* Opcodes/ACONST_NULL) - (&/$DataT "boolean") + (&/$DataT "boolean" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class boolean-class) "valueOf" (str "(Z)" (&host/->type-signature boolean-class))) - (&/$DataT "byte") + (&/$DataT "byte" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class byte-class) "valueOf" (str "(B)" (&host/->type-signature byte-class))) - (&/$DataT "short") + (&/$DataT "short" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class short-class) "valueOf" (str "(S)" (&host/->type-signature short-class))) - (&/$DataT "int") + (&/$DataT "int" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class int-class) "valueOf" (str "(I)" (&host/->type-signature int-class))) - (&/$DataT "long") + (&/$DataT "long" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class long-class) "valueOf" (str "(J)" (&host/->type-signature long-class))) - (&/$DataT "float") + (&/$DataT "float" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class float-class) "valueOf" (str "(F)" (&host/->type-signature float-class))) - (&/$DataT "double") + (&/$DataT "double" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class double-class) "valueOf" (str "(D)" (&host/->type-signature double-class))) - (&/$DataT "char") + (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - (&/$DataT _) + (&/$DataT _ (&/$Nil)) nil (&/$NamedT ?name ?type) diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index d75f6afef..6c128df80 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -39,48 +39,44 @@ "(-> Analysis Analysis Analysis)" (variant$ &/$Cons (tuple$ (&/|list head tail)))) +(defn ^:private List$ [elems] + (&/fold (fn [tail head] + (Cons$ head tail)) + $Nil + (&/|reverse elems))) + ;; [Exports] (defn ->analysis [type] "(-> Type Analysis)" (|case type - (&/$DataT ?class) - (variant$ &/$DataT (text$ ?class)) + (&/$DataT class params) + (variant$ &/$DataT (tuple$ (&/|list (text$ class) + (List$ (&/|map ->analysis params))))) - (&/$TupleT ?members) - (variant$ &/$TupleT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - - (&/$VariantT ?members) - (variant$ &/$VariantT - (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?members))) - - (&/$LambdaT ?input ?output) - (variant$ &/$LambdaT (tuple$ (&/|list (->analysis ?input) (->analysis ?output)))) - - (&/$UnivQ ?env ?body) + (&/$TupleT members) + (variant$ &/$TupleT (List$ (&/|map ->analysis members))) + + (&/$VariantT members) + (variant$ &/$VariantT (List$ (&/|map ->analysis members))) + + (&/$LambdaT input output) + (variant$ &/$LambdaT (tuple$ (&/|list (->analysis input) (->analysis output)))) + + (&/$UnivQ env body) (variant$ &/$UnivQ - (tuple$ (&/|list (&/fold (fn [tail head] - (Cons$ (->analysis head) tail)) - $Nil - (&/|reverse ?env)) - (->analysis ?body)))) + (tuple$ (&/|list (List$ (&/|map ->analysis env)) + (->analysis body)))) - (&/$BoundT ?idx) - (variant$ &/$BoundT (int$ ?idx)) + (&/$BoundT idx) + (variant$ &/$BoundT (int$ idx)) - (&/$AppT ?fun ?arg) - (variant$ &/$AppT (tuple$ (&/|list (->analysis ?fun) (->analysis ?arg)))) + (&/$AppT fun arg) + (variant$ &/$AppT (tuple$ (&/|list (->analysis fun) (->analysis arg)))) - (&/$NamedT [?module ?name] ?type) - (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ ?module) (text$ ?name))) - (->analysis ?type)))) + (&/$NamedT [module name] type*) + (variant$ &/$NamedT (tuple$ (&/|list (tuple$ (&/|list (text$ module) (text$ name))) + (->analysis type*)))) _ - (assert false (&type/show-type type)) + (assert false (prn '->analysis (&type/show-type type) (&/adt->text type))) )) diff --git a/src/lux/host.clj b/src/lux/host.clj index 2290f2f0a..0936d90eb 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -29,8 +29,9 @@ (.getSimpleName class)))] (if (.equals "void" base) (return &type/Unit) - (return (&/V &/$DataT (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base))) + (return (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base) + (&/|list))) ))) (defn ^:private method->type [^Method method] @@ -70,7 +71,7 @@ (defn ->java-sig [^objects type] "(-> Type Text)" (|case type - (&/$DataT ?name) + (&/$DataT ?name params) (->type-signature ?name) (&/$LambdaT _ _) diff --git a/src/lux/type.clj b/src/lux/type.clj index 3b7349fca..0da579cf4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -24,8 +24,8 @@ false)) (def ^:private empty-env (&/V &/$Nil nil)) -(defn Data$ [name] - (&/V &/$DataT name)) +(defn Data$ [name params] + (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] (&/V &/$BoundT idx)) (defn Var$ [id] @@ -46,13 +46,13 @@ (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (&/T "lux" "Bool") (&/V &/$DataT "java.lang.Boolean"))) -(def Int (Named$ (&/T "lux" "Int") (&/V &/$DataT "java.lang.Long"))) -(def Real (Named$ (&/T "lux" "Real") (&/V &/$DataT "java.lang.Double"))) -(def Char (Named$ (&/T "lux" "Char") (&/V &/$DataT "java.lang.Character"))) -(def Text (Named$ (&/T "lux" "Text") (&/V &/$DataT "java.lang.String"))) -(def Unit (Named$ (&/T "lux" "Unit") (&/V &/$TupleT (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (&/V &/$VariantT (&/|list)))) +(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" (&/|list)))) +(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" (&/|list)))) +(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" (&/|list)))) +(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" (&/|list)))) +(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" (&/|list)))) +(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ (&/|list)))) +(def $Void (Named$ (&/T "lux" "Void") (Variant$ (&/|list)))) (def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO @@ -90,7 +90,7 @@ (App$ (Univ$ empty-env (Variant$ (&/|list ;; DataT - Text + (Tuple$ (&/|list Text TypeList)) ;; VariantT TypeList ;; TupleT @@ -221,11 +221,11 @@ (Tuple$ (&/|list ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter") + (Data$ "org.objectweb.asm.ClassWriter" (&/|list)) ;; "lux;loader" - (Data$ "java.lang.ClassLoader") + (Data$ "java.lang.ClassLoader" (&/|list)) ;; "lux;classes" - (Data$ "clojure.lang.Atom"))))) + (Data$ "clojure.lang.Atom" (&/|list)))))) (def DefData* (Univ$ empty-env @@ -405,9 +405,7 @@ )))) (->> state (&/get$ &/$type-vars) (&/get$ &/$mappings)))] (fn [state] - (return* (&/update$ &/$type-vars #(->> % - ;; (&/update$ &/$counter dec) - (&/set$ &/$mappings (&/|remove id mappings*))) + (return* (&/update$ &/$type-vars #(&/set$ &/$mappings (&/|remove id mappings*) %) state) nil))) state)))) @@ -418,12 +416,6 @@ _ (delete-var id)] (return output))) -(defn with-vars [amount k] - (|do [=vars (&/map% (constantly create-var) (&/|range amount)) - output (k (&/|map #(Var$ %) =vars)) - _ (&/map% delete-var (&/|reverse =vars))] - (return output))) - (defn clean* [?tid type] (|case type (&/$VarT ?id) @@ -486,8 +478,13 @@ (defn show-type [^objects type] (|case type - (&/$DataT name) - (str "(^ " name ")") + (&/$DataT name params) + (|case params + (&/$Nil) + (str "(^ " name ")") + + _ + (str "(^ " name " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) (&/$TupleT elems) (if (&/|empty? elems) @@ -535,8 +532,10 @@ (and (= ?xmodule ?ymodule) (= ?xname ?yname)) - [(&/$DataT xname) (&/$DataT yname)] - (.equals ^Object xname yname) + [(&/$DataT xname xparams) (&/$DataT yname yparams)] + (and (.equals ^Object xname yname) + (= (&/|length xparams) (&/|length yparams)) + (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) [(&/$TupleT xelems) (&/$TupleT yelems)] (&/fold2 (fn [old x y] (and old (type= x y))) @@ -677,7 +676,7 @@ (def ^:private init-fixpoints (&/|list)) -(defn ^:private check* [class-loader fixpoints expected actual] +(defn ^:private check* [class-loader fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) (return (&/T fixpoints nil)) (|case [expected actual] @@ -704,13 +703,13 @@ (return (&/T fixpoints nil))) [(&/$Some etype) (&/$None _)] - (check* class-loader fixpoints etype actual) + (check* class-loader fixpoints invariant?? etype actual) [(&/$None _) (&/$Some atype)] - (check* class-loader fixpoints expected atype) + (check* class-loader fixpoints invariant?? expected atype) [(&/$Some etype) (&/$Some atype)] - (check* class-loader fixpoints etype atype)))) + (check* class-loader fixpoints invariant?? etype atype)))) [(&/$VarT ?id) _] (fn [state] @@ -720,7 +719,7 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints bound actual)) + (check* class-loader fixpoints invariant?? bound actual)) state))) [_ (&/$VarT ?id)] @@ -731,12 +730,12 @@ (&/$Left _) ((|do [bound (deref ?id)] - (check* class-loader fixpoints expected bound)) + (check* class-loader fixpoints invariant?? expected bound)) state))) [(&/$AppT (&/$ExT eid) eA) (&/$AppT (&/$ExT aid) aA)] (if (= eid aid) - (check* class-loader fixpoints eA aA) + (check* class-loader fixpoints invariant?? eA aA) (fail (check-error expected actual))) ;; [(&/$AppT (&/$VarT ?eid) A1) (&/$AppT (&/$VarT ?aid) A2)] @@ -744,13 +743,13 @@ ;; (|case ((|do [F1 (deref ?eid)] ;; (fn [state] ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints (App$ F1 A1) (App$ F2 A2))) + ;; (check* class-loader fixpoints invariant?? (App$ F1 A1) (App$ F2 A2))) ;; state) ;; (&/$Right state* output) ;; (return* state* output) ;; (&/$Left _) - ;; ((check* class-loader fixpoints (App$ F1 A1) actual) + ;; ((check* class-loader fixpoints invariant?? (App$ F1 A1) actual) ;; state)))) ;; state) ;; (&/$Right state* output) @@ -758,70 +757,70 @@ ;; (&/$Left _) ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints expected (App$ F2 A2))) + ;; (check* class-loader fixpoints invariant?? 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)] + ;; ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) + ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? A1 A2)] ;; (return (&/T fixpoints** nil))) ;; state)))) - ;; (|do [_ (check* class-loader fixpoints (Var$ ?eid) (Var$ ?aid)) - ;; _ (check* class-loader fixpoints A1 A2)] + ;; (|do [_ (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) + ;; _ (check* class-loader fixpoints invariant?? A1 A2)] ;; (return (&/T fixpoints nil))) [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] - (check* class-loader fixpoints (App$ F1 A1) actual)) + (check* class-loader fixpoints invariant?? (App$ F1 A1) actual)) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) e* (apply-type F2 A1) a* (apply-type F2 A2) - [fixpoints** _] (check* class-loader fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints (Var$ ?id) F2) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) ;; e* (apply-type F2 A1) ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] ;; (return (&/T fixpoints** nil))) [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] - (check* class-loader fixpoints expected (App$ F2 A2))) + (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) state) (&/$Right state* output) (return* state* output) (&/$Left _) - ((|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) + ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) e* (apply-type F1 A1) a* (apply-type F1 A2) - [fixpoints** _] (check* class-loader fixpoints* e* a*)] + [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] (return (&/T fixpoints** nil))) state))) ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints F1 (Var$ ?id)) + ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) ;; e* (apply-type F1 A1) ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* e* a*)] + ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? 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)) + ;; (|do [_ (check* class-loader fixpoints invariant?? eF aF)] + ;; (check* class-loader fixpoints invariant?? eA aA)) [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) @@ -842,44 +841,51 @@ (&/$None) (|do [expected* (apply-type F A)] - (check* class-loader (fp-put fp-pair true fixpoints) expected* actual)))) + (check* class-loader (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) [_ (&/$AppT F A)] (|do [actual* (apply-type F A)] - (check* class-loader fixpoints expected actual*)) + (check* class-loader fixpoints invariant?? expected actual*)) [(&/$UnivQ _) _] (with-var (fn [$arg] (|do [expected* (apply-type expected $arg)] - (check* class-loader fixpoints expected* actual)))) + (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$UnivQ _)] (with-var (fn [$arg] (|do [actual* (apply-type actual $arg)] - (check* class-loader fixpoints expected actual*)))) + (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name) (&/$DataT "null")] + [(&/$DataT e!name e!params) (&/$DataT "null" (&/$Nil))] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) - [(&/$DataT e!name) (&/$DataT a!name)] + [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] (let [e!name (as-obj e!name) a!name (as-obj a!name)] - (if (or (.equals ^Object e!name a!name) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) - (return (&/T fixpoints nil)) - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) + (cond (and (.equals ^Object e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + (return (&/T fixpoints nil))) + + (and (not invariant??) + (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (return (&/T fixpoints nil)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] - (|do [[fixpoints* _] (check* class-loader fixpoints aI eI)] - (check* class-loader fixpoints* eO aO)) + (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] + (check* class-loader fixpoints* invariant?? eO aO)) [(&/$TupleT e!members) (&/$TupleT a!members)] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] + (|do [[fp* _] (check* class-loader fp invariant?? e a)] (return fp*))) fixpoints e!members a!members)] @@ -887,7 +893,7 @@ [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e a] - (|do [[fp* _] (check* class-loader fp e a)] + (|do [[fp* _] (check* class-loader fp invariant?? e a)] (return fp*))) fixpoints e!cases a!cases)] @@ -899,10 +905,10 @@ (fail (check-error expected actual))) [(&/$NamedT ?ename ?etype) _] - (check* class-loader fixpoints ?etype actual) + (check* class-loader fixpoints invariant?? ?etype actual) [_ (&/$NamedT ?aname ?atype)] - (check* class-loader fixpoints expected ?atype) + (check* class-loader fixpoints invariant?? expected ?atype) [_ _] (fail (check-error expected actual)) @@ -910,29 +916,9 @@ (defn check [expected actual] (|do [class-loader &/loader - _ (check* class-loader init-fixpoints expected actual)] + _ (check* class-loader init-fixpoints false expected actual)] (return nil))) -(defn apply-lambda [func param] - (|case func - (&/$LambdaT input output) - (|do [_ (check* init-fixpoints input param)] - (return output)) - - (&/$UnivQ _) - (with-var - (fn [$var] - (|do [func* (apply-type func $var) - =return (apply-lambda func* param)] - (clean $var =return)))) - - (&/$NamedT ?name ?type) - (apply-lambda ?type param) - - _ - (fail (str "[Type System] Not a function type:\n" (show-type func) "\n")) - )) - (defn actual-type [type] "(-> Type (Lux Type))" (|case type -- cgit v1.2.3 From 3c1e63b8ea119601f6ba2c9eb709877c76683a8c Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 17:28:30 -0400 Subject: - Added full support for arrays. --- src/lux/analyser.clj | 97 +++++++++++++++++++++++++++++++++++++++-------- src/lux/analyser/base.clj | 33 ++++++++++++++-- src/lux/analyser/host.clj | 64 +++++++++++++++++++++++++------ src/lux/compiler.clj | 87 +++++++++++++++++++++++++++++++++++++++--- src/lux/compiler/base.clj | 37 ++++++++---------- src/lux/compiler/host.clj | 59 +++++++++++++++++++++++++--- 6 files changed, 314 insertions(+), 63 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a9689a9d0..bd0957bdf 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -63,24 +63,89 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_new-array")] - (&/$Cons [_ (&/$SymbolS _ ?class)] - (&/$Cons [_ (&/$IntS ?length)] - (&/$Nil))))) - (&&host/analyse-jvm-new-array analyse ?class ?length) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil)))) + (&&host/analyse-jvm-znewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] - (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] - (&/$Cons ?elem - (&/$Nil)))))) - (&&host/analyse-jvm-aastore analyse ?array ?idx ?elem) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-zaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] - (&/$Cons ?array - (&/$Cons [_ (&/$IntS ?idx)] - (&/$Nil))))) - (&&host/analyse-jvm-aaload analyse ?array ?idx) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-bnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-baload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-snewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-saload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-inewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-iaload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-lnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-laload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-fnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-faload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-dnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-daload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-cnewarray analyse ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&&host/analyse-jvm-caload analyse ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&&host/analyse-jvm-anewarray analyse ?class ?length) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil))))))) + (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil)))))) + (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) + (&&host/analyse-jvm-arraylength analyse ?array) ;; Classes & interfaces (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 0bb40c71b..8df7f23b2 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -39,9 +39,6 @@ "jvm-null?" "jvm-null" "jvm-new" - "jvm-new-array" - "jvm-aastore" - "jvm-aaload" "jvm-class" "jvm-interface" "jvm-try" @@ -50,6 +47,36 @@ "jvm-monitorexit" "jvm-program" + + "jvm-znewarray" + "jvm-zastore" + "jvm-zaload" + "jvm-bnewarray" + "jvm-bastore" + "jvm-baload" + "jvm-snewarray" + "jvm-sastore" + "jvm-saload" + "jvm-inewarray" + "jvm-iastore" + "jvm-iaload" + "jvm-lnewarray" + "jvm-lastore" + "jvm-laload" + "jvm-fnewarray" + "jvm-fastore" + "jvm-faload" + "jvm-dnewarray" + "jvm-dastore" + "jvm-daload" + "jvm-cnewarray" + "jvm-castore" + "jvm-caload" + "jvm-anewarray" + "jvm-aastore" + "jvm-aaload" + "jvm-arraylength" + "jvm-iadd" "jvm-isub" "jvm-imul" diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 610f3c660..4fbd67fdb 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -226,18 +226,58 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) -(defn analyse-jvm-new-array [analyse ?class ?length] - (return (&/|list (&/T (&/V &&/$jvm-new-array (&/T ?class ?length)) (&/V "array" (&/T (&type/Data$ ?class (&/|list)) - (&/V &/$Nil nil))))))) - -(defn analyse-jvm-aastore [analyse ?array ?idx ?elem] - (|do [=array (analyse-1+ analyse ?array) - =elem (analyse-1+ analyse ?elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T =array ?idx =elem)) (&&/expr-type* =array)))))) - -(defn analyse-jvm-aaload [analyse ?array ?idx] - (|do [=array (analyse-1+ analyse ?array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T =array ?idx)) (&&/expr-type* =array)))))) +(do-template [ ] + (let [elem-type (&type/Data$ (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (defn [analyse length] + (return (&/|list (&/T (&/V length) array-type)))) + + (defn [analyse array idx] + (|do [=array (&&/analyse-1 analyse array-type array)] + (return (&/|list (&/T (&/V (&/T =array idx)) elem-type))))) + + (defn [analyse array idx elem] + (|do [=array (&&/analyse-1 analyse array-type array) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V (&/T =array idx =elem)) array-type))))) + ) + + "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore + "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore + "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore + "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore + "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore + "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore + "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore + "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore + ) + +(defn analyse-jvm-anewarray [analyse class length] + (let [elem-type (&type/Data$ class (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) + +(defn analyse-jvm-aaload [analyse class array idx] + (let [elem-type (&type/Data$ class (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) + +(defn analyse-jvm-aastore [analyse class array idx elem] + (let [elem-type (&type/Data$ class (&/|list)) + array-type (&type/Data$ "Array" (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) + +(let [length-type (&type/Data$ "java.lang.Long" (&/|list))] + (defn analyse-jvm-arraylength [analyse array] + (&type/with-var + (fn [$var] + (let [elem-type $var + array-type (&type/Data$ "Array" (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array)] + (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index da9896bd5..759fc98fc 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -223,14 +223,89 @@ (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args) (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - (&a/$jvm-new-array ?class ?length) - (&&host/compile-jvm-new-array compile-expression ?type ?class ?length) + (&a/$jvm-znewarray ?length) + (&&host/compile-jvm-znewarray compile-expression ?type ?length) - (&a/$jvm-aastore ?array ?idx ?elem) - (&&host/compile-jvm-aastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-zastore ?array ?idx ?elem) + (&&host/compile-jvm-zastore compile-expression ?type ?array ?idx ?elem) - (&a/$jvm-aaload ?array ?idx) - (&&host/compile-jvm-aaload compile-expression ?type ?array ?idx) + (&a/$jvm-zaload ?array ?idx) + (&&host/compile-jvm-zaload compile-expression ?type ?array ?idx) + + (&a/$jvm-bnewarray ?length) + (&&host/compile-jvm-bnewarray compile-expression ?type ?length) + + (&a/$jvm-bastore ?array ?idx ?elem) + (&&host/compile-jvm-bastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-baload ?array ?idx) + (&&host/compile-jvm-baload compile-expression ?type ?array ?idx) + + (&a/$jvm-snewarray ?length) + (&&host/compile-jvm-snewarray compile-expression ?type ?length) + + (&a/$jvm-sastore ?array ?idx ?elem) + (&&host/compile-jvm-sastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-saload ?array ?idx) + (&&host/compile-jvm-saload compile-expression ?type ?array ?idx) + + (&a/$jvm-inewarray ?length) + (&&host/compile-jvm-inewarray compile-expression ?type ?length) + + (&a/$jvm-iastore ?array ?idx ?elem) + (&&host/compile-jvm-iastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-iaload ?array ?idx) + (&&host/compile-jvm-iaload compile-expression ?type ?array ?idx) + + (&a/$jvm-lnewarray ?length) + (&&host/compile-jvm-lnewarray compile-expression ?type ?length) + + (&a/$jvm-lastore ?array ?idx ?elem) + (&&host/compile-jvm-lastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-laload ?array ?idx) + (&&host/compile-jvm-laload compile-expression ?type ?array ?idx) + + (&a/$jvm-fnewarray ?length) + (&&host/compile-jvm-fnewarray compile-expression ?type ?length) + + (&a/$jvm-fastore ?array ?idx ?elem) + (&&host/compile-jvm-fastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-faload ?array ?idx) + (&&host/compile-jvm-faload compile-expression ?type ?array ?idx) + + (&a/$jvm-dnewarray ?length) + (&&host/compile-jvm-dnewarray compile-expression ?type ?length) + + (&a/$jvm-dastore ?array ?idx ?elem) + (&&host/compile-jvm-dastore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-daload ?array ?idx) + (&&host/compile-jvm-daload compile-expression ?type ?array ?idx) + + (&a/$jvm-cnewarray ?length) + (&&host/compile-jvm-cnewarray compile-expression ?type ?length) + + (&a/$jvm-castore ?array ?idx ?elem) + (&&host/compile-jvm-castore compile-expression ?type ?array ?idx ?elem) + + (&a/$jvm-caload ?array ?idx) + (&&host/compile-jvm-caload compile-expression ?type ?array ?idx) + + (&a/$jvm-anewarray ?class ?length) + (&&host/compile-jvm-anewarray compile-expression ?type ?class ?length) + + (&a/$jvm-aastore ?class ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?type ?class ?array ?idx ?elem) + + (&a/$jvm-aaload ?class ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?type ?class ?array ?idx) + + (&a/$jvm-arraylength ?array) + (&&host/compile-jvm-arraylength compile-expression ?type ?array) (&a/$jvm-try ?body ?catches ?finally) (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) diff --git a/src/lux/compiler/base.clj b/src/lux/compiler/base.clj index 7c1297aad..7825bef94 100644 --- a/src/lux/compiler/base.clj +++ b/src/lux/compiler/base.clj @@ -76,26 +76,21 @@ _ (load-class! loader real-name)]] (return nil))) -(do-template [ ] - (defn [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str (&host/->type-signature )))) - ;; (doto writer - ;; ;; X - ;; (.visitTypeInsn Opcodes/NEW ) ;; XW - ;; (.visitInsn ) ;; WXW - ;; (.visitInsn ) ;; WWXW - ;; (.visitInsn Opcodes/POP) ;; WWX - ;; (.visitMethodInsn Opcodes/INVOKESPECIAL "" ) ;; W - ;; ) - ) +(do-template [ ] + (do (defn [^MethodVisitor writer] + (doto writer + (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host/->type-signature ))))) + (defn [^MethodVisitor writer] + (doto writer + (.visitTypeInsn Opcodes/CHECKCAST ) + (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) - wrap-boolean "java/lang/Boolean" "(Z)" Opcodes/DUP_X1 - wrap-byte "java/lang/Byte" "(B)" Opcodes/DUP_X1 - wrap-short "java/lang/Short" "(S)" Opcodes/DUP_X1 - wrap-int "java/lang/Integer" "(I)" Opcodes/DUP_X1 - wrap-long "java/lang/Long" "(J)" Opcodes/DUP_X2 - wrap-float "java/lang/Float" "(F)" Opcodes/DUP_X1 - wrap-double "java/lang/Double" "(D)" Opcodes/DUP_X2 - wrap-char "java/lang/Character" "(C)" Opcodes/DUP_X1 + wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 + wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 + wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 + wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 + wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 + wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 + wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 + wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 ) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index db54af8ac..83c769b4b 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -287,14 +287,62 @@ (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] (return nil))) -(defn compile-jvm-new-array [compile *type* ?class ?length] +(do-template [ ] + (do (defn [compile *type* ?length] + (|do [^MethodVisitor *writer* &/get-writer + :let [_ (doto *writer* + (.visitLdcInsn (int ?length)) + (.visitIntInsn Opcodes/NEWARRAY ))]] + (return nil))) + + (defn [compile *type* ?array ?idx] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitLdcInsn (int ?idx)) + (.visitInsn ) + )]] + (return nil))) + + (defn [compile *type* ?array ?idx ?elem] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitInsn Opcodes/DUP) + (.visitLdcInsn (int ?idx)))] + _ (compile ?elem) + :let [_ (doto *writer* + + (.visitInsn ))]] + (return nil))) + ) + + Opcodes/T_BOOLEAN compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean + Opcodes/T_BYTE compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte + Opcodes/T_SHORT compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short + Opcodes/T_INT compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int + Opcodes/T_LONG compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long + Opcodes/T_FLOAT compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float + Opcodes/T_DOUBLE compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double + Opcodes/T_CHAR compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char + ) + +(defn compile-jvm-anewarray [compile *type* ?class ?length] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int ?length)) (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] (return nil))) -(defn compile-jvm-aastore [compile *type* ?array ?idx ?elem] +(defn compile-jvm-aaload [compile *type* ?class ?array ?idx] + (|do [^MethodVisitor *writer* &/get-writer + _ (compile ?array) + :let [_ (doto *writer* + (.visitLdcInsn (int ?idx)) + (.visitInsn Opcodes/AALOAD))]] + (return nil))) + +(defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* @@ -304,12 +352,13 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-jvm-aaload [compile *type* ?array ?idx] +(defn compile-jvm-arraylength [compile *type* ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + (.visitInsn Opcodes/ARRAYLENGTH) + (.visitInsn Opcodes/I2L) + &&/wrap-long)]] (return nil))) (defn compile-jvm-getstatic [compile *type* ?class ?field] -- cgit v1.2.3 From 1e5f1afbd0f8b54350e552c110dead87b4b5dca0 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 18:31:29 -0400 Subject: - Fixed some errors with JVM interop. --- src/lux/analyser.clj | 29 ++++++--- src/lux/analyser/host.clj | 156 +++++++++++++++++++++++----------------------- src/lux/host.clj | 43 ++++++++----- 3 files changed, 128 insertions(+), 100 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index bd0957bdf..e1c167ce6 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -43,6 +43,14 @@ _ (fail (str "[Analyser Error] Not a tag: " (&/show-ast ast))))) +(defn ^:private extract-text [ast] + (|case ast + [_ (&/$TextS text)] + (return text) + + _ + (fail (str "[Analyser Error] Can't extract text: " (&/show-ast ast))))) + (defn analyse-variant+ [analyser exo-type ident values] (|do [[module tag-name] (&/normalize ident) idx (&&module/tag-index module tag-name)] @@ -155,13 +163,15 @@ (&/$Cons [_ (&/$TupleS ?fields)] (&/$Cons [_ (&/$TupleS ?methods)] (&/$Nil)))))))) - (&&host/analyse-jvm-class analyse compile-token ?name ?super-class ?interfaces ?fields ?methods) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?fields ?methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TupleS ?supers)] ?methods)))) - (&&host/analyse-jvm-interface analyse compile-token ?name ?supers ?methods) + (|do [=supers (&/map% extract-text ?supers)] + (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] @@ -280,7 +290,8 @@ (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))) - (&&host/analyse-jvm-new analyse exo-type ?class ?classes ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-new analyse exo-type ?class =classes ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_getstatic")] (&/$Cons [_ (&/$TextS ?class)] @@ -316,7 +327,8 @@ (&/$Cons [_ (&/$TupleS ?classes)] (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil))))))) - (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method ?classes ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokestatic analyse exo-type ?class ?method =classes ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokevirtual")] (&/$Cons [_ (&/$TextS ?class)] @@ -325,7 +337,8 @@ (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method ?classes ?object ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokevirtual analyse exo-type ?class ?method =classes ?object ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokeinterface")] (&/$Cons [_ (&/$TextS ?class)] @@ -334,7 +347,8 @@ (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method ?classes ?object ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokeinterface analyse exo-type ?class ?method =classes ?object ?args)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokespecial")] (&/$Cons [_ (&/$TextS ?class)] @@ -343,7 +357,8 @@ (&/$Cons ?object (&/$Cons [_ (&/$TupleS ?args)] (&/$Nil)))))))) - (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method ?classes ?object ?args) + (|do [=classes (&/map% extract-text ?classes)] + (&&host/analyse-jvm-invokespecial analyse exo-type ?class ?method =classes ?object ?args)) ;; Exceptions (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 4fbd67fdb..69e1ff47a 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -15,21 +15,21 @@ [env :as &&env]))) ;; [Utils] -(defn ^:private extract-text [text] - (|case text - [_ (&/$TextS ?text)] - (return ?text) +(defn ^:private extract-text [ast] + (|case ast + [_ (&/$TextS text)] + (return text) _ - (fail "[Analyser Error] Can't extract Text."))) + (fail "[Analyser/Host Error] Can't extract text."))) -(defn ^:private analyse-1+ [analyse ?token] +(defn ^:private analyse-1+ [analyse token] (&type/with-var (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] - =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (|do [=expr (&&/analyse-1 analyse $var token) + :let [[item type] =expr] + =type (&type/clean $var type)] + (return (&/T item =type)))))) (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" @@ -76,9 +76,9 @@ (do-template [ ] (let [input-type (&type/Data$ (&/|list)) output-type (&type/Data$ (&/|list))] - (defn [analyse exo-type ?x ?y] - (|do [=x (&&/analyse-1 analyse input-type ?x) - =y (&&/analyse-1 analyse input-type ?y) + (defn [analyse exo-type x y] + (|do [=x (&&/analyse-1 analyse input-type x) + =y (&&/analyse-1 analyse input-type y) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) @@ -123,92 +123,89 @@ analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) -(defn analyse-jvm-getstatic [analyse exo-type ?class ?field] +(defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) + =type (&host/lookup-static-field class-loader class field) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T ?class ?field)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T class field)) output-type))))) -(defn analyse-jvm-getfield [analyse exo-type ?class ?field ?object] +(defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =object (&&/analyse-1 analyse ?object) + =type (&host/lookup-static-field class-loader class field) + =object (&&/analyse-1 analyse object) :let [output-type =type] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T ?class ?field =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T class field =object)) output-type))))) -(defn analyse-jvm-putstatic [analyse exo-type ?class ?field ?value] +(defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =value (&&/analyse-1 analyse =type ?value) + =type (&host/lookup-static-field class-loader class field) + =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T ?class ?field =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T class field =value)) output-type))))) -(defn analyse-jvm-putfield [analyse exo-type ?class ?field ?object ?value] +(defn analyse-jvm-putfield [analyse exo-type class field object value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader ?class ?field) - =object (&&/analyse-1 analyse ?object) - =value (&&/analyse-1 analyse =type ?value) + =type (&host/lookup-static-field class-loader class field) + =object (&&/analyse-1 analyse object) + =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T ?class ?field =object =value)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T class field =object =value)) output-type))))) -(defn analyse-jvm-invokestatic [analyse exo-type ?class ?method ?classes ?args] +(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (&host/lookup-static-method class-loader ?class ?method =classes) + =return (&host/lookup-static-method class-loader class method classes) ;; :let [_ (matchv ::M/objects [=return] ;; [[&/$DataT _return-class (&/|list)]] - ;; (prn 'analyse-jvm-invokestatic ?class ?method _return-class))] + ;; (prn 'analyse-jvm-invokestatic class method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&type/Data$ _class (&/|list)) _arg)) - =classes - ?args) + classes + args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T ?class ?method =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) -(defn analyse-jvm-instanceof [analyse exo-type ?class ?object] - (|do [=object (analyse-1+ analyse ?object) +(defn analyse-jvm-instanceof [analyse exo-type class object] + (|do [=object (analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T ?class =object)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T class =object)) output-type))))) (do-template [ ] - (defn [analyse exo-type ?class ?method ?classes ?object ?args] + (defn [analyse exo-type class method classes object args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (&host/lookup-virtual-method class-loader ?class ?method =classes) - =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) - =args (&/map2% (fn [?c ?o] (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) - =classes ?args) + =return (&host/lookup-virtual-method class-loader class method classes) + =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + classes args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V (&/T class method classes =object =args)) output-type))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface ) -(defn analyse-jvm-invokespecial [analyse exo-type ?class ?method ?classes ?object ?args] +(defn analyse-jvm-invokespecial [analyse exo-type class method classes object args] (|do [class-loader &/loader - =classes (&/map% extract-text ?classes) - =return (if (= "" ?method) + =return (if (= "" method) (return &type/Unit) - (&host/lookup-virtual-method class-loader ?class ?method =classes)) - =object (&&/analyse-1 analyse (&type/Data$ ?class (&/|list)) ?object) - =args (&/map2% (fn [?c ?o] - (&&/analyse-1 analyse (&type/Data$ ?c (&/|list)) ?o)) - =classes ?args) + (&host/lookup-virtual-method class-loader class method classes)) + =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) + =args (&/map2% (fn [c o] + (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + classes args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T ?class ?method =classes =object =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) -(defn analyse-jvm-null? [analyse exo-type ?object] - (|do [=object (analyse-1+ analyse ?object) +(defn analyse-jvm-null? [analyse exo-type object] + (|do [=object (analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] @@ -219,12 +216,14 @@ _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) -(defn analyse-jvm-new [analyse exo-type ?class ?classes ?args] - (|do [=classes (&/map% extract-text ?classes) - =args (&/map% (partial analyse-1+ analyse) ?args) - :let [output-type (&type/Data$ ?class (&/|list))] +(defn analyse-jvm-new [analyse exo-type class classes args] + (|do [class-loader &/loader + =return (&host/lookup-constructor class-loader class classes) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + classes args) + :let [output-type (&type/Data$ class (&/|list))] _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T ?class =classes =args)) output-type))))) + (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) (do-template [ ] (let [elem-type (&type/Data$ (&/|list)) @@ -316,8 +315,7 @@ modifiers)) (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [=interfaces (&/map% extract-text ?interfaces) - =fields (&/map% (fn [?field] + (|do [=fields (&/map% (fn [?field] (|case ?field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] (&/$Cons [_ (&/$TextS ?field-type)] @@ -360,7 +358,7 @@ (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) (&/|list)) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs - (&/Cons$ (&/T ";this" ?super-class) + (&/Cons$ (&/T "this" ?super-class) =method-inputs)))))] (return {:name ?method-name :modifiers =method-modifiers @@ -371,29 +369,29 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class =interfaces =fields =methods)))] + _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) + :let [_ (prn 'analyse-jvm-class ?name ?super-class)]] (return (&/|list)))) -(defn analyse-jvm-interface [analyse compile-token ?name ?supers ?methods] - (|do [=supers (&/map% extract-text ?supers) - =methods (&/map% (fn [method] +(defn analyse-jvm-interface [analyse compile-token name supers methods] + (|do [=methods (&/map% (fn [method] (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?inputs)] - (&/$Cons [_ (&/$TextS ?output)] - (&/$Cons [_ (&/$TupleS ?modifiers)] + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Cons [_ (&/$TupleS modifiers)] (&/$Nil))))))] - (|do [=inputs (&/map% extract-text ?inputs) - =modifiers (analyse-modifiers ?modifiers)] - (return {:name ?method-name + (|do [=inputs (&/map% extract-text inputs) + =modifiers (analyse-modifiers modifiers)] + (return {:name method-name :modifiers =modifiers :inputs =inputs - :output ?output})) + :output output})) _ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - ?methods) - _ (compile-token (&/V &&/$jvm-interface (&/T ?name =supers =methods)))] + methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] (return (&/|list)))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] diff --git a/src/lux/host.clj b/src/lux/host.clj index 0936d90eb..81323b1d8 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -10,7 +10,7 @@ clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) - (:import (java.lang.reflect Field Method Modifier) + (:import (java.lang.reflect Field Method Constructor Modifier) java.util.regex.Pattern)) ;; [Constants] @@ -22,19 +22,21 @@ ;; [Utils] (defn ^:private class->type [^Class class] + "(-> Class Type)" (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" (str (if-let [pkg (.getPackage class)] (str (.getName pkg) ".") "") (.getSimpleName class)))] (if (.equals "void" base) - (return &type/Unit) - (return (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base) - (&/|list))) + &type/Unit + (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) + base) + (&/|list)) ))) (defn ^:private method->type [^Method method] + "(-> Method Type)" (class->type (.getReturnType method))) ;; [Resources] @@ -93,9 +95,8 @@ :when (and (.equals ^Object field (.getName =field)) (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] - (|do [=type (class->type type*)] - (return =type)) - (fail (str "[Analyser Error] Field does not exist: " target "." field)))) + (return (class->type type*)) + (fail (str "[Host Error] Field does not exist: " target "." field)))) lookup-static-field true lookup-field false @@ -107,17 +108,31 @@ (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object (Modifier/isStatic (.getModifiers =method))) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))] + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] =method))] - (method->type method) - (fail (str "[Analyser Error] Method does not exist: " target "." method-name)))) + (return (method->type method)) + (fail (str "[Host Error] Method does not exist: " target "." method-name)))) lookup-static-method true lookup-virtual-method false ) +(defn lookup-constructor [class-loader target args] + (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (return &type/Unit) + (fail (str "[Host Error] Constructor does not exist: " target)))) + (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) -- cgit v1.2.3 From 45a102bae3707d1a5220d7e124221ed46882f22d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 19:00:56 -0400 Subject: - Added exhaustiveness testing for class definition. --- src/lux/analyser/host.clj | 29 +++++++++++++++++++++++++++-- src/lux/host.clj | 5 +++++ 2 files changed, 32 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 69e1ff47a..0eb89b251 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -315,7 +315,9 @@ modifiers)) (defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [=fields (&/map% (fn [?field] + (|do [class-loader &/loader + abstract-methods (&/flat-map% (partial &host/abstract-methods class-loader) (&/Cons$ ?super-class ?interfaces)) + =fields (&/map% (fn [?field] (|case ?field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] (&/$Cons [_ (&/$TextS ?field-type)] @@ -369,8 +371,31 @@ _ (fail "[Analyser Error] Wrong syntax for method."))) (&/enumerate ?methods)) + ;; Test for method completion + :let [methods-map (&/fold (fn [mmap mentry] + (assoc mmap (:name mentry) mentry)) + {} + =methods) + missing-method (&/fold (fn [missing abs-meth] + (|let [[am-name am-inputs] abs-meth] + (or missing + (if-let [meth-struct (get methods-map am-name)] + (let [meth-inputs (:inputs meth-struct)] + (if (and (= (&/|length meth-inputs) (&/|length am-inputs)) + (&/fold2 (fn [prev mi ai] (and prev (= mi ai))) + true + meth-inputs am-inputs)) + nil + am-name)) + am-name)))) + nil + abstract-methods)] + _ (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))) _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) - :let [_ (prn 'analyse-jvm-class ?name ?super-class)]] + ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] + ] (return (&/|list)))) (defn analyse-jvm-interface [analyse compile-token name supers methods] diff --git a/src/lux/host.clj b/src/lux/host.clj index 81323b1d8..8d6135d64 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -134,5 +134,10 @@ (return &type/Unit) (fail (str "[Host Error] Constructor does not exist: " target)))) +(defn abstract-methods [class-loader class] + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj class) true class-loader)) + :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] + (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) + (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) -- cgit v1.2.3 From c9560da3760d0d277a715a966496451020f3f2f8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 12 Sep 2015 22:36:34 -0400 Subject: - Added exhaustiveness testing for exception-handling code. - Added some optimizations for using List & Maybe within the compiler. --- src/lux/analyser.clj | 4 +- src/lux/analyser/case.clj | 8 +-- src/lux/analyser/host.clj | 135 +++++++++++++++++++++++++++++++------------- src/lux/analyser/lux.clj | 26 ++++----- src/lux/analyser/module.clj | 2 +- src/lux/analyser/record.clj | 2 +- src/lux/base.clj | 53 ++++++++++------- src/lux/compiler/cache.clj | 6 +- src/lux/compiler/type.clj | 2 +- src/lux/host.clj | 4 +- src/lux/parser.clj | 8 +-- src/lux/type.clj | 45 ++++++++------- 12 files changed, 186 insertions(+), 109 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index e1c167ce6..03709b226 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -364,7 +364,7 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_try")] (&/$Cons ?body ?handlers))) - (|do [catches+finally (&/fold% parse-handler (&/T (&/|list) (&/V &/$None nil)) ?handlers)] + (|do [catches+finally (&/fold% parse-handler (&/T &/Nil$ &/None$) ?handlers)] (&&host/analyse-jvm-try analyse exo-type ?body catches+finally)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_throw")] @@ -602,7 +602,7 @@ (&&lux/analyse-record analyse exo-type ?elems) (&/$TagS ?ident) - (analyse-variant+ analyse exo-type ?ident (&/|list)) + (analyse-variant+ analyse exo-type ?ident &/Nil$) (&/$SymbolS _ "_jvm_null") (&&host/analyse-jvm-null analyse exo-type) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index a0f07cdce..109ba7c41 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -39,7 +39,7 @@ ;; [Utils] (def ^:private unit - (&/T (&/T "" -1 -1) (&/V &/$TupleS (&/|list)))) + (&/T (&/T "" -1 -1) (&/V &/$TupleS &/Nil$))) (defn ^:private resolve-type [type] (|case type @@ -118,7 +118,7 @@ (defn adjust-type [type] "(-> Type (Lux Type))" - (adjust-type* (&/|list) type)) + (adjust-type* &/Nil$ type)) (defn ^:private analyse-pattern [value-type pattern kont] (|let [[meta pattern*] pattern] @@ -170,7 +170,7 @@ (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] (return (&/T (&/Cons$ =test =tests) =kont))))) (|do [=kont kont] - (return (&/T (&/|list) =kont))) + (return (&/T &/Nil$ =kont))) (&/|reverse (&/zip2 ?member-types ?members)))] (return (&/T (&/V $TupleTestAC =tests) =kont))))) @@ -392,7 +392,7 @@ (|do [patterns (&/fold% (fn [patterns branch] (|let [[pattern body] branch] (analyse-branch analyse exo-type value-type pattern body patterns))) - (&/|list) + &/Nil$ branches) struct (&/fold% merge-total (&/V $DefaultTotal false) patterns) ? (check-totality value-type struct)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 0eb89b251..db04a60c0 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -23,6 +23,48 @@ _ (fail "[Analyser/Host Error] Can't extract text."))) +(defn ^:private ensure-catching [exceptions] + "(-> (List Text) (Lux (,)))" + (|do [class-loader &/loader] + (fn [state] + (let [exceptions (&/|map #(Class/forName % true class-loader) exceptions) + catching (->> state (&/get$ &/$host) (&/get$ &/$catching) + (&/|map #(Class/forName % true class-loader)))] + (if-let [missing-ex (&/fold (fn [prev now] + (or prev + (if (&/fold (fn [found? ex-catch] + (or found? + (.isAssignableFrom ex-catch now))) + false + catching) + nil + now))) + nil + exceptions)] + (assert false (str "[Analyser Error] Unhandled exception: " missing-ex)) + ;; (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) + (&/return* state nil))) + ))) + +(defn ^:private with-catches [catches body] + "(All [a] (-> (List Text) (Lux a) (Lux a)))" + (fn [state] + (let [;; _ (prn 'with-catches/_0 (&/->seq catches)) + old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + ;; _ (prn 'with-catches/_1 (&/->seq (->> state (&/get$ &/$host) (&/get$ &/$catching)))) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %))) + ;; _ (prn 'with-catches/_2 (&/->seq (->> state* (&/get$ &/$host) (&/get$ &/$catching)))) + ] + (|case (&/run-state body state*) + (&/$Left msg) + (&/V &/$Left msg) + + (&/$Right state** output) + (do ;; (prn 'with-catches/_3 (&/->seq (->> state** (&/get$ &/$host) (&/get$ &/$catching)))) + (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output))))) + )) + (defn ^:private analyse-1+ [analyse token] (&type/with-var (fn [$var] @@ -74,8 +116,8 @@ ;; [Resources] (do-template [ ] - (let [input-type (&type/Data$ (&/|list)) - output-type (&type/Data$ (&/|list))] + (let [input-type (&type/Data$ &/Nil$) + output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type x y] (|do [=x (&&/analyse-1 analyse input-type x) =y (&&/analyse-1 analyse input-type y) @@ -157,12 +199,15 @@ (defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =return (&host/lookup-static-method class-loader class method classes) + =return+exceptions (&host/lookup-static-method class-loader class method classes) + :let [[=return exceptions] =return+exceptions] + ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] + _ (ensure-catching exceptions) ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class (&/|list)]] + ;; [[&/$DataT _return-class &/Nil$]] ;; (prn 'analyse-jvm-invokestatic class method _return-class))] =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class (&/|list)) _arg)) + (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) classes args) :let [output-type =return] @@ -179,11 +224,16 @@ (do-template [ ] (defn [analyse exo-type class method classes object args] (|do [class-loader &/loader - =return (&host/lookup-virtual-method class-loader class method classes) - =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + =return+exceptions (&host/lookup-virtual-method class-loader class method classes) + ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] + :let [[=return exceptions] =return+exceptions] + _ (ensure-catching exceptions) + =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) :let [output-type =return] + ;; :let [_ (prn ' [class method] '=return (&type/show-type =return))] + ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] _ (&type/check exo-type (as-otype+ output-type))] (return (&/|list (&/T (&/V (&/T class method classes =object =args)) output-type))))) @@ -193,12 +243,15 @@ (defn analyse-jvm-invokespecial [analyse exo-type class method classes object args] (|do [class-loader &/loader - =return (if (= "" method) - (return &type/Unit) - (&host/lookup-virtual-method class-loader class method classes)) - =object (&&/analyse-1 analyse (&type/Data$ class (&/|list)) object) + =return+exceptions (if (= "" method) + (return (&/T &type/Unit &/Nil$)) + (&host/lookup-virtual-method class-loader class method classes)) + :let [[=return exceptions] =return+exceptions] + ;; :let [_ (prn 'analyse-jvm-invokespecial (&/adt->text =return+exceptions))] + _ (ensure-catching exceptions) + =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) =args (&/map2% (fn [c o] - (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) :let [output-type =return] _ (&type/check exo-type (as-otype+ output-type))] @@ -212,21 +265,21 @@ (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null" (&/|list))] + (|do [:let [output-type (&type/Data$ "null" &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader =return (&host/lookup-constructor class-loader class classes) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c (&/|list)) o)) + =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) - :let [output-type (&type/Data$ class (&/|list))] + :let [output-type (&type/Data$ class &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) (do-template [ ] - (let [elem-type (&type/Data$ (&/|list)) + (let [elem-type (&type/Data$ &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (defn [analyse length] (return (&/|list (&/T (&/V length) array-type)))) @@ -252,24 +305,24 @@ ) (defn analyse-jvm-anewarray [analyse class length] - (let [elem-type (&type/Data$ class (&/|list)) + (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) (defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class (&/|list)) + (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array)] (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) (defn analyse-jvm-aastore [analyse class array idx elem] - (let [elem-type (&type/Data$ class (&/|list)) + (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ "Array" (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =elem (&&/analyse-1 analyse elem-type elem)] (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) -(let [length-type (&type/Data$ "java.lang.Long" (&/|list))] +(let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] (&type/with-var (fn [$var] @@ -353,11 +406,11 @@ =method-body (&/with-scope (str ?name "_" ?idx) (&/fold (fn [body* input*] (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) (&/|list)) + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) body*))) (if (= "void" ?method-output) (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) (&/|list)) ?method-body)) + (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) &/Nil$) ?method-body)) (&/|reverse (if (:static? =method-modifiers) =method-inputs (&/Cons$ (&/T "this" ?super-class) @@ -396,7 +449,7 @@ _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] ] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-jvm-interface [analyse compile-token name supers methods] (|do [=methods (&/map% (fn [method] @@ -417,19 +470,21 @@ (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) methods) _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] - =body (&&/analyse-1 analyse exo-type ?body) =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] - (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class (&/|list)) + (|do [=catch-body (&&env/with-local ?ex-arg (&type/Data$ ?ex-class &/Nil$) (&&/analyse-1 analyse exo-type ?catch-body)) idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) + :let [catched-exceptions (&/|map #(aget % 0) =catches)] + =body (with-catches catched-exceptions + (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally - (&/$None) (return (&/V &/$None nil)) + (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) @@ -437,7 +492,7 @@ (defn analyse-jvm-throw [analyse exo-type ?ex] (|do [=ex (analyse-1+ analyse ?ex) :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable" (&/|list)) _type)] + _ (&type/check (&type/Data$ "java.lang.Throwable" &/Nil$) _type)] (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) (do-template [ ] @@ -453,9 +508,9 @@ ) (do-template [ ] - (let [output-type (&type/Data$ (&/|list))] + (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -480,9 +535,9 @@ ) (do-template [ ] - (let [output-type (&type/Data$ (&/|list))] + (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] - (|do [=value (&&/analyse-1 analyse (&type/Data$ (&/|list)) ?value) + (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V =value) output-type)))))) @@ -501,9 +556,11 @@ analyse-jvm-lushr &&/$jvm-lushr "java.lang.Long" "java.lang.Integer" ) -(defn analyse-jvm-program [analyse compile-token ?args ?body] - (|do [=body (&/with-scope "" - (&&env/with-local ?args (&/V &/$AppT (&/T &type/List &type/Text)) - (&&/analyse-1 analyse (&/V &/$AppT (&/T &type/IO &type/Unit)) ?body))) - _ (compile-token (&/V &&/$jvm-program =body))] - (return (&/|list)))) +(let [input-type (&type/App$ &type/List &type/Text) + output-type (&type/App$ &type/IO &type/Unit)] + (defn analyse-jvm-program [analyse compile-token ?args ?body] + (|do [=body (&/with-scope "" + (&&env/with-local ?args input-type + (&&/analyse-1 analyse output-type ?body))) + _ (compile-token (&/V &&/$jvm-program =body))] + (return &/Nil$)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6205adccb..4a03c4848 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -59,7 +59,7 @@ (|do [:let [=var* (next-bound-type tuple-type)] _ (&type/set-var iid =var*) tuple-type* (&type/clean $var tuple-type)] - (return (&type/Univ$ (&/|list) tuple-type*))) + (return (&type/Univ$ &/Nil$ tuple-type*))) _ (&type/clean $var tuple-type))] @@ -110,7 +110,7 @@ (|do [output (with-attempt (|case ?values (&/$Nil) - (analyse-tuple analyse (&/V &/$Right exo-type) (&/|list)) + (analyse-tuple analyse (&/V &/$Right exo-type) &/Nil$) (&/$Cons ?value (&/$Nil)) (analyse exo-type ?value) @@ -155,7 +155,7 @@ (|do [:let [=var* (next-bound-type variant-type)] _ (&type/set-var iid =var*) variant-type* (&type/clean $var variant-type)] - (return (&type/Univ$ (&/|list) variant-type*))) + (return (&type/Univ$ &/Nil$ variant-type*))) _ (&type/clean $var variant-type)) @@ -291,7 +291,7 @@ (&/T register* (&/Cons$ frame* new-inner)))) (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) - (&/|list)) + &/Nil$) (&/|reverse inner) scopes)] ((|do [_ (&type/check exo-type (&&/expr-type* =local))] (return (&/|list =local))) @@ -313,7 +313,7 @@ _ (&type/check exo-type fun-type) ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))] ] - (return (&/T fun-type (&/|list)))) + (return (&/T fun-type &/Nil$))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] @@ -416,7 +416,7 @@ _ (&type/set-var iid =input*) =output* (&type/clean $input =output) =output** (&type/clean $output =output*)] - (return (&type/Univ$ (&/|list) (embed-inferred-input =input* =output**)))) + (return (&type/Univ$ &/Nil$ (embed-inferred-input =input* =output**)))) _ (|do [=output* (&type/clean $input =output) @@ -490,7 +490,7 @@ ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] ] - (return (&/|list))) + (return &/Nil$)) _ (do ;; (println 'DEF (str module-name ";" ?name)) @@ -505,7 +505,7 @@ [def-analysis def-type] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) )]] - (return (&/|list))))) + (return &/Nil$)))) )))) (defn analyse-declare-macro [analyse compile-token ?name] @@ -515,7 +515,7 @@ _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) ;; :let [_ (prn 'analyse-declare-macro ?name "2")] ] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name @@ -524,7 +524,7 @@ ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-import [analyse compile-module compile-token path] ;; (prn 'analyse-import path) @@ -537,17 +537,17 @@ ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] _ (&&module/add-import path) _ (&/when% (not already-compiled?) (compile-module path))] - (return (&/|list)))))) + (return &/Nil$))))) (defn analyse-export [analyse compile-token name] (|do [module-name &/get-module-name _ (&&module/export module-name name)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-alias [analyse compile-token ex-alias ex-module] (|do [module-name &/get-module-name _ (&&module/alias module-name ex-alias ex-module)] - (return (&/|list)))) + (return &/Nil$))) (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 97365ba08..deb6be69e 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -27,7 +27,7 @@ ;; "lux;defs" (&/|table) ;; "lux;imports" - (&/|list) + &/Nil$ ;; "lux;tags" (&/|table) ;; "lux;types" diff --git a/src/lux/analyser/record.clj b/src/lux/analyser/record.clj index 0f860888b..ddc9616fd 100644 --- a/src/lux/analyser/record.clj +++ b/src/lux/analyser/record.clj @@ -16,7 +16,7 @@ "(-> (List (, Syntax Syntax)) (Lux (List Syntax)))" (|do [[tag-group tag-type] (|case pairs (&/$Nil) - (return (&/T (&/|list) &type/Unit)) + (return (&/T &/Nil$ &type/Unit)) (&/$Cons [[_ (&/$TagS tag1)] _] _) (|do [[module name] (&&/resolved-ident tag1) diff --git a/src/lux/base.clj b/src/lux/base.clj index c0f28f519..aefa0cf4c 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -84,7 +84,8 @@ (deftags ["writer" "loader" - "classes"]) + "classes" + "catching"]) ;; Compiler (deftags @@ -179,13 +180,13 @@ (defmacro |list [& elems] (reduce (fn [tail head] `(V $Cons (T ~head ~tail))) - `(V $Nil nil) + `Nil$ (reverse elems))) (defmacro |table [& elems] (reduce (fn [table [k v]] `(|put ~k ~v ~table)) - `(|list) + `Nil$ (reverse (partition 2 elems)))) (defn |get [slot table] @@ -201,7 +202,7 @@ (defn |put [slot value table] (|case table ($Nil) - (V $Cons (T (T slot value) (V $Nil nil))) + (V $Cons (T (T slot value) Nil$)) ($Cons [k v] table*) (if (.equals ^Object k slot) @@ -344,7 +345,7 @@ (if (p x) (|let [[pre post] (|split-with p xs*)] (T (Cons$ x pre) post)) - (T (V $Nil nil) xs)))) + (T Nil$ xs)))) (defn |contains? [k table] (|case table @@ -355,6 +356,14 @@ (or (.equals ^Object k k*) (|contains? k table*)))) +(defn |member? [x xs] + (|case xs + ($Nil) + false + + ($Cons x* xs*) + (or (= x x*) (|member? x xs*)))) + (defn fold [f init xs] (|case xs ($Nil) @@ -386,7 +395,7 @@ (let [|range* (fn |range* [from to] (if (< from to) (V $Cons (T from (|range* (inc from) to))) - (V $Nil nil)))] + Nil$))] (defn |range [n] (|range* 0 n))) @@ -404,12 +413,12 @@ (V $Cons (T (T x y) (zip2 xs* ys*))) [_ _] - (V $Nil nil))) + Nil$)) (defn |keys [plist] (|case plist ($Nil) - (|list) + Nil$ ($Cons [k v] plist*) (Cons$ k (|keys plist*)))) @@ -417,7 +426,7 @@ (defn |vals [plist] (|case plist ($Nil) - (|list) + Nil$ ($Cons [k v] plist*) (Cons$ v (|vals plist*)))) @@ -448,7 +457,7 @@ flat-map% |++) (defn list-join [xss] - (fold |++ (V $Nil nil) xss)) + (fold |++ Nil$ xss)) (defn |as-pairs [xs] (|case xs @@ -456,12 +465,12 @@ (V $Cons (T (T x y) (|as-pairs xs*))) _ - (V $Nil nil))) + Nil$)) (defn |reverse [xs] (fold (fn [tail head] (Cons$ head tail)) - (|list) + Nil$ xs)) (defn assert! [test message] @@ -497,7 +506,7 @@ (try-all% (|list (|do [head monad tail (repeat% monad)] (return (Cons$ head tail))) - (return (|list))))) + (return Nil$)))) (defn exhaust% [step] (fn [state] @@ -580,6 +589,7 @@ (try (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) (catch java.lang.reflect.InvocationTargetException e (prn 'InvocationTargetException (.getCause e)) + (prn 'memory-class-loader/findClass class-name (get @store class-name)) (throw e))) (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) @@ -591,7 +601,10 @@ ;; "lux;loader" (memory-class-loader store) ;; "lux;classes" - store))) + store + ;; "lux;catching" + Nil$ + ))) (defn init-state [_] (T ;; "lux;source" @@ -601,11 +614,11 @@ ;; "lux;modules" (|table) ;; "lux;envs" - (|list) + Nil$ ;; "lux;types" +init-bindings+ ;; "lux;expected" - (V $VariantT (|list)) + (V $VariantT Nil$) ;; "lux;seed" 0 ;; "lux;eval?" @@ -671,13 +684,13 @@ (defn ->list [seq] (if (empty? seq) - (|list) + Nil$ (Cons$ (first seq) (->list (rest seq))))) (defn |repeat [n x] (if (> n 0) (Cons$ x (|repeat (dec n) x)) - (|list))) + Nil$)) (def get-module-name (fn [state] @@ -830,7 +843,7 @@ (return (Cons$ z zs))) [($Nil) ($Nil)] - (return (V $Nil nil)) + (return Nil$) [_ _] (fail "Lists don't match in size."))) @@ -841,7 +854,7 @@ (Cons$ (f x y) (map2 f xs* ys*)) [_ _] - (V $Nil nil))) + Nil$)) (defn fold2 [f init xs ys] (|case [xs ys] diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index e47da2678..3532cf843 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -92,7 +92,7 @@ (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] (load _import (hash content) compile-module))) (if (= [""] imports) - (&/|list) + &/Nil$ (&/->list imports)))] (if (->> loads &/->seq (every? true?)) (do (doseq [^File file (seq (.listFiles (File. module-path))) @@ -109,7 +109,7 @@ ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) tag-groups (let [all-tags (get-field &/tags-field module-meta)] (if (= "" all-tags) - (&/|list) + &/Nil$ (-> all-tags (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) (->> (map (fn [_group] @@ -149,7 +149,7 @@ (return nil))) )) (if (= [""] defs) - (&/|list) + &/Nil$ (&/->list defs))) _ (&/map% (fn [group] (|let [[_type _tags] group] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 6c128df80..00e66410f 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -33,7 +33,7 @@ (def ^:private $Nil "Analysis" - (variant$ &/$Nil (tuple$ (&/|list)))) + (variant$ &/$Nil (tuple$ &/Nil$))) (defn ^:private Cons$ [head tail] "(-> Analysis Analysis Analysis)" diff --git a/src/lux/host.clj b/src/lux/host.clj index 8d6135d64..9137f3874 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -32,7 +32,7 @@ &type/Unit (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) base) - (&/|list)) + &/Nil$) ))) (defn ^:private method->type [^Method method] @@ -115,7 +115,7 @@ args (&/|map #(.getName ^Class %) param-types)))))] =method))] - (return (method->type method)) + (return (&/T (method->type method) (->> method .getExceptionTypes &/->list (&/|map #(.getName %))))) (fail (str "[Host Error] Method does not exist: " target "." method-name)))) lookup-static-method true diff --git a/src/lux/parser.clj b/src/lux/parser.clj index dbd6ca2c5..516b6a947 100644 --- a/src/lux/parser.clj +++ b/src/lux/parser.clj @@ -17,7 +17,7 @@ token &lexer/lex] (|case token [meta [ _]] - (return (&/V (&/fold &/|++ (&/|list) elems))) + (return (&/V (&/fold &/|++ &/Nil$ elems))) _ (fail (str "[Parser Error] Unbalanced " "."))))) @@ -29,7 +29,7 @@ (defn ^:private parse-record [parse] (|do [elems* (&/repeat% parse) token &lexer/lex - :let [elems (&/fold &/|++ (&/|list) elems*)]] + :let [elems (&/fold &/|++ &/Nil$ elems*)]] (|case token [meta (&lexer/$Close_Brace _)] (if (even? (&/|length elems)) @@ -45,10 +45,10 @@ :let [[meta token*] token]] (|case token* (&lexer/$White_Space _) - (return (&/|list)) + (return &/Nil$) (&lexer/$Comment _) - (return (&/|list)) + (return &/Nil$) (&lexer/$Bool ?value) (return (&/|list (&/T meta (&/V &/$BoolS (Boolean/parseBoolean ?value))))) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0da579cf4..8a1e11bed 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -23,7 +23,7 @@ _ false)) -(def ^:private empty-env (&/V &/$Nil nil)) +(def ^:private empty-env &/Nil$) (defn Data$ [name params] (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] @@ -46,13 +46,13 @@ (&/V &/$NamedT (&/T name type))) -(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" (&/|list)))) -(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" (&/|list)))) -(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" (&/|list)))) -(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" (&/|list)))) -(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" (&/|list)))) -(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ (&/|list)))) -(def $Void (Named$ (&/T "lux" "Void") (Variant$ (&/|list)))) +(def Bool (Named$ (&/T "lux" "Bool") (Data$ "java.lang.Boolean" &/Nil$))) +(def Int (Named$ (&/T "lux" "Int") (Data$ "java.lang.Long" &/Nil$))) +(def Real (Named$ (&/T "lux" "Real") (Data$ "java.lang.Double" &/Nil$))) +(def Char (Named$ (&/T "lux" "Char") (Data$ "java.lang.Character" &/Nil$))) +(def Text (Named$ (&/T "lux" "Text") (Data$ "java.lang.String" &/Nil$))) +(def Unit (Named$ (&/T "lux" "Unit") (Tuple$ &/Nil$))) +(def $Void (Named$ (&/T "lux" "Void") (Variant$ &/Nil$))) (def Ident (Named$ (&/T "lux" "Ident") (Tuple$ (&/|list Text Text)))) (def IO @@ -221,11 +221,14 @@ (Tuple$ (&/|list ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter" (&/|list)) + (Data$ "org.objectweb.asm.ClassWriter" &/Nil$) ;; "lux;loader" - (Data$ "java.lang.ClassLoader" (&/|list)) + (Data$ "java.lang.ClassLoader" &/Nil$) ;; "lux;classes" - (Data$ "clojure.lang.Atom" (&/|list)))))) + (Data$ "clojure.lang.Atom" &/Nil$) + ;; "lux;catching" + (App$ List Text) + )))) (def DefData* (Univ$ empty-env @@ -367,7 +370,7 @@ (let [id (->> state (&/get$ &/$type-vars) (&/get$ &/$counter))] (return* (&/update$ &/$type-vars #(->> % (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [ms] (&/|put id (&/V &/$None nil) ms)))) + (&/update$ &/$mappings (fn [ms] (&/|put id &/None$ ms)))) state) id)))) @@ -396,7 +399,7 @@ (|case ?type* (&/$VarT ?id*) (if (.equals ^Object id ?id*) - (return (&/T ?id (&/V &/$None nil))) + (return (&/T ?id &/None$)) (return binding)) _ @@ -465,7 +468,7 @@ (&/T ??out (&/Cons$ ?in ?args))) _ - (&/T type (&/|list)))) + (&/T type &/Nil$))) (defn ^:private unravel-app [fun-type] (|case fun-type @@ -474,7 +477,7 @@ (&/T ?fun-type (&/|++ ?args (&/|list ?right)))) _ - (&/T fun-type (&/|list)))) + (&/T fun-type &/Nil$))) (defn show-type [^objects type] (|case type @@ -581,7 +584,7 @@ (|let [[e a] k] (|case fixpoints (&/$Nil) - (&/V &/$None nil) + &/None$ (&/$Cons [[e* a*] v*] fixpoints*) (if (and (type= e e*) @@ -674,7 +677,7 @@ (def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) -(def ^:private init-fixpoints (&/|list)) +(def ^:private init-fixpoints &/Nil$) (defn ^:private check* [class-loader fixpoints invariant?? expected actual] (if (clojure.lang.Util/identical expected actual) @@ -689,14 +692,14 @@ (return* state* (&/V &/$Some ebound)) (&/$Left _) - (return* state (&/V &/$None nil)))) + (return* state &/None$))) abound (fn [state] (|case ((deref ?aid) state) (&/$Right state* abound) (return* state* (&/V &/$Some abound)) (&/$Left _) - (return* state (&/V &/$None nil))))] + (return* state &/None$)))] (|case [ebound abound] [(&/$None _) (&/$None _)] (|do [_ (set-var ?eid actual)] @@ -873,6 +876,10 @@ (return (&/T fixpoints nil))) (and (not invariant??) + ;; (do (println '[Data Data] [e!name a!name] + ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) + ;; true) (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) (return (&/T fixpoints nil)) -- cgit v1.2.3 From 12402b01ce04428fee46a9441a4d1f4cf16db179 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 13 Sep 2015 00:58:35 -0400 Subject: - Fixed bug wherein mutual recursion could occur between modules. - Fixed bug wherein recompiling a previously cached module didn't always trigger all the necessary recompilations from dependent modules. --- src/lux/analyser/lux.clj | 7 +++++-- src/lux/base.clj | 38 ++++++++++++++++++++++++++++++++++++-- src/lux/compiler.clj | 7 ++++--- src/lux/compiler/cache.clj | 6 ++++-- 4 files changed, 49 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 4a03c4848..3de4db89f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -364,7 +364,7 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [_ (when (or (= "zip" (aget real-name 1)) + ;; :let [_ (when (or (= "invoke-interface$" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) ;; ) @@ -534,7 +534,10 @@ (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? path) - ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] + ;; :let [_ (prn 'analyse-import module-name path + ;; already-compiled?)] + active? (&/active-module? path) + _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) _ (&/when% (not already-compiled?) (compile-module path))] (return &/Nil$))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index aefa0cf4c..4c5d8ae44 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -80,12 +80,19 @@ "locals" "closure"]) +;; ModuleState +(deftags + ["Active" + "Compiled" + "Cached"]) + ;; Host (deftags ["writer" "loader" "classes" - "catching"]) + "catching" + "module-states"]) ;; Compiler (deftags @@ -110,7 +117,6 @@ (def eval-field "_eval") (def tags-field "_tags") (def module-class-name "_") - (def +name-separator+ ";") (defn T [& elems] @@ -604,6 +610,8 @@ store ;; "lux;catching" Nil$ + ;; "lux;module-states" + (|table) ))) (defn init-state [_] @@ -937,3 +945,29 @@ ($None) (V $None nil) ($Some xs**) (V $Some (V $Cons (T x xs**)))) ))) + +(do-template [ ] + (do (defn [module] + "(-> Text (Lux (,)))" + (fn [state] + (let [state* (update$ $host (fn [host] + (update$ $module-states + (fn [module-states] + (|put module (V nil) module-states)) + host)) + state)] + (V $Right (T state* nil))))) + (defn [module] + "(-> Text (Lux Bool))" + (fn [state] + (if-let [module-state (->> state (get$ $host) (get$ $module-states) (|get module))] + (V $Right (T state (|case module-state + () true + _ false))) + (V $Right (T state false))) + ))) + + flag-active-module active-module? $Active + flag-compiled-module compiled-module? $Compiled + flag-cached-module cached-module? $Cached + ) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 759fc98fc..d6bbb17ae 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -483,8 +483,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&&cache/delete name) - _ (&a-module/enter-module name) + (|do [_ (&a-module/enter-module name) + _ (&/flag-active-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) (str (&host/->module-class name) "/_") nil "java/lang/Object" nil) @@ -529,7 +529,8 @@ .visitEnd) (.visitEnd)) ;; _ (prn 'CLOSED name =class) - ]] + ] + _ (&/flag-compiled-module name)] (&&/save-class! &/module-class-name (.toByteArray =class))) ?state) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 3532cf843..d4ce7516d 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -89,8 +89,9 @@ ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] - (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux"))] - (load _import (hash content) compile-module))) + (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux")) + _ (load _import (hash content) compile-module)] + (&/cached-module? _import))) (if (= [""] imports) &/Nil$ (&/->list imports)))] @@ -120,6 +121,7 @@ &/->list)))] ;; (prn 'load module defs) (|do [_ (&a-module/enter-module module) + _ (&/flag-cached-module module) _ (&a-module/set-imports imports) _ (&/map% (fn [_def] (let [[_exported? _name _ann] (string/split _def #" ") -- cgit v1.2.3 From 8a67a7e51b3875c3ebba4e8d0acbd275aaa2c356 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 14 Sep 2015 23:27:38 -0400 Subject: - Added the possibility to define anonymous classes. - Fixed some bugs. --- src/lux/analyser.clj | 62 ++++++---- src/lux/analyser/host.clj | 307 +++++++++++++++++++++++++++------------------- src/lux/base.clj | 5 +- src/lux/compiler.clj | 24 +--- src/lux/compiler/host.clj | 166 ++++++++++++++++--------- src/lux/host.clj | 69 +++++++++-- src/lux/type.clj | 6 +- 7 files changed, 390 insertions(+), 249 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 03709b226..a412362d9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -71,85 +71,85 @@ (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil)))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) (&&host/analyse-jvm-znewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-zastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_zaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-zaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-bnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_bastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-bastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_baload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-baload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_snewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-snewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_sastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-sastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_saload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-saload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_inewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-inewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-iastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-iaload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-lnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-lastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-laload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-fnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-fastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_faload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-faload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-dnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_dastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-dastore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_daload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-daload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_cnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-cnewarray analyse ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_castore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) (&&host/analyse-jvm-castore analyse ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-caload analyse ?array ?idx) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$IntS ?length)] (&/$Nil))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Cons ?elem (&/$Nil))))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) (&&host/analyse-jvm-aastore analyse ?class ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons [_ (&/$IntS ?idx)] (&/$Nil)))))) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) (&&host/analyse-jvm-aaload analyse ?class ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) @@ -173,6 +173,14 @@ (|do [=supers (&/map% extract-text ?supers)] (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] + (&/$Cons [_ (&/$TextS ?super-class)] + (&/$Cons [_ (&/$TupleS ?interfaces)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil)))))) + (|do [=interfaces (&/map% extract-text ?interfaces)] + (&&host/analyse-jvm-anon-class analyse compile-token exo-type ?super-class =interfaces ?methods)) + ;; Programs (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_program")] (&/$Cons [_ (&/$SymbolS "" ?args)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index db04a60c0..f6963d8bf 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -12,7 +12,9 @@ [type :as &type] [host :as &host]) (lux.analyser [base :as &&] - [env :as &&env]))) + [lambda :as &&lambda] + [env :as &&env]) + [lux.compiler.base :as &c!base])) ;; [Utils] (defn ^:private extract-text [ast] @@ -65,14 +67,6 @@ output))))) )) -(defn ^:private analyse-1+ [analyse token] - (&type/with-var - (fn [$var] - (|do [=expr (&&/analyse-1 analyse $var token) - :let [[item type] =expr] - =type (&type/clean $var type)] - (return (&/T item =type)))))) - (defn ^:private ensure-object [token] "(-> Analysis (Lux (,)))" (|case token @@ -215,7 +209,7 @@ (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) (defn analyse-jvm-instanceof [analyse exo-type class object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] @@ -258,14 +252,14 @@ (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) (defn analyse-jvm-null? [analyse exo-type object] - (|do [=object (analyse-1+ analyse object) + (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ "null" &/Nil$)] + (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) @@ -280,18 +274,23 @@ (do-template [ ] (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + length-type &type/Int + idx-type &type/Int] (defn [analyse length] - (return (&/|list (&/T (&/V length) array-type)))) + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V =length) array-type))))) (defn [analyse array idx] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V (&/T =array idx)) elem-type))))) + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V (&/T =array =idx)) elem-type))))) (defn [analyse array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V (&/T =array idx =elem)) array-type))))) + (return (&/|list (&/T (&/V (&/T =array =idx =elem)) array-type))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -304,30 +303,35 @@ "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore ) -(defn analyse-jvm-anewarray [analyse class length] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class length)) array-type))))) - -(defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array idx)) elem-type)))))) +(let [length-type &type/Int + idx-type &type/Int] + (defn analyse-jvm-anewarray [analyse class length] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=length (&&/analyse-1 analyse length-type length)] + (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class =length)) array-type)))))) + + (defn analyse-jvm-aaload [analyse class array idx] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx)] + (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array =idx)) elem-type)))))) -(defn analyse-jvm-aastore [analyse class array idx elem] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ "Array" (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array idx =elem)) array-type)))))) + (defn analyse-jvm-aastore [analyse class array idx elem] + (let [elem-type (&type/Data$ class &/Nil$) + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem)] + (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array =idx =elem)) array-type))))))) (let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ "Array" (&/|list elem-type))] + array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array)] (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) @@ -367,68 +371,85 @@ :concurrency nil} modifiers)) -(defn analyse-jvm-class [analyse compile-token ?name ?super-class ?interfaces ?fields ?methods] - (|do [class-loader &/loader - abstract-methods (&/flat-map% (partial &host/abstract-methods class-loader) (&/Cons$ ?super-class ?interfaces)) - =fields (&/map% (fn [?field] - (|case ?field - [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Nil)))))] - (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] - (return {:name ?field-name - :modifiers =field-modifiers - :type ?field-type})) - - _ - (fail "[Analyser Error] Wrong syntax for field."))) - ?fields) - =methods (&/map% (fn [?method] - (|case ?method - [?idx [_ (&/$FormS (&/$Cons [_ (&/$TextS ?method-name)] - (&/$Cons [_ (&/$TupleS ?method-inputs)] - (&/$Cons [_ (&/$TextS ?method-output)] - (&/$Cons [_ (&/$TupleS ?method-modifiers)] - (&/$Cons ?method-body - (&/$Nil)))))))]] - (|do [=method-inputs (&/map% (fn [minput] - (|case minput - [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" ?input-name)] - (&/$Cons [_ (&/$TextS ?input-type)] - (&/$Nil))))] - (return (&/T ?input-name ?input-type)) - - _ - (fail "[Analyser Error] Wrong syntax for method input."))) - ?method-inputs) - =method-modifiers (analyse-modifiers ?method-modifiers) - =method-body (&/with-scope (str ?name "_" ?idx) - (&/fold (fn [body* input*] - (|let [[iname itype] input*] - (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) - body*))) - (if (= "void" ?method-output) - (analyse-1+ analyse ?method-body) - (&&/analyse-1 analyse (&type/Data$ (as-otype ?method-output) &/Nil$) ?method-body)) - (&/|reverse (if (:static? =method-modifiers) - =method-inputs - (&/Cons$ (&/T "this" ?super-class) - =method-inputs)))))] - (return {:name ?method-name - :modifiers =method-modifiers - :inputs (&/|map &/|second =method-inputs) - :output ?method-output - :body =method-body})) - - _ - (fail "[Analyser Error] Wrong syntax for method."))) - (&/enumerate ?methods)) - ;; Test for method completion +(defn ^:private analyse-field [field] + (|case field + [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Nil)))))] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (return {:name ?field-name + :modifiers =field-modifiers + :type ?field-type})) + + _ + (fail "[Analyser Error] Wrong syntax for field."))) + +(defn ^:private analyse-method [analyse name owner-class method] + (|case method + [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons method-body + (&/$Nil)))))))]] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs) + =method-body (&/fold (fn [body* input*] + (|let [[iname itype] input*] + (&&env/with-local iname (&type/Data$ (as-otype itype) &/Nil$) + body*))) + (if (= "void" method-output) + (&&/analyse-1+ analyse method-body) + (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) + (&/|reverse (&/Cons$ (&/T "this" owner-class) + =method-inputs)))] + (return {:name method-name + :modifiers =method-modifiers + :inputs (&/|map &/|second =method-inputs) + :output method-output + :body =method-body})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + +(defn ^:private analyse-method-decl [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Nil))))))] + (|do [=inputs (&/map% extract-text inputs) + =modifiers (analyse-modifiers modifiers)] + (return {:name method-name + :modifiers =modifiers + :inputs =inputs + :output output})) + + _ + (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) + +(defn ^:private mandatory-methods [supers] + (|do [class-loader &/loader] + (&/flat-map% (partial &host/abstract-methods class-loader) supers))) + +(defn ^:private check-method-completion [supers methods] + "(-> (List ClassName) (List MethodDesc) (Lux (,)))" + (|do [abstract-methods (mandatory-methods supers) :let [methods-map (&/fold (fn [mmap mentry] (assoc mmap (:name mentry) mentry)) {} - =methods) + methods) missing-method (&/fold (fn [missing abs-meth] (|let [[am-name am-inputs] abs-meth] (or missing @@ -442,36 +463,74 @@ am-name)) am-name)))) nil - abstract-methods)] - _ (if (nil? missing-method) - (return nil) - (fail (str "[Analyser Error] Missing method: " missing-method))) - _ (compile-token (&/V &&/$jvm-class (&/T ?name ?super-class ?interfaces =fields =methods))) - ;; :let [_ (prn 'analyse-jvm-class ?name ?super-class)] - ] - (return &/Nil$))) + abstract-methods)]] + (if (nil? missing-method) + (return nil) + (fail (str "[Analyser Error] Missing method: " missing-method))))) + +(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] + (&/with-closure + (|do [module &/get-module-name + ;; :let [_ (prn 'analyse-jvm-class/_0)] + =fields (&/map% analyse-field fields) + ;; :let [_ (prn 'analyse-jvm-class/_1)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-class/_2)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-class/_3)] + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil))) + :let [_ (println 'DEF (str module "." name))]] + (return &/Nil$)))) (defn analyse-jvm-interface [analyse compile-token name supers methods] - (|do [=methods (&/map% (fn [method] - (|case method - [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Nil))))))] - (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers)] - (return {:name method-name - :modifiers =modifiers - :inputs =inputs - :output output})) - - _ - (fail (str "[Analyser Error] Invalid method signature: " (&/show-ast method))))) - methods) - _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods)))] + (|do [module &/get-module-name + =methods (&/map% analyse-method-decl methods) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods))) + :let [_ (println 'DEF (str module "." name))]] (return &/Nil$))) +(defn ^:private captured-source [env-entry] + (|case env-entry + [name [(&&/$captured _ _ source) _]] + source)) + +(let [captured-slot-modifier {:visibility "private" + :static? false + :final? false + :abstract? false + :concurrency nil} + captured-slot-type "java.lang.Object"] + (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] + (&/with-closure + (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)] + module &/get-module-name + scope &/get-scope-name + ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)] + :let [name (&host/location (&/|tail scope)) + anon-class (str module "." name)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] + =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] + _ (check-method-completion (&/Cons$ super-class interfaces) =methods) + ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] + =captured &&env/captured-vars + :let [=fields (&/|map (fn [idx+capt] + {:name (str &c!base/closure-prefix (aget idx+capt 0)) + :modifiers captured-slot-modifier + :type captured-slot-type}) + (&/enumerate =captured)) + ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) + ;; =methods* (rename-captured-vars) + ] + :let [sources (&/|map captured-source =captured)] + ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] + ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) + :let [_ (println 'DEF anon-class)]] + (return (&/|list (&/T (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) (&type/Data$ anon-class (&/|list))))) + ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) + )))) + (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] (|do [:let [[?catches ?finally] ?catches+?finally] =catches (&/map% (fn [[?ex-class ?ex-arg ?catch-body]] @@ -485,19 +544,17 @@ (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally (&/$None) (return &/None$) - (&/$Some ?finally*) (|do [=finally (analyse-1+ analyse ?finally*)] + (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] (return (&/V &/$Some =finally))))] (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (analyse-1+ analyse ?ex) - :let [[_obj _type] =ex] - _ (&type/check (&type/Data$ "java.lang.Throwable" &/Nil$) _type)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) &type/$Void))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)] + (return (&/|list (&/T (&/V &&/$jvm-throw =ex) exo-type))))) (do-template [ ] (defn [analyse exo-type ?monitor] - (|do [=monitor (analyse-1+ analyse ?monitor) + (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object =monitor) :let [output-type &type/Unit] _ (&type/check exo-type output-type)] diff --git a/src/lux/base.clj b/src/lux/base.clj index 4c5d8ae44..0e164f5d2 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -749,10 +749,11 @@ (defn with-writer [writer body] (fn [state] - (let [output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] + (let [old-writer (->> state (get$ $host) (get$ $writer)) + output (body (update$ $host #(set$ $writer (V $Some writer) %) state))] (|case output ($Right ?state ?value) - (return* (update$ $host #(set$ $writer (->> state (get$ $host) (get$ $writer)) %) ?state) + (return* (update$ $host #(set$ $writer old-writer %) ?state) ?value) _ diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d6bbb17ae..048b9ee1d 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -405,23 +405,6 @@ ) )) -(defn ^:private compile-statement [syntax] - (|case syntax - (&a/$def ?name ?body) - (&&lux/compile-def compile-expression ?name ?body) - - (&a/$declare-macro ?module ?name) - (&&lux/compile-declare-macro compile-expression ?module ?name) - - (&a/$jvm-program ?body) - (&&host/compile-jvm-program compile-expression ?body) - - (&a/$jvm-interface ?name ?supers ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods))) - (defn ^:private compile-token [syntax] (|case syntax (&a/$def ?name ?body) @@ -436,8 +419,8 @@ (&a/$jvm-interface ?name ?supers ?methods) (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods) + (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env) _ (compile-expression syntax))) @@ -483,7 +466,8 @@ (|do [module-exists? (&a-module/exists? name)] (if module-exists? (fail "[Compiler Error] Can't redefine a module!") - (|do [_ (&a-module/enter-module name) + (|do [_ (&&cache/delete name) + _ (&a-module/enter-module name) _ (&/flag-active-module name) :let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_6 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 83c769b4b..2ca613633 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -76,7 +76,7 @@ (&/$DataT "char" (&/$Nil)) (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host/->class char-class) "valueOf" (str "(C)" (&host/->type-signature char-class))) - (&/$DataT _ (&/$Nil)) + (&/$DataT _ _) nil (&/$NamedT ?name ?type) @@ -290,16 +290,18 @@ (do-template [ ] (do (defn [compile *type* ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitIntInsn Opcodes/NEWARRAY ))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] (return nil))) (defn [compile *type* ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) (.visitInsn ) )]] (return nil))) @@ -307,9 +309,10 @@ (defn [compile *type* ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (doto *writer* @@ -329,25 +332,27 @@ (defn compile-jvm-anewarray [compile *type* ?class ?length] (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn (int ?length)) - (.visitTypeInsn Opcodes/ANEWARRAY (&host/->class ?class)))]] + _ (compile ?length) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) (defn compile-jvm-aaload [compile *type* ?class ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitLdcInsn (int ?idx)) - (.visitInsn Opcodes/AALOAD))]] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) (defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int ?idx)))] + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] + :let [_ (.visitInsn *writer* Opcodes/DUP)] + _ (compile ?idx) + :let [_ (.visitInsn *writer* Opcodes/L2I)] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) @@ -355,6 +360,7 @@ (defn compile-jvm-arraylength [compile *type* ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) + :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (doto *writer* (.visitInsn Opcodes/ARRAYLENGTH) (.visitInsn Opcodes/I2L) @@ -417,33 +423,75 @@ (&&/wrap-boolean))]] (return nil))) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods] - (|do [module &/get-module-name] - (let [super-class* (&host/->class ?super-class) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - (str module "/" ?name) nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) - ?fields)] - (|do [_ (&/map% (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod =class (modifiers->int (:modifiers method)) - (:name method) - signature nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] - _ (compile (:body method)) - :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ?methods)] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))))) +(defn ^:private compile-method [compile class-writer method] + ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) + ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) + ;; (prn 'compile-method/_2 (&/adt->text (:output method))) + ;; (prn 'compile-method/_3 (&/adt->text (:body method))) + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (&/with-writer (.visitMethod class-writer (modifiers->int (:modifiers method)) + (:name method) + signature nil nil) + (|do [^MethodVisitor =method &/get-writer + :let [_ (.visitCode =method)] + _ (compile (:body method)) + :let [_ (doto =method + (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (.visitMaxs 0 0) + (.visitEnd))]] + (return nil))))) + +(defn ^:private compile-method-decl [class-writer method] + (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" + (&host/->type-signature (:output method)))] + (.visitMethod class-writer (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + +(let [clo-field-sig (&host/->type-signature "java.lang.Object") + -return "V"] + (defn ^:private anon-class--signature [env] + (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" + -return)) + + (defn ^:private add-anon-class- [class-writer class-name env] + (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) + (.visitCode) + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") + (-> (doto (.visitVarInsn Opcodes/ALOAD 0) + (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) + (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) + (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) + (|case ?name+?captured + [?name [(&a/$captured _ ?captured-id ?source) _]]) + (doseq [?name+?captured (&/->seq env)]))) + (.visitInsn Opcodes/RETURN) + (.visitMaxs 0 0) + (.visitEnd))) + ) + +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env] + (|do [;; :let [_ (prn 'compile-jvm-class/_0)] + module &/get-module-name + ;; :let [_ (prn 'compile-jvm-class/_1)] + :let [full-name (str module "/" ?name) + super-class* (&host/->class ?super-class) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil) + (.visitEnd))) + ?fields)] + ;; :let [_ (prn 'compile-jvm-class/_2)] + _ (&/map% (partial compile-method compile =class) ?methods) + ;; :let [_ (prn 'compile-jvm-class/_3)] + :let [_ (when env + (add-anon-class- =class full-name env))] + ;; :let [_ (prn 'compile-jvm-class/_4)] + ] + (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) @@ -451,11 +499,7 @@ (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) - _ (do (&/|map (fn [method] - (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" - (&host/->type-signature (:output method)))] - (.visitMethod =interface (modifiers->int (:modifiers method)) (:name method) signature nil nil))) - ?methods) + _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) @@ -467,14 +511,14 @@ $catch-finally (new Label) compile-finally (|case ?finally (&/$Some ?finally*) (|do [_ (return nil) - _ (compile ?finally*) - :let [_ (doto *writer* - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $end))]] - (return nil)) + _ (compile ?finally*) + :let [_ (doto *writer* + (.visitInsn Opcodes/POP) + (.visitJumpInsn Opcodes/GOTO $end))]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] - (return nil))) + :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)]] + (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) @@ -501,12 +545,12 @@ :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) - :let [_ (.visitInsn *writer* Opcodes/POP)] - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil)) + :let [_ (.visitInsn *writer* Opcodes/POP)] + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil)) (&/$None) (|do [_ (return nil) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) + :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] + (return nil))) :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] :let [_ (.visitLabel *writer* $end)]] (return nil))) diff --git a/src/lux/host.clj b/src/lux/host.clj index 9137f3874..eafd6a1ac 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -19,21 +19,45 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") +(def array-data-tag "#Array") +(def null-data-tag "#Null") ;; [Utils] +(def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") + +(comment + (let [class (class (to-array []))] + (str (if-let [pkg (.getPackage class)] + (str (.getName pkg) ".") + "") + (.getSimpleName class))) + + (.getName String) "java.lang.String" + + (.getName (class (to-array []))) "[Ljava.lang.Object;" + + (re-find class-name-re "java.lang.String") + ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] + + (re-find class-name-re "[Ljava.lang.Object;") + ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] + ) + (defn ^:private class->type [^Class class] "(-> Class Type)" - (if-let [[_ base arr-level] (re-find #"^([^\[]+)(\[\])*$" - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class)))] - (if (.equals "void" base) - &type/Unit - (&type/Data$ (str (reduce str "" (repeat (int (/ (count arr-level) 2)) "[")) - base) - &/Nil$) - ))) + (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (let [output-type (if (.equals "void" base) + &type/Unit + (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (&type/Data$ base &/Nil$) + (range (count (or arr-brackets "")))) + )] + ;; (prn 'class->type/_2 class (&type/show-type output-type)) + output-type) + )))) (defn ^:private method->type [^Method method] "(-> Method Type)" @@ -70,11 +94,31 @@ (str "L" class* ";"))) )) +(defn unfold-array [type] + "(-> Type (, Int Type))" + (|case type + (&/$DataT "#Array" (&/$Cons param (&/$Nil))) + (|let [[count inner] (unfold-array param)] + (&/T (inc count) inner)) + + _ + (&/T 0 type))) + (defn ->java-sig [^objects type] "(-> Type Text)" (|case type (&/$DataT ?name params) - (->type-signature ?name) + (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= null-data-tag ?name) (->type-signature "java.lang.Object") + :else (->type-signature ?name)) (&/$LambdaT _ _) (->type-signature function-class) @@ -123,6 +167,7 @@ ) (defn lookup-constructor [class-loader target args] + ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] (and (= (&/|length args) (&/|length param-types)) diff --git a/src/lux/type.clj b/src/lux/type.clj index 8a1e11bed..baf834ee6 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -862,7 +862,7 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "null" (&/$Nil))] + [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] (if (contains? primitive-types e!name) (fail (str "[Type Error] Can't use \"null\" with primitive types.")) (return (&/T fixpoints nil))) @@ -880,7 +880,9 @@ ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) ;; true) - (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader))) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) (return (&/T fixpoints nil)) :else -- cgit v1.2.3 From d2a4aac2226b5cca59be236d3228fe5e5b17b8de Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 14 Sep 2015 23:37:10 -0400 Subject: - Renamed "this" to "_jvm_this". - Movied lux/data/io to lux/codata/io. --- src/lux/analyser/base.clj | 2 ++ src/lux/analyser/host.clj | 2 +- src/lux/analyser/lux.clj | 7 +++---- 3 files changed, 6 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index 8df7f23b2..b12425ac7 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -155,6 +155,8 @@ (|let [[_ type] syntax+] type)) +(def jvm-this "_jvm_this") + (defn cap-1 [action] (|do [result action] (|case result diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index f6963d8bf..681f22168 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -411,7 +411,7 @@ (if (= "void" method-output) (&&/analyse-1+ analyse method-body) (&&/analyse-1 analyse (&type/Data$ (as-otype method-output) &/Nil$) method-body)) - (&/|reverse (&/Cons$ (&/T "this" owner-class) + (&/|reverse (&/Cons$ (&/T &&/jvm-this owner-class) =method-inputs)))] (return {:name method-name :modifiers =method-modifiers diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 3de4db89f..6546990e6 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -275,10 +275,9 @@ endo-type)))) state) - [_] - (do ;; (prn 'analyse-symbol/_2.1.2 ?module name name) - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")))) - (fail* "_{_ analyse-symbol _}_"))) + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) + (fail* ""))) (&/$Cons top-outer _) (do ;; (prn 'analyse-symbol/_3 ?module name) -- cgit v1.2.3 From 5dafb9ad900f990a14e280db2e00fb668a6606b9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 00:31:35 -0400 Subject: - Compiler now takes into consideration exceptions that can be thrown by constructors. - Changed the order of parameters in UnivQ & ExQ (even params are now arguments & odd params are now the UnivQ/ExQ types). --- src/lux/analyser/case.clj | 2 +- src/lux/analyser/host.clj | 3 ++- src/lux/host.clj | 2 +- src/lux/type.clj | 50 +++++++++++++++++++++++------------------------ 4 files changed, 29 insertions(+), 28 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 109ba7c41..c6806a627 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -68,7 +68,7 @@ (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) + (adjust-type* (&/Cons$ (&/T _aenv 0 $var) (&/|map update-up-frame up)) =type)))) (&/$TupleT ?members) (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 681f22168..f17be2a7c 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -265,9 +265,10 @@ (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader - =return (&host/lookup-constructor class-loader class classes) + [=return exceptions] (&host/lookup-constructor class-loader class classes) =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) + _ (ensure-catching exceptions) :let [output-type (&type/Data$ class &/Nil$)] _ (&type/check exo-type output-type)] (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) diff --git a/src/lux/host.clj b/src/lux/host.clj index eafd6a1ac..6be162bf7 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -176,7 +176,7 @@ args (&/|map #(.getName ^Class %) param-types))))] =method))] - (return &type/Unit) + (return (&/T &type/Unit (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %))))) (fail (str "[Host Error] Constructor does not exist: " target)))) (defn abstract-methods [class-loader class] diff --git a/src/lux/type.clj b/src/lux/type.clj index baf834ee6..d6275651e 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -58,7 +58,7 @@ (def IO (Named$ (&/T "lux/data" "IO") (Univ$ empty-env - (Lambda$ Unit (Bound$ 1))))) + (Lambda$ Unit (Bound$ 0))))) (def List (Named$ (&/T "lux" "List") @@ -67,9 +67,9 @@ ;; lux;Nil Unit ;; lux;Cons - (Tuple$ (&/|list (Bound$ 1) - (App$ (Bound$ 0) - (Bound$ 1)))) + (Tuple$ (&/|list (Bound$ 0) + (App$ (Bound$ 1) + (Bound$ 0)))) ))))) (def Maybe @@ -79,12 +79,12 @@ ;; lux;None Unit ;; lux;Some - (Bound$ 1) + (Bound$ 0) ))))) (def Type (Named$ (&/T "lux" "Type") - (let [Type (App$ (Bound$ 0) (Bound$ 1)) + (let [Type (App$ (Bound$ 1) (Bound$ 0)) TypeList (App$ List Type) TypePair (Tuple$ (&/|list Type Type))] (App$ (Univ$ empty-env @@ -123,13 +123,13 @@ Int ;; "lux;mappings" (App$ List - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1)))))))))) + (Tuple$ (&/|list (Bound$ 2) + (Bound$ 0)))))))))) (def Env (Named$ (&/T "lux" "Env") - (let [bindings (App$ (App$ Bindings (Bound$ 3)) - (Bound$ 1))] + (let [bindings (App$ (App$ Bindings (Bound$ 2)) + (Bound$ 0))] (Univ$ empty-env (Univ$ empty-env (Tuple$ @@ -152,14 +152,14 @@ (Named$ (&/T "lux" "Meta") (Univ$ empty-env (Univ$ empty-env - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1))))))) + (Tuple$ (&/|list (Bound$ 2) + (Bound$ 0))))))) (def AST* (Named$ (&/T "lux" "AST'") - (let [AST* (App$ (Bound$ 1) - (App$ (Bound$ 0) - (Bound$ 1))) + (let [AST* (App$ (Bound$ 0) + (App$ (Bound$ 1) + (Bound$ 0))) AST*List (App$ List AST*)] (Univ$ empty-env (Variant$ (&/|list @@ -198,17 +198,17 @@ (Univ$ empty-env (Variant$ (&/|list ;; &/$Left - (Bound$ 3) + (Bound$ 2) ;; &/$Right - (Bound$ 1))))))) + (Bound$ 0))))))) (def StateE (Univ$ empty-env (Univ$ empty-env - (Lambda$ (Bound$ 3) + (Lambda$ (Bound$ 2) (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ 3) - (Bound$ 1)))))))) + (Tuple$ (&/|list (Bound$ 2) + (Bound$ 0)))))))) (def Source (Named$ (&/T "lux" "Source") @@ -238,7 +238,7 @@ ;; "lux;TypeD" Type ;; "lux;MacroD" - (Bound$ 1) + (Bound$ 0) ;; "lux;AliasD" Ident )))) @@ -263,7 +263,7 @@ (Tuple$ (&/|list Bool (App$ DefData* (Lambda$ ASTList - (App$ (App$ StateE (Bound$ 1)) + (App$ (App$ StateE (Bound$ 0)) ASTList)))))))) ;; "lux;imports" (App$ List Text) @@ -293,7 +293,7 @@ Cursor ;; "lux;modules" (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ 0) (Bound$ 1)))))) + (App$ $Module (App$ (Bound$ 1) (Bound$ 0)))))) ;; "lux;envs" (App$ List (App$ (App$ Env Text) @@ -645,8 +645,8 @@ (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/Cons$ param) - (&/Cons$ type-fn)) + (&/Cons$ type-fn) + (&/Cons$ param)) local-def)) (&/$AppT F A) -- cgit v1.2.3 From 79f2b2d51b8210d0a2bc81344ea82b4e5cbc7429 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 00:59:45 -0400 Subject: - The Macro type now flows from lux.lux into the compiler, to achieve a perfect match without having the write the type in 2 places. - Made the "Host" type fully opaque to avoid letting users manipulate instances. --- src/lux/analyser/module.clj | 2 + src/lux/base.clj | 7 ++ src/lux/type.clj | 207 ++------------------------------------------ 3 files changed, 14 insertions(+), 202 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index deb6be69e..63ba9b741 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -62,6 +62,8 @@ (defn define [module name def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] + (when (and (= "Macro" name) (= "lux" module)) + (&type/set-macro-type! (aget def-data 1))) (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) (return* (->> state diff --git a/src/lux/base.clj b/src/lux/base.clj index 0e164f5d2..e57cb0957 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -600,6 +600,13 @@ (do (prn 'memory-class-loader/store class-name (keys @store)) (throw (IllegalStateException. (str "[Class Loader] Unknown class: " class-name))))))))) + +;; (deftype Host +;; (& #writer (^ org.objectweb.asm.ClassWriter) +;; #loader (^ java.net.URLClassLoader) +;; #classes (^ clojure.lang.Atom) +;; #catching (List Text) +;; #module-states (List (, Text ModuleState)))) (defn host [_] (let [store (atom {})] (T ;; "lux;writer" diff --git a/src/lux/type.clj b/src/lux/type.clj index d6275651e..bc28dbde0 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -114,208 +114,11 @@ ))) $Void)))) -(def Bindings - (Named$ (&/T "lux" "Bindings") - (Univ$ empty-env - (Univ$ empty-env - (Tuple$ (&/|list - ;; "lux;counter" - Int - ;; "lux;mappings" - (App$ List - (Tuple$ (&/|list (Bound$ 2) - (Bound$ 0)))))))))) - -(def Env - (Named$ (&/T "lux" "Env") - (let [bindings (App$ (App$ Bindings (Bound$ 2)) - (Bound$ 0))] - (Univ$ empty-env - (Univ$ empty-env - (Tuple$ - (&/|list - ;; "lux;name" - Text - ;; "lux;inner-closures" - Int - ;; "lux;locals" - bindings - ;; "lux;closure" - bindings - ))))))) - -(def Cursor - (Named$ (&/T "lux" "Cursor") - (Tuple$ (&/|list Text Int Int)))) - -(def Meta - (Named$ (&/T "lux" "Meta") - (Univ$ empty-env - (Univ$ empty-env - (Tuple$ (&/|list (Bound$ 2) - (Bound$ 0))))))) - -(def AST* - (Named$ (&/T "lux" "AST'") - (let [AST* (App$ (Bound$ 0) - (App$ (Bound$ 1) - (Bound$ 0))) - AST*List (App$ List AST*)] - (Univ$ empty-env - (Variant$ (&/|list - ;; &/$BoolS - Bool - ;; &/$IntS - Int - ;; &/$RealS - Real - ;; &/$CharS - Char - ;; &/$TextS - Text - ;; &/$SymbolS - Ident - ;; &/$TagS - Ident - ;; &/$FormS - AST*List - ;; &/$TupleS - AST*List - ;; &/$RecordS - (App$ List (Tuple$ (&/|list AST* AST*)))) - ))))) - -(def AST - (Named$ (&/T "lux" "AST") - (let [w (App$ Meta Cursor)] - (App$ w (App$ AST* w))))) - -(def ^:private ASTList (App$ List AST)) - -(def Either - (Named$ (&/T "lux" "Either") - (Univ$ empty-env - (Univ$ empty-env - (Variant$ (&/|list - ;; &/$Left - (Bound$ 2) - ;; &/$Right - (Bound$ 0))))))) - -(def StateE - (Univ$ empty-env - (Univ$ empty-env - (Lambda$ (Bound$ 2) - (App$ (App$ Either Text) - (Tuple$ (&/|list (Bound$ 2) - (Bound$ 0)))))))) - -(def Source - (Named$ (&/T "lux" "Source") - (App$ List - (App$ (App$ Meta Cursor) - Text)))) - -(def Host - (Named$ (&/T "lux" "Host") - (Tuple$ - (&/|list - ;; "lux;writer" - (Data$ "org.objectweb.asm.ClassWriter" &/Nil$) - ;; "lux;loader" - (Data$ "java.lang.ClassLoader" &/Nil$) - ;; "lux;classes" - (Data$ "clojure.lang.Atom" &/Nil$) - ;; "lux;catching" - (App$ List Text) - )))) - -(def DefData* - (Univ$ empty-env - (Variant$ (&/|list - ;; "lux;ValueD" - (Tuple$ (&/|list Type Unit)) - ;; "lux;TypeD" - Type - ;; "lux;MacroD" - (Bound$ 0) - ;; "lux;AliasD" - Ident - )))) - -(def LuxVar - (Named$ (&/T "lux" "LuxVar") - (Variant$ (&/|list - ;; "lux;Local" - Int - ;; "lux;Global" - Ident)))) - -(def $Module - (Univ$ empty-env - (Tuple$ - (&/|list - ;; "lux;module-aliases" - (App$ List (Tuple$ (&/|list Text Text))) - ;; "lux;defs" - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Bool - (App$ DefData* - (Lambda$ ASTList - (App$ (App$ StateE (Bound$ 0)) - ASTList)))))))) - ;; "lux;imports" - (App$ List Text) - ;; "lux;tags" - ;; (List (, Text (, Int (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list Int - (App$ List Ident) - Type))))) - ;; "lux;types" - ;; (List (, Text (, (List Ident) Type))) - (App$ List - (Tuple$ (&/|list Text - (Tuple$ (&/|list (App$ List Ident) - Type))))) - )))) - -(def $Compiler - (Named$ (&/T "lux" "Compiler") - (App$ (Univ$ empty-env - (Tuple$ - (&/|list - ;; "lux;source" - Source - ;; "lux;cursor" - Cursor - ;; "lux;modules" - (App$ List (Tuple$ (&/|list Text - (App$ $Module (App$ (Bound$ 1) (Bound$ 0)))))) - ;; "lux;envs" - (App$ List - (App$ (App$ Env Text) - (Tuple$ (&/|list LuxVar Type)))) - ;; "lux;types" - (App$ (App$ Bindings Int) Type) - ;; "lux;expected" - Type - ;; "lux;seed" - Int - ;; "lux;eval?" - Bool - ;; "lux;host" - Host - ))) - $Void))) - -(def Macro - (Named$ (&/T "lux" "Macro") - (Lambda$ ASTList - (App$ (App$ StateE $Compiler) - ASTList)))) +(def Macro) + +(defn set-macro-type! [type] + (def Macro type) + nil) (defn bound? [id] (fn [state] -- cgit v1.2.3 From 0f358c4052cf766a74b0354124736cb3652cda1d Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 15 Sep 2015 02:18:07 -0400 Subject: - :: no longer demands prefixes for the struct members - Fixed both lux/control/comonad;be & lux/codata/stream;\stream --- src/lux/analyser/case.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index c6806a627..325b6cdd8 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -113,7 +113,7 @@ (adjust-type* up ?type) _ - (assert false (prn 'adjust-type* (&type/show-type type))) + (assert false (prn-str 'adjust-type* (&type/show-type type))) )) (defn adjust-type [type] -- cgit v1.2.3 From 6a84a06475463ffdaf3d6512696c7577afc8fed1 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2015 18:54:38 -0400 Subject: - Now the file-name & the line numbers are stored inside the .class files for debug info. --- src/lux/analyser.clj | 43 +-- src/lux/analyser/base.clj | 19 +- src/lux/analyser/env.clj | 2 +- src/lux/analyser/host.clj | 152 +++++++---- src/lux/analyser/lambda.clj | 10 +- src/lux/analyser/lux.clj | 129 +++++---- src/lux/base.clj | 7 + src/lux/compiler.clj | 628 +++++++++++++++++++++++--------------------- src/lux/compiler/case.clj | 2 +- src/lux/compiler/host.clj | 90 ++++--- src/lux/compiler/lambda.clj | 10 +- src/lux/compiler/lux.clj | 28 +- src/lux/compiler/type.clj | 20 +- 13 files changed, 631 insertions(+), 509 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index a412362d9..190b34b03 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -60,9 +60,9 @@ (if (or ? (&&/type-tag? module tag-name)) (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) (|do [wanted-type (&&module/tag-type module tag-name) - [variant-analysis variant-type] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (&&lux/analyse-variant analyser (&/V &/$Left wanted-type) idx values)) _ (&type/check exo-type variant-type)] - (return (&/|list (&/T variant-analysis exo-type)))))) + (return (&/|list (&&/|meta exo-type variant-cursor variant-analysis)))))) _ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) @@ -324,10 +324,10 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_putfield")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons [_ (&/$TextS ?field)] - (&/$Cons ?object - (&/$Cons ?value + (&/$Cons ?value + (&/$Cons ?object (&/$Nil))))))) - (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?object ?value) + (&&host/analyse-jvm-putfield analyse exo-type ?class ?field ?value ?object) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_invokestatic")] (&/$Cons [_ (&/$TextS ?class)] @@ -584,24 +584,29 @@ (|case token ;; Standard special forms (&/$BoolS ?value) - (|do [_ (&type/check exo-type &type/Bool)] - (return (&/|list (&/T (&/V &&/$bool ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Bool) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$bool ?value))))) (&/$IntS ?value) - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&/T (&/V &&/$int ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$int ?value))))) (&/$RealS ?value) - (|do [_ (&type/check exo-type &type/Real)] - (return (&/|list (&/T (&/V &&/$real ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Real) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$real ?value))))) (&/$CharS ?value) - (|do [_ (&type/check exo-type &type/Char)] - (return (&/|list (&/T (&/V &&/$char ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Char) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$char ?value))))) (&/$TextS ?value) - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&/T (&/V &&/$text ?value) exo-type)))) + (|do [_ (&type/check exo-type &type/Text) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$text ?value))))) (&/$TupleS ?elems) (&&lux/analyse-tuple analyse (&/V &/$Right exo-type) ?elems) @@ -657,16 +662,16 @@ (defn ^:private just-analyse [analyser syntax] (&type/with-var (fn [?var] - (|do [[?output-term ?output-type] (&&/analyse-1 analyser ?var syntax)] + (|do [[[?output-type ?output-cursor] ?output-term] (&&/analyse-1 analyser ?var syntax)] (|case [?var ?output-type] [(&/$VarT ?e-id) (&/$VarT ?a-id)] (if (= ?e-id ?a-id) (|do [?output-type* (&type/deref ?e-id)] - (return (&/T ?output-term ?output-type*))) - (return (&/T ?output-term ?output-type))) + (return (&&/|meta ?output-type* ?output-cursor ?output-term))) + (return (&&/|meta ?output-type ?output-cursor ?output-term))) [_ _] - (return (&/T ?output-term ?output-type))) + (return (&&/|meta ?output-type ?output-cursor ?output-term))) )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] diff --git a/src/lux/analyser/base.clj b/src/lux/analyser/base.clj index b12425ac7..664ba4450 100644 --- a/src/lux/analyser/base.clj +++ b/src/lux/analyser/base.clj @@ -152,7 +152,7 @@ ;; [Exports] (defn expr-type* [syntax+] - (|let [[_ type] syntax+] + (|let [[[type _] _] syntax+] type)) (def jvm-this "_jvm_this") @@ -173,18 +173,21 @@ (&type/with-var (fn [$var] (|do [=expr (analyse-1 analyse $var ?token) - :let [[?item ?type] =expr] + :let [[[?type ?cursor] ?item] =expr] =type (&type/clean $var ?type)] - (return (&/T ?item =type)))))) + (return (&/T (&/T =type ?cursor) ?item)))))) (defn resolved-ident [ident] - (|let [[?module ?name] ident] - (|do [module* (if (.equals "" ?module) - &/get-module-name - (return ?module))] - (return (&/T module* ?name))))) + (|do [:let [[?module ?name] ident] + module* (if (.equals "" ?module) + &/get-module-name + (return ?module))] + (return (&/T module* ?name)))) (let [tag-names #{"DataT" "VariantT" "TupleT" "LambdaT" "BoundT" "VarT" "ExT" "UnivQ" "ExQ" "AppT" "NamedT"}] (defn type-tag? [module name] (and (= "lux" module) (contains? tag-names name)))) + +(defn |meta [type cursor analysis] + (&/T (&/T type cursor) analysis)) diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index 66478eecc..a7ce52c1f 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -24,7 +24,7 @@ (let [bound-unit (&/V &&/$var (&/V &/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter))))] (&/Cons$ (&/update$ &/$locals #(->> % (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name (&/T bound-unit type) m)))) + (&/update$ &/$mappings (fn [m] (&/|put name (&&/|meta type &/empty-cursor bound-unit) m)))) (&/|head stack)) (&/|tail stack)))) state))] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index f17be2a7c..292d3d4b1 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -115,8 +115,10 @@ (defn [analyse exo-type x y] (|do [=x (&&/analyse-1 analyse input-type x) =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V (&/T =x =y)) output-type)))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V (&/T =x =y)))))))) analyse-jvm-iadd &&/$jvm-iadd "java.lang.Integer" "java.lang.Integer" analyse-jvm-isub &&/$jvm-isub "java.lang.Integer" "java.lang.Integer" @@ -163,33 +165,41 @@ (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) :let [output-type =type] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getstatic (&/T class field)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-getstatic (&/T class field output-type))))))) (defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) :let [output-type =type] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-getfield (&/T class field =object)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-getfield (&/T class field =object output-type))))))) (defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putstatic (&/T class field =value)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-putstatic (&/T class field =value output-type))))))) -(defn analyse-jvm-putfield [analyse exo-type class field object value] +(defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-putfield (&/T class field =object =value)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-putfield (&/T class field =value =object (&&/expr-type* =object)))))))) (defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader @@ -205,15 +215,19 @@ classes args) :let [output-type =return] - _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokestatic (&/T class method classes =args)) output-type))))) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) (defn analyse-jvm-instanceof [analyse exo-type class object] (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-instanceof (&/T class =object)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-instanceof (&/T class =object))))))) (do-template [ ] (defn [analyse exo-type class method classes object args] @@ -228,8 +242,10 @@ :let [output-type =return] ;; :let [_ (prn ' [class method] '=return (&type/show-type =return))] ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] - _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V (&/T class method classes =object =args)) output-type))))) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V (&/T class method classes =object =args output-type))))))) analyse-jvm-invokevirtual &&/$jvm-invokevirtual analyse-jvm-invokeinterface &&/$jvm-invokeinterface @@ -248,20 +264,26 @@ (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) classes args) :let [output-type =return] - _ (&type/check exo-type (as-otype+ output-type))] - (return (&/|list (&/T (&/V &&/$jvm-invokespecial (&/T class method classes =object =args)) output-type))))) + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-invokespecial (&/T class method classes =object =args output-type))))))) (defn analyse-jvm-null? [analyse exo-type object] (|do [=object (&&/analyse-1+ analyse object) _ (ensure-object =object) :let [output-type &type/Bool] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null? =object) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-null? =object)))))) (defn analyse-jvm-null [analyse exo-type] (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-null nil) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-null nil)))))) (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader @@ -270,8 +292,10 @@ classes args) _ (ensure-catching exceptions) :let [output-type (&type/Data$ class &/Nil$)] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T class classes =args)) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor + (&/V &&/$jvm-new (&/T class classes =args))))))) (do-template [ ] (let [elem-type (&type/Data$ &/Nil$) @@ -279,19 +303,25 @@ length-type &type/Int idx-type &type/Int] (defn [analyse length] - (|do [=length (&&/analyse-1 analyse length-type length)] - (return (&/|list (&/T (&/V =length) array-type))))) + (|do [=length (&&/analyse-1 analyse length-type length) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V =length)))))) (defn [analyse array idx] (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx)] - (return (&/|list (&/T (&/V (&/T =array =idx)) elem-type))))) + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor] + (return (&/|list (&&/|meta elem-type _cursor + (&/V (&/T =array =idx))))))) (defn [analyse array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V (&/T =array =idx =elem)) array-type))))) + =elem (&&/analyse-1 analyse elem-type elem) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V (&/T =array =idx =elem))))))) ) "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore @@ -309,23 +339,29 @@ (defn analyse-jvm-anewarray [analyse class length] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] - (|do [=length (&&/analyse-1 analyse length-type length)] - (return (&/|list (&/T (&/V &&/$jvm-anewarray (&/T class =length)) array-type)))))) + (|do [=length (&&/analyse-1 analyse length-type length) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V &&/$jvm-anewarray (&/T class =length)))))))) (defn analyse-jvm-aaload [analyse class array idx] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx)] - (return (&/|list (&/T (&/V &&/$jvm-aaload (&/T class =array =idx)) elem-type)))))) + =idx (&&/analyse-1 analyse idx-type idx) + _cursor &/cursor] + (return (&/|list (&&/|meta elem-type _cursor + (&/V &&/$jvm-aaload (&/T class =array =idx)))))))) (defn analyse-jvm-aastore [analyse class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem)] - (return (&/|list (&/T (&/V &&/$jvm-aastore (&/T class =array =idx =elem)) array-type))))))) + =elem (&&/analyse-1 analyse elem-type elem) + _cursor &/cursor] + (return (&/|list (&&/|meta array-type _cursor + (&/V &&/$jvm-aastore (&/T class =array =idx =elem))))))))) (let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] (defn analyse-jvm-arraylength [analyse array] @@ -333,8 +369,11 @@ (fn [$var] (let [elem-type $var array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array)] - (return (&/|list (&/T (&/V &&/$jvm-arraylength =array) length-type))))))))) + (|do [=array (&&/analyse-1 analyse array-type array) + _cursor &/cursor] + (return (&/|list (&&/|meta length-type _cursor + (&/V &&/$jvm-arraylength =array) + ))))))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] @@ -492,7 +531,7 @@ (defn ^:private captured-source [env-entry] (|case env-entry - [name [(&&/$captured _ _ source) _]] + [name [_ (&&/$captured _ _ source)]] source)) (let [captured-slot-modifier {:visibility "private" @@ -527,8 +566,11 @@ ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) - :let [_ (println 'DEF anon-class)]] - (return (&/|list (&/T (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) (&type/Data$ anon-class (&/|list))))) + :let [_ (println 'DEF anon-class)] + _cursor &/cursor] + (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor + (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) + ))) ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) )))) @@ -546,20 +588,24 @@ =finally (|case ?finally (&/$None) (return &/None$) (&/$Some ?finally*) (|do [=finally (&&/analyse-1+ analyse ?finally*)] - (return (&/V &/$Some =finally))))] - (return (&/|list (&/T (&/V &&/$jvm-try (&/T =body =catches =finally)) exo-type))))) + (return (&/V &/$Some =finally)))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-try (&/T =body =catches =finally))))))) (defn analyse-jvm-throw [analyse exo-type ?ex] - (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex)] - (return (&/|list (&/T (&/V &&/$jvm-throw =ex) exo-type))))) + (|do [=ex (&&/analyse-1 analyse (&type/Data$ "java.lang.Throwable" &/Nil$) ?ex) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-throw =ex)))))) (do-template [ ] (defn [analyse exo-type ?monitor] (|do [=monitor (&&/analyse-1+ analyse ?monitor) _ (ensure-object =monitor) :let [output-type &type/Unit] - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =monitor) output-type))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V =monitor)))))) analyse-jvm-monitorenter &&/$jvm-monitorenter analyse-jvm-monitorexit &&/$jvm-monitorexit @@ -569,8 +615,9 @@ (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V =value))))))) analyse-jvm-d2f &&/$jvm-d2f "java.lang.Double" "java.lang.Float" analyse-jvm-d2i &&/$jvm-d2i "java.lang.Double" "java.lang.Integer" @@ -596,8 +643,9 @@ (let [output-type (&type/Data$ &/Nil$)] (defn [analyse exo-type ?value] (|do [=value (&&/analyse-1 analyse (&type/Data$ &/Nil$) ?value) - _ (&type/check exo-type output-type)] - (return (&/|list (&/T (&/V =value) output-type)))))) + _ (&type/check exo-type output-type) + _cursor &/cursor] + (return (&/|list (&&/|meta output-type _cursor (&/V =value))))))) analyse-jvm-iand &&/$jvm-iand "java.lang.Integer" "java.lang.Integer" analyse-jvm-ior &&/$jvm-ior "java.lang.Integer" "java.lang.Integer" diff --git a/src/lux/analyser/lambda.clj b/src/lux/analyser/lambda.clj index 819f07583..bbb5d2dc7 100644 --- a/src/lux/analyser/lambda.clj +++ b/src/lux/analyser/lambda.clj @@ -22,11 +22,11 @@ (return (&/T scope-name =captured =return)))))))) (defn close-over [scope name register frame] - (|let [[_ register-type] register - register* (&/T (&/V &&/$captured (&/T scope - (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) - register)) - register-type)] + (|let [[[register-type register-cursor] _] register + register* (&&/|meta register-type register-cursor + (&/V &&/$captured (&/T scope + (->> frame (&/get$ &/$closure) (&/get$ &/$counter)) + register)))] (&/T register* (&/update$ &/$closure #(->> % (&/update$ &/$counter inc) (&/update$ &/$mappings (fn [mps] (&/|put name register* mps)))) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 6546990e6..488b7ae4f 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -52,7 +52,7 @@ (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left exo-type**) ?elems)) =var (&type/resolve-type $var) inferred-type (|case =var (&/$VarT iid) @@ -63,7 +63,8 @@ _ (&type/clean $var tuple-type))] - (return (&/|list (&/T tuple-analysis inferred-type)))))) + (return (&/|list (&&/|meta inferred-type tuple-cursor + tuple-analysis)))))) _ (analyse-tuple analyse (&/V &/$Right exo-type*) ?elems))) @@ -74,23 +75,28 @@ (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] (return =analysis)) ?elems) - _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems)))] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) + _ (&type/check exo-type (&/V &/$TupleT (&/|map &&/expr-type* =elems))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* (&/$TupleT ?members) (|do [=elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) - ?members ?elems)] - (return (&/|list (&/T (&/V &&/$tuple =elems) - exo-type)))) + ?members ?elems) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$tuple =elems) + )))) (&/$UnivQ _) (|do [$var &type/existential exo-type** (&type/apply-type exo-type* $var) - [tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] - (return (&/|list (&/T tuple-analysis exo-type)))) + [[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Right exo-type**) ?elems))] + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))) _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) @@ -146,7 +152,7 @@ (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] - [variant-analysis variant-type] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) + [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] =var (&type/resolve-type $var) ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] @@ -161,7 +167,8 @@ (&type/clean $var variant-type)) ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] ] - (return (&/|list (&/T variant-analysis inferred-type)))))) + (return (&/|list (&&/|meta inferred-type variant-cursor + variant-analysis)))))) _ (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) @@ -188,9 +195,11 @@ (|do [_exo-type (&type/deref+ exo-type)] (fail (str err "\n" 'analyse-variant " " idx " " (&type/show-type exo-type) " " (&type/show-type _exo-type) - " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))))))] - (return (&/|list (&/T (&/V &&/$variant (&/T idx =value)) - exo-type)))) + " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$variant (&/T idx =value)) + )))) (&/$None) (fail (str "[Analyser Error] There is no case " idx " for variant type " (&type/show-type exo-type*)))) @@ -210,9 +219,10 @@ (|do [? (&type/bound? id)] (if ? (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) - (|do [[tuple-analysis tuple-type] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) + (|do [[[tuple-type tuple-cursor] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/V &/$Left rec-type) rec-members)) _ (&type/check exo-type tuple-type)] - (return (&/|list (&/T tuple-analysis exo-type)))))) + (return (&/|list (&&/|meta exo-type tuple-cursor + tuple-analysis)))))) _ (analyse-tuple analyse (&/V &/$Right exo-type) rec-members) @@ -234,9 +244,11 @@ _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - endo-type))))) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + ))))) (defn ^:private analyse-local [analyse exo-type name] (fn [state] @@ -270,9 +282,11 @@ _ (if (and (clojure.lang.Util/identical &type/Type endo-type) (clojure.lang.Util/identical &type/Type exo-type)) (return nil) - (&type/check exo-type endo-type))] - (return (&/|list (&/T (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - endo-type)))) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + )))) state) _ @@ -354,7 +368,7 @@ (defn analyse-apply [analyse exo-type form-cursor =fn ?args] (|do [loader &/loader] - (|let [[=fn-form =fn-type] =fn] + (|let [[[=fn-type =fn-cursor] =fn-form] =fn] (|case =fn-form (&&/$var (&/$Global ?module ?name)) (|do [[real-name $def] (&&module/find-def ?module ?name)] @@ -363,7 +377,7 @@ (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] - ;; :let [_ (when (or (= "invoke-interface$" (aget real-name 1)) + ;; :let [_ (when (or (= "do" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) ;; ) @@ -376,13 +390,15 @@ _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) - =output-t)))))) + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + )))))) _ (|do [[=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&/T (&/V &&/$apply (&/T =fn =args)) - =output-t))))) + (return (&/|list (&&/|meta =output-t =fn-cursor + (&/V &&/$apply (&/T =fn =args)) + ))))) ))) (defn analyse-case [analyse exo-type ?value ?branches] @@ -390,9 +406,11 @@ _ (&/assert! (> num-branches 0) "[Analyser Error] Can't have empty branches in \"case'\" expression.") _ (&/assert! (even? num-branches) "[Analyser Error] Unbalanced branches in \"case'\" expression.") =value (&&/analyse-1+ analyse ?value) - =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches))] - (return (&/|list (&/T (&/V &&/$case (&/T =value =match)) - exo-type))))) + =match (&&case/analyse-branches analyse exo-type (&&/expr-type* =value) (&/|as-pairs ?branches)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$case (&/T =value =match)) + ))))) (defn analyse-lambda* [analyse exo-type ?self ?arg ?body] (|case exo-type @@ -406,7 +424,7 @@ (fn [$input] (&type/with-var (fn [$output] - (|do [[lambda-analysis lambda-type] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) + (|do [[[lambda-type lambda-cursor] lambda-analysis] (analyse-lambda* analyse (&type/Lambda$ $input $output) ?self ?arg ?body) =input (&type/resolve-type $input) =output (&type/resolve-type $output) inferred-type (|case =input @@ -421,9 +439,9 @@ (|do [=output* (&type/clean $input =output) =output** (&type/clean $output =output*)] (return (embed-inferred-input =input =output**)))) - _ (&type/check exo-type inferred-type) - ] - (return (&/T lambda-analysis inferred-type))) + _ (&type/check exo-type inferred-type)] + (return (&&/|meta inferred-type lambda-cursor + lambda-analysis))) )))))) _ @@ -437,8 +455,10 @@ (&/$LambdaT ?arg-t ?return-t) (|do [[=scope =captured =body] (&&lambda/with-lambda ?self exo-type* ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body))] - (return (&/T (&/V &&/$lambda (&/T =scope =captured =body)) exo-type*))) + (&&/analyse-1 analyse ?return-t ?body)) + _cursor &/cursor] + (return (&&/|meta exo-type* _cursor + (&/V &&/$lambda (&/T =scope =captured =body))))) @@ -452,9 +472,10 @@ (&/$UnivQ _) (|do [$var &type/existential exo-type* (&type/apply-type exo-type $var) - [_expr _] (analyse-lambda** analyse exo-type* ?self ?arg ?body)] - (return (&/T _expr exo-type))) - + [_ _expr] (analyse-lambda** analyse exo-type* ?self ?arg ?body) + _cursor &/cursor] + (return (&&/|meta exo-type _cursor _expr))) + (&/$VarT id) (|do [? (&type/bound? id)] (if ? @@ -484,7 +505,7 @@ (|do [=value (&/with-scope ?name (&&/analyse-1+ analyse ?value))] (|case =value - [(&&/$var (&/$Global ?r-module ?r-name)) _] + [_ (&&/$var (&/$Global ?r-module ?r-name))] (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) ;; _ (println)] @@ -501,7 +522,7 @@ ;; (return nil)) ;; (return nil)) :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - [def-analysis def-type] =value + [[def-type def-cursor] def-analysis] =value _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) )]] (return &/Nil$)))) @@ -533,8 +554,7 @@ (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? path) - ;; :let [_ (prn 'analyse-import module-name path - ;; already-compiled?)] + ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] active? (&/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) @@ -554,15 +574,22 @@ (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) + ;; :let [_ (prn 'analyse-check/_0 (&type/show-type ==type))] _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) - ==type))))) + =value (&&/analyse-1 analyse ==type ?value) + ;; :let [_ (prn 'analyse-check/_1 (&/adt->text =value))] + _cursor &/cursor + ] + (return (&/|list (&&/|meta ==type _cursor + (&/V &&/$ann (&/T =value =type)) + ))))) (defn analyse-coerce [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) _ (&type/check exo-type ==type) - =value (&&/analyse-1+ analyse ?value)] - (return (&/|list (&/T (&/V &&/$ann (&/T =value =type)) - ==type))))) + =value (&&/analyse-1+ analyse ?value) + _cursor &/cursor] + (return (&/|list (&&/|meta ==type _cursor + (&/V &&/$ann (&/T =value =type)) + ))))) diff --git a/src/lux/base.clj b/src/lux/base.clj index e57cb0957..19f236ce1 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -132,6 +132,8 @@ (def Nil$ (V $Nil nil)) (defn Cons$ [h t] (V $Cons (T h t))) +(def empty-cursor (T "" -1 -1)) + (defn get$ [slot ^objects record] (aget record slot)) @@ -792,6 +794,11 @@ _ output))))) +(def cursor + ;; (Lux Cursor) + (fn [state] + (return* state (get$ $cursor state)))) + (defn show-ast [ast] ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 048b9ee1d..d89684bcc 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -35,374 +35,388 @@ MethodVisitor))) ;; [Utils/Compilers] +(def ^:private !source->last-line (atom nil)) + (defn ^:private compile-expression [syntax] - (|let [[?form ?type] syntax] - (|case ?form - (&a/$bool ?value) - (&&lux/compile-bool compile-expression ?type ?value) - - (&a/$int ?value) - (&&lux/compile-int compile-expression ?type ?value) - - (&a/$real ?value) - (&&lux/compile-real compile-expression ?type ?value) - - (&a/$char ?value) - (&&lux/compile-char compile-expression ?type ?value) - - (&a/$text ?value) - (&&lux/compile-text compile-expression ?type ?value) - - (&a/$tuple ?elems) - (&&lux/compile-tuple compile-expression ?type ?elems) - - (&a/$var (&/$Local ?idx)) - (&&lux/compile-local compile-expression ?type ?idx) - - (&a/$captured ?scope ?captured-id ?source) - (&&lux/compile-captured compile-expression ?type ?scope ?captured-id ?source) - - (&a/$var (&/$Global ?owner-class ?name)) - (&&lux/compile-global compile-expression ?type ?owner-class ?name) - - (&a/$apply ?fn ?args) - (&&lux/compile-apply compile-expression ?type ?fn ?args) - - (&a/$variant ?tag ?members) - (&&lux/compile-variant compile-expression ?type ?tag ?members) - - (&a/$case ?value ?match) - (&&case/compile-case compile-expression ?type ?value ?match) - - (&a/$lambda ?scope ?env ?body) - (&&lambda/compile-lambda compile-expression ?scope ?env ?body) - - (&a/$ann ?value-ex ?type-ex) - (&&lux/compile-ann compile-expression ?type ?value-ex ?type-ex) - - ;; Characters - (&a/$jvm-ceq ?x ?y) - (&&host/compile-jvm-ceq compile-expression ?type ?x ?y) - - (&a/$jvm-clt ?x ?y) - (&&host/compile-jvm-clt compile-expression ?type ?x ?y) - - (&a/$jvm-cgt ?x ?y) - (&&host/compile-jvm-cgt compile-expression ?type ?x ?y) - - ;; Integer arithmetic - (&a/$jvm-iadd ?x ?y) - (&&host/compile-jvm-iadd compile-expression ?type ?x ?y) - - (&a/$jvm-isub ?x ?y) - (&&host/compile-jvm-isub compile-expression ?type ?x ?y) - - (&a/$jvm-imul ?x ?y) - (&&host/compile-jvm-imul compile-expression ?type ?x ?y) - - (&a/$jvm-idiv ?x ?y) - (&&host/compile-jvm-idiv compile-expression ?type ?x ?y) - - (&a/$jvm-irem ?x ?y) - (&&host/compile-jvm-irem compile-expression ?type ?x ?y) - - (&a/$jvm-ieq ?x ?y) - (&&host/compile-jvm-ieq compile-expression ?type ?x ?y) - - (&a/$jvm-ilt ?x ?y) - (&&host/compile-jvm-ilt compile-expression ?type ?x ?y) - - (&a/$jvm-igt ?x ?y) - (&&host/compile-jvm-igt compile-expression ?type ?x ?y) - - ;; Long arithmetic - (&a/$jvm-ladd ?x ?y) - (&&host/compile-jvm-ladd compile-expression ?type ?x ?y) - - (&a/$jvm-lsub ?x ?y) - (&&host/compile-jvm-lsub compile-expression ?type ?x ?y) - - (&a/$jvm-lmul ?x ?y) - (&&host/compile-jvm-lmul compile-expression ?type ?x ?y) - - (&a/$jvm-ldiv ?x ?y) - (&&host/compile-jvm-ldiv compile-expression ?type ?x ?y) - - (&a/$jvm-lrem ?x ?y) - (&&host/compile-jvm-lrem compile-expression ?type ?x ?y) - - (&a/$jvm-leq ?x ?y) - (&&host/compile-jvm-leq compile-expression ?type ?x ?y) - - (&a/$jvm-llt ?x ?y) - (&&host/compile-jvm-llt compile-expression ?type ?x ?y) - - (&a/$jvm-lgt ?x ?y) - (&&host/compile-jvm-lgt compile-expression ?type ?x ?y) - - ;; Float arithmetic - (&a/$jvm-fadd ?x ?y) - (&&host/compile-jvm-fadd compile-expression ?type ?x ?y) - - (&a/$jvm-fsub ?x ?y) - (&&host/compile-jvm-fsub compile-expression ?type ?x ?y) - - (&a/$jvm-fmul ?x ?y) - (&&host/compile-jvm-fmul compile-expression ?type ?x ?y) - - (&a/$jvm-fdiv ?x ?y) - (&&host/compile-jvm-fdiv compile-expression ?type ?x ?y) - - (&a/$jvm-frem ?x ?y) - (&&host/compile-jvm-frem compile-expression ?type ?x ?y) - - (&a/$jvm-feq ?x ?y) - (&&host/compile-jvm-feq compile-expression ?type ?x ?y) - - (&a/$jvm-flt ?x ?y) - (&&host/compile-jvm-flt compile-expression ?type ?x ?y) - - (&a/$jvm-fgt ?x ?y) - (&&host/compile-jvm-fgt compile-expression ?type ?x ?y) - - ;; Double arithmetic - (&a/$jvm-dadd ?x ?y) - (&&host/compile-jvm-dadd compile-expression ?type ?x ?y) - - (&a/$jvm-dsub ?x ?y) - (&&host/compile-jvm-dsub compile-expression ?type ?x ?y) - - (&a/$jvm-dmul ?x ?y) - (&&host/compile-jvm-dmul compile-expression ?type ?x ?y) - - (&a/$jvm-ddiv ?x ?y) - (&&host/compile-jvm-ddiv compile-expression ?type ?x ?y) - - (&a/$jvm-drem ?x ?y) - (&&host/compile-jvm-drem compile-expression ?type ?x ?y) - - (&a/$jvm-deq ?x ?y) - (&&host/compile-jvm-deq compile-expression ?type ?x ?y) - - (&a/$jvm-dlt ?x ?y) - (&&host/compile-jvm-dlt compile-expression ?type ?x ?y) - - (&a/$jvm-dgt ?x ?y) - (&&host/compile-jvm-dgt compile-expression ?type ?x ?y) - - (&a/$jvm-null _) - (&&host/compile-jvm-null compile-expression ?type) - - (&a/$jvm-null? ?object) - (&&host/compile-jvm-null? compile-expression ?type ?object) - - (&a/$jvm-new ?class ?classes ?args) - (&&host/compile-jvm-new compile-expression ?type ?class ?classes ?args) - - (&a/$jvm-getstatic ?class ?field) - (&&host/compile-jvm-getstatic compile-expression ?type ?class ?field) + ;; (prn 'compile-expression (&/adt->text syntax)) + (|let [[[?type [_file-name _line _column]] ?form] syntax] + (|do [^MethodVisitor *writer* &/get-writer + :let [debug-label (new Label) + _ (when (not= _line (get @!source->last-line _file-name)) + (doto *writer* + (.visitLabel debug-label) + (.visitLineNumber (int _line) debug-label)) + (swap! !source->last-line assoc _file-name _line))]] + (|case ?form + (&a/$bool ?value) + (&&lux/compile-bool compile-expression ?value) + + (&a/$int ?value) + (do ;; (prn 'compile-expression (&/adt->text syntax)) + (&&lux/compile-int compile-expression ?value)) + + (&a/$real ?value) + (&&lux/compile-real compile-expression ?value) + + (&a/$char ?value) + (&&lux/compile-char compile-expression ?value) + + (&a/$text ?value) + (&&lux/compile-text compile-expression ?value) + + (&a/$tuple ?elems) + (&&lux/compile-tuple compile-expression ?elems) + + (&a/$var (&/$Local ?idx)) + (&&lux/compile-local compile-expression ?idx) + + (&a/$captured ?scope ?captured-id ?source) + (&&lux/compile-captured compile-expression ?scope ?captured-id ?source) + + (&a/$var (&/$Global ?owner-class ?name)) + (&&lux/compile-global compile-expression ?owner-class ?name) + + (&a/$apply ?fn ?args) + (&&lux/compile-apply compile-expression ?fn ?args) + + (&a/$variant ?tag ?members) + (&&lux/compile-variant compile-expression ?tag ?members) + + (&a/$case ?value ?match) + (&&case/compile-case compile-expression ?value ?match) + + (&a/$lambda ?scope ?env ?body) + (&&lambda/compile-lambda compile-expression ?scope ?env ?body) + + (&a/$ann ?value-ex ?type-ex) + (&&lux/compile-ann compile-expression ?value-ex ?type-ex) + + ;; Characters + (&a/$jvm-ceq ?x ?y) + (&&host/compile-jvm-ceq compile-expression ?x ?y) + + (&a/$jvm-clt ?x ?y) + (&&host/compile-jvm-clt compile-expression ?x ?y) + + (&a/$jvm-cgt ?x ?y) + (&&host/compile-jvm-cgt compile-expression ?x ?y) + + ;; Integer arithmetic + (&a/$jvm-iadd ?x ?y) + (&&host/compile-jvm-iadd compile-expression ?x ?y) + + (&a/$jvm-isub ?x ?y) + (&&host/compile-jvm-isub compile-expression ?x ?y) + + (&a/$jvm-imul ?x ?y) + (&&host/compile-jvm-imul compile-expression ?x ?y) + + (&a/$jvm-idiv ?x ?y) + (&&host/compile-jvm-idiv compile-expression ?x ?y) + + (&a/$jvm-irem ?x ?y) + (&&host/compile-jvm-irem compile-expression ?x ?y) + + (&a/$jvm-ieq ?x ?y) + (&&host/compile-jvm-ieq compile-expression ?x ?y) + + (&a/$jvm-ilt ?x ?y) + (&&host/compile-jvm-ilt compile-expression ?x ?y) + + (&a/$jvm-igt ?x ?y) + (&&host/compile-jvm-igt compile-expression ?x ?y) + + ;; Long arithmetic + (&a/$jvm-ladd ?x ?y) + (&&host/compile-jvm-ladd compile-expression ?x ?y) + + (&a/$jvm-lsub ?x ?y) + (&&host/compile-jvm-lsub compile-expression ?x ?y) + + (&a/$jvm-lmul ?x ?y) + (&&host/compile-jvm-lmul compile-expression ?x ?y) + + (&a/$jvm-ldiv ?x ?y) + (&&host/compile-jvm-ldiv compile-expression ?x ?y) + + (&a/$jvm-lrem ?x ?y) + (&&host/compile-jvm-lrem compile-expression ?x ?y) + + (&a/$jvm-leq ?x ?y) + (&&host/compile-jvm-leq compile-expression ?x ?y) + + (&a/$jvm-llt ?x ?y) + (&&host/compile-jvm-llt compile-expression ?x ?y) + + (&a/$jvm-lgt ?x ?y) + (&&host/compile-jvm-lgt compile-expression ?x ?y) + + ;; Float arithmetic + (&a/$jvm-fadd ?x ?y) + (&&host/compile-jvm-fadd compile-expression ?x ?y) + + (&a/$jvm-fsub ?x ?y) + (&&host/compile-jvm-fsub compile-expression ?x ?y) + + (&a/$jvm-fmul ?x ?y) + (&&host/compile-jvm-fmul compile-expression ?x ?y) + + (&a/$jvm-fdiv ?x ?y) + (&&host/compile-jvm-fdiv compile-expression ?x ?y) + + (&a/$jvm-frem ?x ?y) + (&&host/compile-jvm-frem compile-expression ?x ?y) + + (&a/$jvm-feq ?x ?y) + (&&host/compile-jvm-feq compile-expression ?x ?y) + + (&a/$jvm-flt ?x ?y) + (&&host/compile-jvm-flt compile-expression ?x ?y) + + (&a/$jvm-fgt ?x ?y) + (&&host/compile-jvm-fgt compile-expression ?x ?y) + + ;; Double arithmetic + (&a/$jvm-dadd ?x ?y) + (&&host/compile-jvm-dadd compile-expression ?x ?y) + + (&a/$jvm-dsub ?x ?y) + (&&host/compile-jvm-dsub compile-expression ?x ?y) + + (&a/$jvm-dmul ?x ?y) + (&&host/compile-jvm-dmul compile-expression ?x ?y) + + (&a/$jvm-ddiv ?x ?y) + (&&host/compile-jvm-ddiv compile-expression ?x ?y) + + (&a/$jvm-drem ?x ?y) + (&&host/compile-jvm-drem compile-expression ?x ?y) + + (&a/$jvm-deq ?x ?y) + (&&host/compile-jvm-deq compile-expression ?x ?y) + + (&a/$jvm-dlt ?x ?y) + (&&host/compile-jvm-dlt compile-expression ?x ?y) + + (&a/$jvm-dgt ?x ?y) + (&&host/compile-jvm-dgt compile-expression ?x ?y) + + (&a/$jvm-null _) + (&&host/compile-jvm-null compile-expression) + + (&a/$jvm-null? ?object) + (&&host/compile-jvm-null? compile-expression ?object) + + (&a/$jvm-new ?class ?classes ?args) + (&&host/compile-jvm-new compile-expression ?class ?classes ?args) + + (&a/$jvm-getstatic ?class ?field ?output-type) + (&&host/compile-jvm-getstatic compile-expression ?class ?field ?output-type) + + (&a/$jvm-getfield ?class ?field ?object ?output-type) + (&&host/compile-jvm-getfield compile-expression ?class ?field ?object ?output-type) - (&a/$jvm-getfield ?class ?field ?object) - (&&host/compile-jvm-getfield compile-expression ?type ?class ?field ?object) + (&a/$jvm-putstatic ?class ?field ?value ?output-type) + (&&host/compile-jvm-putstatic compile-expression ?class ?field ?value) - (&a/$jvm-putstatic ?class ?field ?value) - (&&host/compile-jvm-putstatic compile-expression ?type ?class ?field ?value) + (&a/$jvm-putfield ?class ?field ?value ?object ?output-type) + (&&host/compile-jvm-putfield compile-expression ?class ?field ?object ?value) - (&a/$jvm-putfield ?class ?field ?object ?value) - (&&host/compile-jvm-putfield compile-expression ?type ?class ?field ?object ?value) + (&a/$jvm-invokestatic ?class ?method ?classes ?args ?output-type) + (&&host/compile-jvm-invokestatic compile-expression ?class ?method ?classes ?args ?output-type) - (&a/$jvm-invokestatic ?class ?method ?classes ?args) - (&&host/compile-jvm-invokestatic compile-expression ?type ?class ?method ?classes ?args) + (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokevirtual compile-expression ?class ?method ?classes ?object ?args ?output-type) - (&a/$jvm-invokevirtual ?class ?method ?classes ?object ?args) - (&&host/compile-jvm-invokevirtual compile-expression ?type ?class ?method ?classes ?object ?args) + (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokeinterface compile-expression ?class ?method ?classes ?object ?args ?output-type) - (&a/$jvm-invokeinterface ?class ?method ?classes ?object ?args) - (&&host/compile-jvm-invokeinterface compile-expression ?type ?class ?method ?classes ?object ?args) + (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args ?output-type) + (&&host/compile-jvm-invokespecial compile-expression ?class ?method ?classes ?object ?args ?output-type) + + (&a/$jvm-znewarray ?length) + (&&host/compile-jvm-znewarray compile-expression ?length) - (&a/$jvm-invokespecial ?class ?method ?classes ?object ?args) - (&&host/compile-jvm-invokespecial compile-expression ?type ?class ?method ?classes ?object ?args) - - (&a/$jvm-znewarray ?length) - (&&host/compile-jvm-znewarray compile-expression ?type ?length) + (&a/$jvm-zastore ?array ?idx ?elem) + (&&host/compile-jvm-zastore compile-expression ?array ?idx ?elem) - (&a/$jvm-zastore ?array ?idx ?elem) - (&&host/compile-jvm-zastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-zaload ?array ?idx) + (&&host/compile-jvm-zaload compile-expression ?array ?idx) - (&a/$jvm-zaload ?array ?idx) - (&&host/compile-jvm-zaload compile-expression ?type ?array ?idx) + (&a/$jvm-bnewarray ?length) + (&&host/compile-jvm-bnewarray compile-expression ?length) - (&a/$jvm-bnewarray ?length) - (&&host/compile-jvm-bnewarray compile-expression ?type ?length) + (&a/$jvm-bastore ?array ?idx ?elem) + (&&host/compile-jvm-bastore compile-expression ?array ?idx ?elem) - (&a/$jvm-bastore ?array ?idx ?elem) - (&&host/compile-jvm-bastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-baload ?array ?idx) + (&&host/compile-jvm-baload compile-expression ?array ?idx) - (&a/$jvm-baload ?array ?idx) - (&&host/compile-jvm-baload compile-expression ?type ?array ?idx) + (&a/$jvm-snewarray ?length) + (&&host/compile-jvm-snewarray compile-expression ?length) - (&a/$jvm-snewarray ?length) - (&&host/compile-jvm-snewarray compile-expression ?type ?length) + (&a/$jvm-sastore ?array ?idx ?elem) + (&&host/compile-jvm-sastore compile-expression ?array ?idx ?elem) - (&a/$jvm-sastore ?array ?idx ?elem) - (&&host/compile-jvm-sastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-saload ?array ?idx) + (&&host/compile-jvm-saload compile-expression ?array ?idx) - (&a/$jvm-saload ?array ?idx) - (&&host/compile-jvm-saload compile-expression ?type ?array ?idx) + (&a/$jvm-inewarray ?length) + (&&host/compile-jvm-inewarray compile-expression ?length) - (&a/$jvm-inewarray ?length) - (&&host/compile-jvm-inewarray compile-expression ?type ?length) + (&a/$jvm-iastore ?array ?idx ?elem) + (&&host/compile-jvm-iastore compile-expression ?array ?idx ?elem) - (&a/$jvm-iastore ?array ?idx ?elem) - (&&host/compile-jvm-iastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-iaload ?array ?idx) + (&&host/compile-jvm-iaload compile-expression ?array ?idx) - (&a/$jvm-iaload ?array ?idx) - (&&host/compile-jvm-iaload compile-expression ?type ?array ?idx) + (&a/$jvm-lnewarray ?length) + (&&host/compile-jvm-lnewarray compile-expression ?length) - (&a/$jvm-lnewarray ?length) - (&&host/compile-jvm-lnewarray compile-expression ?type ?length) + (&a/$jvm-lastore ?array ?idx ?elem) + (&&host/compile-jvm-lastore compile-expression ?array ?idx ?elem) - (&a/$jvm-lastore ?array ?idx ?elem) - (&&host/compile-jvm-lastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-laload ?array ?idx) + (&&host/compile-jvm-laload compile-expression ?array ?idx) - (&a/$jvm-laload ?array ?idx) - (&&host/compile-jvm-laload compile-expression ?type ?array ?idx) + (&a/$jvm-fnewarray ?length) + (&&host/compile-jvm-fnewarray compile-expression ?length) - (&a/$jvm-fnewarray ?length) - (&&host/compile-jvm-fnewarray compile-expression ?type ?length) + (&a/$jvm-fastore ?array ?idx ?elem) + (&&host/compile-jvm-fastore compile-expression ?array ?idx ?elem) - (&a/$jvm-fastore ?array ?idx ?elem) - (&&host/compile-jvm-fastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-faload ?array ?idx) + (&&host/compile-jvm-faload compile-expression ?array ?idx) - (&a/$jvm-faload ?array ?idx) - (&&host/compile-jvm-faload compile-expression ?type ?array ?idx) + (&a/$jvm-dnewarray ?length) + (&&host/compile-jvm-dnewarray compile-expression ?length) - (&a/$jvm-dnewarray ?length) - (&&host/compile-jvm-dnewarray compile-expression ?type ?length) + (&a/$jvm-dastore ?array ?idx ?elem) + (&&host/compile-jvm-dastore compile-expression ?array ?idx ?elem) - (&a/$jvm-dastore ?array ?idx ?elem) - (&&host/compile-jvm-dastore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-daload ?array ?idx) + (&&host/compile-jvm-daload compile-expression ?array ?idx) - (&a/$jvm-daload ?array ?idx) - (&&host/compile-jvm-daload compile-expression ?type ?array ?idx) + (&a/$jvm-cnewarray ?length) + (&&host/compile-jvm-cnewarray compile-expression ?length) - (&a/$jvm-cnewarray ?length) - (&&host/compile-jvm-cnewarray compile-expression ?type ?length) + (&a/$jvm-castore ?array ?idx ?elem) + (&&host/compile-jvm-castore compile-expression ?array ?idx ?elem) - (&a/$jvm-castore ?array ?idx ?elem) - (&&host/compile-jvm-castore compile-expression ?type ?array ?idx ?elem) + (&a/$jvm-caload ?array ?idx) + (&&host/compile-jvm-caload compile-expression ?array ?idx) - (&a/$jvm-caload ?array ?idx) - (&&host/compile-jvm-caload compile-expression ?type ?array ?idx) + (&a/$jvm-anewarray ?class ?length) + (&&host/compile-jvm-anewarray compile-expression ?class ?length) - (&a/$jvm-anewarray ?class ?length) - (&&host/compile-jvm-anewarray compile-expression ?type ?class ?length) + (&a/$jvm-aastore ?class ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?class ?array ?idx ?elem) - (&a/$jvm-aastore ?class ?array ?idx ?elem) - (&&host/compile-jvm-aastore compile-expression ?type ?class ?array ?idx ?elem) + (&a/$jvm-aaload ?class ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?class ?array ?idx) - (&a/$jvm-aaload ?class ?array ?idx) - (&&host/compile-jvm-aaload compile-expression ?type ?class ?array ?idx) + (&a/$jvm-arraylength ?array) + (&&host/compile-jvm-arraylength compile-expression ?array) - (&a/$jvm-arraylength ?array) - (&&host/compile-jvm-arraylength compile-expression ?type ?array) + (&a/$jvm-try ?body ?catches ?finally) + (&&host/compile-jvm-try compile-expression ?body ?catches ?finally) - (&a/$jvm-try ?body ?catches ?finally) - (&&host/compile-jvm-try compile-expression ?type ?body ?catches ?finally) + (&a/$jvm-throw ?ex) + (&&host/compile-jvm-throw compile-expression ?ex) - (&a/$jvm-throw ?ex) - (&&host/compile-jvm-throw compile-expression ?type ?ex) + (&a/$jvm-monitorenter ?monitor) + (&&host/compile-jvm-monitorenter compile-expression ?monitor) - (&a/$jvm-monitorenter ?monitor) - (&&host/compile-jvm-monitorenter compile-expression ?type ?monitor) + (&a/$jvm-monitorexit ?monitor) + (&&host/compile-jvm-monitorexit compile-expression ?monitor) - (&a/$jvm-monitorexit ?monitor) - (&&host/compile-jvm-monitorexit compile-expression ?type ?monitor) + (&a/$jvm-d2f ?value) + (&&host/compile-jvm-d2f compile-expression ?value) - (&a/$jvm-d2f ?value) - (&&host/compile-jvm-d2f compile-expression ?type ?value) + (&a/$jvm-d2i ?value) + (&&host/compile-jvm-d2i compile-expression ?value) - (&a/$jvm-d2i ?value) - (&&host/compile-jvm-d2i compile-expression ?type ?value) + (&a/$jvm-d2l ?value) + (&&host/compile-jvm-d2l compile-expression ?value) + + (&a/$jvm-f2d ?value) + (&&host/compile-jvm-f2d compile-expression ?value) - (&a/$jvm-d2l ?value) - (&&host/compile-jvm-d2l compile-expression ?type ?value) - - (&a/$jvm-f2d ?value) - (&&host/compile-jvm-f2d compile-expression ?type ?value) + (&a/$jvm-f2i ?value) + (&&host/compile-jvm-f2i compile-expression ?value) - (&a/$jvm-f2i ?value) - (&&host/compile-jvm-f2i compile-expression ?type ?value) + (&a/$jvm-f2l ?value) + (&&host/compile-jvm-f2l compile-expression ?value) + + (&a/$jvm-i2b ?value) + (&&host/compile-jvm-i2b compile-expression ?value) - (&a/$jvm-f2l ?value) - (&&host/compile-jvm-f2l compile-expression ?type ?value) - - (&a/$jvm-i2b ?value) - (&&host/compile-jvm-i2b compile-expression ?type ?value) + (&a/$jvm-i2c ?value) + (&&host/compile-jvm-i2c compile-expression ?value) - (&a/$jvm-i2c ?value) - (&&host/compile-jvm-i2c compile-expression ?type ?value) + (&a/$jvm-i2d ?value) + (&&host/compile-jvm-i2d compile-expression ?value) - (&a/$jvm-i2d ?value) - (&&host/compile-jvm-i2d compile-expression ?type ?value) + (&a/$jvm-i2f ?value) + (&&host/compile-jvm-i2f compile-expression ?value) - (&a/$jvm-i2f ?value) - (&&host/compile-jvm-i2f compile-expression ?type ?value) + (&a/$jvm-i2l ?value) + (&&host/compile-jvm-i2l compile-expression ?value) - (&a/$jvm-i2l ?value) - (&&host/compile-jvm-i2l compile-expression ?type ?value) + (&a/$jvm-i2s ?value) + (&&host/compile-jvm-i2s compile-expression ?value) - (&a/$jvm-i2s ?value) - (&&host/compile-jvm-i2s compile-expression ?type ?value) + (&a/$jvm-l2d ?value) + (&&host/compile-jvm-l2d compile-expression ?value) - (&a/$jvm-l2d ?value) - (&&host/compile-jvm-l2d compile-expression ?type ?value) + (&a/$jvm-l2f ?value) + (&&host/compile-jvm-l2f compile-expression ?value) - (&a/$jvm-l2f ?value) - (&&host/compile-jvm-l2f compile-expression ?type ?value) + (&a/$jvm-l2i ?value) + (&&host/compile-jvm-l2i compile-expression ?value) - (&a/$jvm-l2i ?value) - (&&host/compile-jvm-l2i compile-expression ?type ?value) + (&a/$jvm-iand ?x ?y) + (&&host/compile-jvm-iand compile-expression ?x ?y) - (&a/$jvm-iand ?x ?y) - (&&host/compile-jvm-iand compile-expression ?type ?x ?y) + (&a/$jvm-ior ?x ?y) + (&&host/compile-jvm-ior compile-expression ?x ?y) - (&a/$jvm-ior ?x ?y) - (&&host/compile-jvm-ior compile-expression ?type ?x ?y) + (&a/$jvm-ixor ?x ?y) + (&&host/compile-jvm-ixor compile-expression ?x ?y) - (&a/$jvm-ixor ?x ?y) - (&&host/compile-jvm-ixor compile-expression ?type ?x ?y) + (&a/$jvm-ishl ?x ?y) + (&&host/compile-jvm-ishl compile-expression ?x ?y) - (&a/$jvm-ishl ?x ?y) - (&&host/compile-jvm-ishl compile-expression ?type ?x ?y) + (&a/$jvm-ishr ?x ?y) + (&&host/compile-jvm-ishr compile-expression ?x ?y) - (&a/$jvm-ishr ?x ?y) - (&&host/compile-jvm-ishr compile-expression ?type ?x ?y) + (&a/$jvm-iushr ?x ?y) + (&&host/compile-jvm-iushr compile-expression ?x ?y) - (&a/$jvm-iushr ?x ?y) - (&&host/compile-jvm-iushr compile-expression ?type ?x ?y) + (&a/$jvm-land ?x ?y) + (&&host/compile-jvm-land compile-expression ?x ?y) - (&a/$jvm-land ?x ?y) - (&&host/compile-jvm-land compile-expression ?type ?x ?y) + (&a/$jvm-lor ?x ?y) + (&&host/compile-jvm-lor compile-expression ?x ?y) - (&a/$jvm-lor ?x ?y) - (&&host/compile-jvm-lor compile-expression ?type ?x ?y) + (&a/$jvm-lxor ?x ?y) + (&&host/compile-jvm-lxor compile-expression ?x ?y) - (&a/$jvm-lxor ?x ?y) - (&&host/compile-jvm-lxor compile-expression ?type ?x ?y) + (&a/$jvm-lshl ?x ?y) + (&&host/compile-jvm-lshl compile-expression ?x ?y) - (&a/$jvm-lshl ?x ?y) - (&&host/compile-jvm-lshl compile-expression ?type ?x ?y) + (&a/$jvm-lshr ?x ?y) + (&&host/compile-jvm-lshr compile-expression ?x ?y) - (&a/$jvm-lshr ?x ?y) - (&&host/compile-jvm-lshr compile-expression ?type ?x ?y) + (&a/$jvm-lushr ?x ?y) + (&&host/compile-jvm-lushr compile-expression ?x ?y) - (&a/$jvm-lushr ?x ?y) - (&&host/compile-jvm-lushr compile-expression ?type ?x ?y) + (&a/$jvm-instanceof ?class ?object) + (&&host/compile-jvm-instanceof compile-expression ?class ?object) - (&a/$jvm-instanceof ?class ?object) - (&&host/compile-jvm-instanceof compile-expression ?type ?class ?object) - ) + _ + (assert false (prn-str 'compile-expression (&/adt->text syntax))) + )) )) (defn ^:private compile-token [syntax] @@ -429,13 +443,15 @@ (&/with-eval (|do [module &/get-module-name id &/gen-id + [file-name _ _] &/cursor :let [class-name (str (&host/->module-class module) "/" id) ;; _ (prn 'eval! id class-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/eval-field "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))))] + (doto (.visitEnd))) + (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitCode *writer*)] @@ -475,7 +491,8 @@ (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/hash-field "I" nil file-hash) .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) - .visitEnd)) + .visitEnd) + (.visitSource file-name nil)) ;; _ (prn 'compile-module name =class) ]] (fn [state] @@ -524,6 +541,7 @@ )) (defn ^:private init! [] + (reset! !source->last-line {}) (.mkdirs (java.io.File. &&/output-dir))) ;; [Resources] diff --git a/src/lux/compiler/case.clj b/src/lux/compiler/case.clj index 5f9d6cd2d..64237f3db 100644 --- a/src/lux/compiler/case.clj +++ b/src/lux/compiler/case.clj @@ -161,7 +161,7 @@ )) ;; [Resources] -(defn compile-case [compile *type* ?value ?matches] +(defn compile-case [compile ?value ?matches] (|do [^MethodVisitor *writer* &/get-writer :let [$end (new Label)] _ (compile ?value) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 2ca613633..179b5423c 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -88,7 +88,7 @@ ;; [Resources] (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer _ (compile ?x) @@ -130,7 +130,7 @@ ) (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer _ (compile ?y) @@ -162,7 +162,7 @@ ) (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [:let [+wrapper-class+ (&host/->class )] ^MethodVisitor *writer* &/get-writer _ (compile ?y) @@ -199,9 +199,9 @@ compile-jvm-dgt Opcodes/FCMPG -1 "java.lang.Double" "doubleValue" "()D" ) -(defn compile-jvm-invokestatic [compile *type* ?class ?method ?classes ?args] +(defn compile-jvm-invokestatic [compile ?class ?method ?classes ?args ?output-type] (|do [^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] @@ -209,14 +209,14 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) (do-template [ ] - (defn [compile *type* ?class ?method ?classes ?object ?args] + (defn [compile ?class ?method ?classes ?object ?args ?output-type] (|do [:let [?class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] _ (&/map2% (fn [class-name arg] @@ -226,7 +226,7 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn ?class* ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL @@ -234,10 +234,10 @@ ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) -(defn compile-jvm-invokespecial [compile *type* ?class ?method ?classes ?object ?args] +(defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] (|do [:let [?class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig *type*))] + :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] :let [_ (when (not= "" ?method) @@ -249,15 +249,15 @@ ?classes ?args) :let [_ (doto *writer* (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) - (prepare-return! *type*))]] + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-null [compile *type*] +(defn compile-jvm-null [compile] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) -(defn compile-jvm-null? [compile *type* ?object] +(defn compile-jvm-null? [compile ?object] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [$then (new Label) @@ -271,7 +271,7 @@ (.visitLabel $end))]] (return nil))) -(defn compile-jvm-new [compile *type* ?class ?classes ?args] +(defn compile-jvm-new [compile ?class ?classes ?args] (|do [^MethodVisitor *writer* &/get-writer :let [init-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")V") class* (&host/->class ?class) @@ -288,14 +288,14 @@ (return nil))) (do-template [ ] - (do (defn [compile *type* ?length] + (do (defn [compile ?length] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?length) :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] (return nil))) - (defn [compile *type* ?array ?idx] + (defn [compile ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -306,7 +306,7 @@ )]] (return nil))) - (defn [compile *type* ?array ?idx ?elem] + (defn [compile ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -330,14 +330,14 @@ Opcodes/T_CHAR compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char ) -(defn compile-jvm-anewarray [compile *type* ?class ?length] +(defn compile-jvm-anewarray [compile ?class ?length] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?length) :let [_ (.visitInsn *writer* Opcodes/L2I)] :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) -(defn compile-jvm-aaload [compile *type* ?class ?array ?idx] +(defn compile-jvm-aaload [compile ?class ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -346,7 +346,7 @@ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) -(defn compile-jvm-aastore [compile *type* ?class ?array ?idx ?elem] +(defn compile-jvm-aastore [compile ?class ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -357,7 +357,7 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-jvm-arraylength [compile *type* ?array] +(defn compile-jvm-arraylength [compile ?array] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -367,36 +367,38 @@ &&/wrap-long)]] (return nil))) -(defn compile-jvm-getstatic [compile *type* ?class ?field] +(defn compile-jvm-getstatic [compile ?class ?field ?output-type] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*)) - (prepare-return! *type*))]] + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-getfield [compile *type* ?class ?field ?object] +(defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] (|do [:let [class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig *type*)) - (prepare-return! *type*))]] + (.visitFieldInsn Opcodes/GETFIELD class* ?field (&host/->java-sig ?output-type)) + (prepare-return! ?output-type))]] (return nil))) -(defn compile-jvm-putstatic [compile *type* ?class ?field ?value] +(defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] + :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) -(defn compile-jvm-putfield [compile *type* ?class ?field ?object ?value] +(defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] (|do [:let [class* (&host/->class (&type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) + :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?value) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig *type*))]] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig ?output-type))]] (return nil))) (defn ^:private modifiers->int [mods] @@ -414,7 +416,7 @@ ;; else 0))) -(defn compile-jvm-instanceof [compile *type* class object] +(defn compile-jvm-instanceof [compile class object] (|do [:let [class* (&host/->class class)] ^MethodVisitor *writer* &/get-writer _ (compile object) @@ -463,7 +465,7 @@ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -474,11 +476,13 @@ (|do [;; :let [_ (prn 'compile-jvm-class/_0)] module &/get-module-name ;; :let [_ (prn 'compile-jvm-class/_1)] + [file-name _ _] &/cursor :let [full-name (str module "/" ?name) super-class* (&host/->class ?super-class) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String)))) + full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) + (.visitSource file-name nil)) _ (&/|map (fn [field] (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) (&host/->type-signature (:type field)) nil nil) @@ -495,15 +499,17 @@ (defn compile-jvm-interface [compile ?name ?supers ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) - (|do [module &/get-module-name] + (|do [module &/get-module-name + [file-name _ _] &/cursor] (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) - (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String)))) + (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String))) + (.visitSource file-name nil)) _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) -(defn compile-jvm-try [compile *type* ?body ?catches ?finally] +(defn compile-jvm-try [compile ?body ?catches ?finally] (|do [^MethodVisitor *writer* &/get-writer :let [$from (new Label) $to (new Label) @@ -555,14 +561,14 @@ :let [_ (.visitLabel *writer* $end)]] (return nil))) -(defn compile-jvm-throw [compile *type* ?ex] +(defn compile-jvm-throw [compile ?ex] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?ex) :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] (return nil))) (do-template [ ] - (defn [compile *type* ?monitor] + (defn [compile ?monitor] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?monitor) :let [_ (doto *writer* @@ -575,7 +581,7 @@ ) (do-template [ ] - (defn [compile *type* ?value] + (defn [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class )) @@ -609,7 +615,7 @@ ) (do-template [ ] - (defn [compile *type* ?x ?y] + (defn [compile ?x ?y] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW (&host/->class )) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 86bc08534..77dc316b8 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -44,7 +44,7 @@ (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq env)]))) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) @@ -82,7 +82,7 @@ (.visitInsn Opcodes/DUP))] _ (&/map% (fn [?name+?captured] (|case ?name+?captured - [?name [(&a/$captured _ _ ?source) _]] + [?name [_ (&a/$captured _ _ ?source)]] (compile ?source))) closed-over) :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL lambda-class "" init-signature)]] @@ -93,7 +93,8 @@ 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)) + (|do [[file-name _ _] &/cursor + :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 @@ -102,8 +103,9 @@ (.visitEnd)) (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) (|case ?name+?captured - [?name [(&a/$captured _ ?captured-id ?source) _]]) + [?name [_ (&a/$captured _ ?captured-id ?source)]]) (doseq [?name+?captured (&/->seq ?env)]))) + (.visitSource file-name nil) (add-lambda-apply class-name ?env) (add-lambda- class-name ?env) )] diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index e85af8b0d..f7cd905e8 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -26,13 +26,13 @@ MethodVisitor))) ;; [Exports] -(defn compile-bool [compile *type* ?value] +(defn compile-bool [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] (return nil))) (do-template [ ] - (defn [compile *type* value] + (defn [compile value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitTypeInsn Opcodes/NEW ) @@ -46,12 +46,12 @@ compile-char "java/lang/Character" "(C)V" char ) -(defn compile-text [compile *type* ?value] +(defn compile-text [compile ?value] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitLdcInsn *writer* ?value)]] (return nil))) -(defn compile-tuple [compile *type* ?elems] +(defn compile-tuple [compile ?elems] (|do [^MethodVisitor *writer* &/get-writer :let [num-elems (&/|length ?elems) _ (doto *writer* @@ -67,7 +67,7 @@ (&/|range num-elems) ?elems)] (return nil))) -(defn compile-variant [compile *type* ?tag ?value] +(defn compile-variant [compile ?tag ?value] ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* @@ -84,12 +84,12 @@ :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) -(defn compile-local [compile *type* ?idx] +(defn compile-local [compile ?idx] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] (return nil))) -(defn compile-captured [compile *type* ?scope ?captured-id ?source] +(defn compile-captured [compile ?scope ?captured-id ?source] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitVarInsn Opcodes/ALOAD 0) @@ -99,12 +99,12 @@ "Ljava/lang/Object;"))]] (return nil))) -(defn compile-global [compile *type* ?owner-class ?name] +(defn compile-global [compile ?owner-class ?name] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&/normalize-name ?name)) &/datum-field "Ljava/lang/Object;")]] (return nil))) -(defn compile-apply [compile *type* ?fn ?args] +(defn compile-apply [compile ?fn ?args] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?fn) _ (&/map% (fn [?arg] @@ -142,10 +142,10 @@ "value" (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) ?def-type (|case ?body - [(&a/$ann ?def-value ?type-expr) ?def-type] + [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)] ?type-expr - [?def-value ?def-type] + [[?def-type ?def-cursor] ?def-value] (&&type/->analysis ?def-type))] (|do [:let [_ (doto **writer** (.visitLdcInsn (int 2)) ;; S @@ -186,6 +186,7 @@ "value")] ^ClassWriter *writer* &/get-writer module-name &/get-module-name + [file-name _ _] &/cursor :let [datum-sig "Ljava/lang/Object;" def-name (&/normalize-name ?name) current-class (str (&host/->module-class module-name) "/" def-name) @@ -197,7 +198,8 @@ (-> (.visitField field-flags &/datum-field datum-sig nil nil) (doto (.visitEnd))) (-> (.visitField field-flags &/meta-field datum-sig nil nil) - (doto (.visitEnd))))] + (doto (.visitEnd))) + (.visitSource file-name nil))] _ (&/with-writer (.visitMethod =class Opcodes/ACC_PUBLIC "" "()V" nil nil) (|do [^MethodVisitor **writer** &/get-writer :let [_ (.visitCode **writer**)] @@ -217,7 +219,7 @@ _ (&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] +(defn compile-ann [compile ?value-ex ?type-ex] (compile ?value-ex)) (defn compile-declare-macro [compile module name] diff --git a/src/lux/compiler/type.clj b/src/lux/compiler/type.clj index 00e66410f..c1615f9b6 100644 --- a/src/lux/compiler/type.clj +++ b/src/lux/compiler/type.clj @@ -13,23 +13,27 @@ ;; [Utils] (defn ^:private variant$ [tag body] "(-> Text Analysis Analysis)" - (&/T (&/V &a/$variant (&/T tag body)) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$variant (&/T tag body)) + )) (defn ^:private tuple$ [members] "(-> (List Analysis) Analysis)" - (&/T (&/V &a/$tuple members) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$tuple members) + )) (defn ^:private int$ [value] "(-> Int Analysis)" - (&/T (&/V &a/$int value) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$int value) + )) (defn ^:private text$ [text] "(-> Text Analysis)" - (&/T (&/V &a/$text text) - &type/$Void)) + (&a/|meta &type/$Void &/empty-cursor + (&/V &a/$text text) + )) (def ^:private $Nil "Analysis" -- cgit v1.2.3 From ceff2a8a5fc4cb701a114071f75367c8b1004887 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 16 Sep 2015 21:10:41 -0400 Subject: - Did a trick to make sure "this" always had the type of the class being defined, instead of the type of the super-class. --- src/lux/analyser/host.clj | 9 ++++--- src/lux/compiler/host.clj | 21 +++------------- src/lux/host.clj | 64 +++++++++++++++++++++++++++++++++++++---------- src/lux/type.clj | 2 -- 4 files changed, 60 insertions(+), 36 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 292d3d4b1..6c15c8bbc 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -425,7 +425,7 @@ _ (fail "[Analyser Error] Wrong syntax for field."))) -(defn ^:private analyse-method [analyse name owner-class method] +(defn ^:private analyse-method [analyse owner-class method] (|case method [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS method-inputs)] @@ -511,10 +511,12 @@ (defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] (&/with-closure (|do [module &/get-module-name + :let [full-name (str module "." name)] ;; :let [_ (prn 'analyse-jvm-class/_0)] =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] - =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + _ (&host/use-dummy-class name super-class interfaces =fields) + =methods (&/map% (partial analyse-method analyse full-name) (&/enumerate methods)) ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] @@ -549,7 +551,8 @@ :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] - =methods (&/map% (partial analyse-method analyse name super-class) (&/enumerate methods)) + _ (&host/use-dummy-class name super-class interfaces (&/|list)) + =methods (&/map% (partial analyse-method analyse anon-class) (&/enumerate methods)) ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 179b5423c..89f830561 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -401,21 +401,6 @@ :let [_ (.visitFieldInsn *writer* Opcodes/PUTFIELD class* ?field (&host/->java-sig ?output-type))]] (return nil))) -(defn ^:private modifiers->int [mods] - (+ (case (:visibility mods) - "default" 0 - "public" Opcodes/ACC_PUBLIC - "private" Opcodes/ACC_PRIVATE - "protected" Opcodes/ACC_PROTECTED) - (if (:static? mods) Opcodes/ACC_STATIC 0) - (if (:final? mods) Opcodes/ACC_FINAL 0) - (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) - (case (:concurrency mods) - "synchronized" Opcodes/ACC_SYNCHRONIZED - "volatile" Opcodes/ACC_VOLATILE - ;; else - 0))) - (defn compile-jvm-instanceof [compile class object] (|do [:let [class* (&host/->class class)] ^MethodVisitor *writer* &/get-writer @@ -432,7 +417,7 @@ ;; (prn 'compile-method/_3 (&/adt->text (:body method))) (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (&/with-writer (.visitMethod class-writer (modifiers->int (:modifiers method)) + (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil nil) (|do [^MethodVisitor =method &/get-writer @@ -447,7 +432,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (modifiers->int (:modifiers method)) (:name method) signature nil nil))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil nil))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] @@ -484,7 +469,7 @@ full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) (.visitSource file-name nil)) _ (&/|map (fn [field] - (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (doto (.visitField =class (&host/modifiers->int (:modifiers field)) (:name field) (&host/->type-signature (:type field)) nil nil) (.visitEnd))) ?fields)] diff --git a/src/lux/host.clj b/src/lux/host.clj index 6be162bf7..d2ade63c7 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -11,7 +11,11 @@ (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type])) (:import (java.lang.reflect Field Method Constructor Modifier) - java.util.regex.Pattern)) + java.util.regex.Pattern + (org.objectweb.asm Opcodes + Label + ClassWriter + MethodVisitor))) ;; [Constants] (def prefix "lux.") @@ -46,18 +50,18 @@ (defn ^:private class->type [^Class class] "(-> Class Type)" (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) - (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] - (let [base (or arr-base simple-base)] - ;; (prn 'class->type/_1 class base arr-brackets) - (let [output-type (if (.equals "void" base) - &type/Unit - (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) - (&type/Data$ base &/Nil$) - (range (count (or arr-brackets "")))) - )] - ;; (prn 'class->type/_2 class (&type/show-type output-type)) - output-type) - )))) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (let [output-type (if (.equals "void" base) + &type/Unit + (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (&type/Data$ base &/Nil$) + (range (count (or arr-brackets "")))) + )] + ;; (prn 'class->type/_2 class (&type/show-type output-type)) + output-type) + )))) (defn ^:private method->type [^Method method] "(-> Method Type)" @@ -186,3 +190,37 @@ (defn location [scope] (->> scope (&/|map &/normalize-name) (&/|interpose "$") (&/fold str ""))) + +(defn modifiers->int [mods] + (+ (case (:visibility mods) + "default" 0 + "public" Opcodes/ACC_PUBLIC + "private" Opcodes/ACC_PRIVATE + "protected" Opcodes/ACC_PROTECTED) + (if (:static? mods) Opcodes/ACC_STATIC 0) + (if (:final? mods) Opcodes/ACC_FINAL 0) + (if (:abstract? mods) Opcodes/ACC_ABSTRACT 0) + (case (:concurrency mods) + "synchronized" Opcodes/ACC_SYNCHRONIZED + "volatile" Opcodes/ACC_VOLATILE + ;; else + 0))) + +(defn use-dummy-class [name super-class interfaces fields] + (|do [module &/get-module-name + :let [full-name (str module "/" name) + =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) + (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) + full-name nil (->class super-class) (->> interfaces (&/|map ->class) &/->seq (into-array String)))) + _ (&/|map (fn [field] + (doto (.visitField =class (modifiers->int (:modifiers field)) (:name field) + (->type-signature (:type field)) nil nil) + (.visitEnd))) + fields) + bytecode (.toByteArray (doto =class .visitEnd))] + loader &/loader + !classes &/classes + :let [real-name (str (->class-name module) "." name) + _ (swap! !classes assoc real-name bytecode) + _ (.loadClass loader real-name)]] + (return nil))) diff --git a/src/lux/type.clj b/src/lux/type.clj index bc28dbde0..24486c85a 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -404,8 +404,6 @@ "\n\nActual: " (show-type actual) "\n")) -;; (def !flag (atom false)) - (defn beta-reduce [env type] ;; (when @!flag ;; (prn 'beta-reduce (show-type type))) -- cgit v1.2.3 From 03bf7b58e6cf45b76b317369aa476443236658f9 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 09:22:21 -0400 Subject: - Both method declarations & method definitions in classes can now include declarations of which exceptions they throw. --- src/lux/analyser/host.clj | 30 ++++++++++++++++++------------ src/lux/compiler/host.clj | 6 ++++-- 2 files changed, 22 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 6c15c8bbc..9d295edda 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -414,8 +414,8 @@ (defn ^:private analyse-field [field] (|case field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Cons [_ (&/$TupleS ?field-modifiers)] + (&/$Cons [_ (&/$TextS ?field-type)] (&/$Nil)))))] (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] (return {:name ?field-name @@ -428,12 +428,14 @@ (defn ^:private analyse-method [analyse owner-class method] (|case method [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons method-body - (&/$Nil)))))))]] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))]] (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] (|case minput [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] @@ -455,6 +457,7 @@ =method-inputs)))] (return {:name method-name :modifiers =method-modifiers + :exceptions =method-exs :inputs (&/|map &/|second =method-inputs) :output method-output :body =method-body})) @@ -465,14 +468,17 @@ (defn ^:private analyse-method-decl [method] (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Nil))))))] + (&/$Cons [_ (&/$TupleS modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Nil)))))))] (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers)] + =modifiers (analyse-modifiers modifiers) + =method-exs (&/map% extract-text method-exs)] (return {:name method-name :modifiers =modifiers + :exceptions =method-exs :inputs =inputs :output output})) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 89f830561..b4858d789 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -419,7 +419,9 @@ (&host/->type-signature (:output method)))] (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) - signature nil nil) + signature + nil + (->> (:exceptions method) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (.visitCode =method)] _ (compile (:body method)) @@ -432,7 +434,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil nil))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) &/->seq (into-array java.lang.String))))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] -- cgit v1.2.3 From 0fbbced7029ae8dc05b63c618bc6dd30aeef8b09 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 16:17:03 -0400 Subject: - Finished some missing bits of class definition analysis. --- src/lux/analyser/host.clj | 54 ++++++++++++++++++++++++++++-------- src/lux/compiler/host.clj | 36 ++++++++++++++++++++++-- src/lux/host.clj | 70 +++++++++++++++++++++++++++++++++++++++++------ src/lux/type.clj | 50 ++++++++++++++++++--------------- 4 files changed, 165 insertions(+), 45 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9d295edda..53ab1de5b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -425,15 +425,45 @@ _ (fail "[Analyser Error] Wrong syntax for field."))) +(defn ^:private dummy-method-desc [method] + (|case method + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))] + (|do [=method-modifiers (analyse-modifiers method-modifiers) + =method-exs (&/map% extract-text method-exs) + =method-inputs (&/map% (fn [minput] + (|case minput + [_ (&/$FormS (&/$Cons [_ (&/$SymbolS "" input-name)] + (&/$Cons [_ (&/$TextS input-type)] + (&/$Nil))))] + (return (&/T input-name input-type)) + + _ + (fail "[Analyser Error] Wrong syntax for method input."))) + method-inputs)] + (return {:name method-name + :modifiers =method-modifiers + :exceptions =method-exs + :inputs (&/|map &/|second =method-inputs) + :output method-output})) + + _ + (fail "[Analyser Error] Wrong syntax for method."))) + (defn ^:private analyse-method [analyse owner-class method] (|case method - [idx [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] - (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))]] + [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] + (&/$Cons [_ (&/$TupleS method-modifiers)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] @@ -521,8 +551,9 @@ ;; :let [_ (prn 'analyse-jvm-class/_0)] =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] - _ (&host/use-dummy-class name super-class interfaces =fields) - =methods (&/map% (partial analyse-method analyse full-name) (&/enumerate methods)) + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces =fields =method-descs) + =methods (&/map% (partial analyse-method analyse full-name) methods) ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] @@ -557,8 +588,9 @@ :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] - _ (&host/use-dummy-class name super-class interfaces (&/|list)) - =methods (&/map% (partial analyse-method analyse anon-class) (&/enumerate methods)) + =method-descs (&/map% dummy-method-desc methods) + _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs) + =methods (&/map% (partial analyse-method analyse anon-class) methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index b4858d789..95d63b0fb 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -410,6 +410,36 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-method-return [writer output] + (case output + "void" (.visitInsn writer Opcodes/RETURN) + "boolean" (doto writer + &&/unwrap-boolean + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + &&/unwrap-byte + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + &&/unwrap-short + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + &&/unwrap-int + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + &&/unwrap-long + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + &&/unwrap-float + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + &&/unwrap-double + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + &&/unwrap-char + (.visitInsn Opcodes/IRETURN)) + ;; else + (.visitInsn writer Opcodes/ARETURN))) + (defn ^:private compile-method [compile class-writer method] ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) @@ -421,12 +451,12 @@ (:name method) signature nil - (->> (:exceptions method) &/->seq (into-array java.lang.String))) + (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer :let [_ (.visitCode =method)] _ (compile (:body method)) :let [_ (doto =method - (.visitInsn (if (= "void" (:output method)) Opcodes/RETURN Opcodes/ARETURN)) + (compile-method-return (:output method)) (.visitMaxs 0 0) (.visitEnd))]] (return nil))))) @@ -434,7 +464,7 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) &/->seq (into-array java.lang.String))))) + (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] diff --git a/src/lux/host.clj b/src/lux/host.clj index d2ade63c7..b05c30ad3 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -68,14 +68,15 @@ (class->type (.getReturnType method))) ;; [Resources] -(defn ^String ->class [class] - (string/replace class (-> class-name-separator Pattern/quote re-pattern) class-separator)) - -(defn ^String ->class-name [module] - (string/replace module (-> module-separator Pattern/quote re-pattern) class-name-separator)) - -(defn ^String ->module-class [module-name] - (string/replace module-name (-> module-separator Pattern/quote re-pattern) class-separator)) +(do-template [ ] + (let [regex (-> Pattern/quote re-pattern)] + (defn [old] + (string/replace old regex ))) + + ^String ->class class-name-separator class-separator + ^String ->class-name module-separator class-name-separator + ^String ->module-class module-separator class-separator + ) (def ->package ->module-class) @@ -206,7 +207,45 @@ ;; else 0))) -(defn use-dummy-class [name super-class interfaces fields] +(let [object-real-class (->class "java.lang.Object")] + (defn ^:private dummy-return [writer name output] + (case output + "void" (if (= "" name) + (doto writer + (.visitVarInsn Opcodes/ALOAD 0) + (.visitMethodInsn Opcodes/INVOKESPECIAL object-real-class "" "()V") + (.visitInsn Opcodes/RETURN)) + (.visitInsn writer Opcodes/RETURN)) + "boolean" (doto writer + (.visitLdcInsn false) + (.visitInsn Opcodes/IRETURN)) + "byte" (doto writer + (.visitLdcInsn (byte 0)) + (.visitInsn Opcodes/IRETURN)) + "short" (doto writer + (.visitLdcInsn (short 0)) + (.visitInsn Opcodes/IRETURN)) + "int" (doto writer + (.visitLdcInsn (int 0)) + (.visitInsn Opcodes/IRETURN)) + "long" (doto writer + (.visitLdcInsn (long 0)) + (.visitInsn Opcodes/LRETURN)) + "float" (doto writer + (.visitLdcInsn (float 0.0)) + (.visitInsn Opcodes/FRETURN)) + "double" (doto writer + (.visitLdcInsn (double 0.0)) + (.visitInsn Opcodes/DRETURN)) + "char" (doto writer + (.visitLdcInsn (char 0)) + (.visitInsn Opcodes/IRETURN)) + ;; else + (doto writer + (.visitInsn Opcodes/ACONST_NULL) + (.visitInsn Opcodes/ARETURN))))) + +(defn use-dummy-class [name super-class interfaces fields methods] (|do [module &/get-module-name :let [full-name (str module "/" name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -217,6 +256,19 @@ (->type-signature (:type field)) nil nil) (.visitEnd))) fields) + _ (&/|map (fn [method] + (|let [signature (str "(" (&/fold str "" (&/|map ->type-signature (:inputs method))) ")" + (->type-signature (:output method)))] + (doto (.visitMethod =class (modifiers->int (:modifiers method)) + (:name method) + signature + nil + (->> (:exceptions method) (&/|map ->class) &/->seq (into-array java.lang.String))) + .visitCode + (dummy-return (:name method) (:output method)) + (.visitMaxs 0 0) + (.visitEnd)))) + methods) bytecode (.toByteArray (doto =class .visitEnd))] loader &/loader !classes &/classes diff --git a/src/lux/type.clj b/src/lux/type.clj index 24486c85a..0495e6b02 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -663,31 +663,37 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT "#Null" (&/$Nil))] - (if (contains? primitive-types e!name) - (fail (str "[Type Error] Can't use \"null\" with primitive types.")) - (return (&/T fixpoints nil))) - [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] - (cond (and (.equals ^Object e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - (return (&/T fixpoints nil))) - - (and (not invariant??) - ;; (do (println '[Data Data] [e!name a!name] - ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) - ;; true) - (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) - (catch Exception e - (prn 'FAILED_HERE e!name a!name)))) + (cond (= "#Null" a!name) + (if (not (contains? primitive-types e!name)) (return (&/T fixpoints nil)) + (fail (check-error expected actual))) - :else - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name)))) + (= "#Null" e!name) + (if (= "#Null" a!name) + (return (&/T fixpoints nil)) + (fail (check-error expected actual))) + + :else + (let [e!name (as-obj e!name) + a!name (as-obj a!name)] + (cond (and (.equals ^Object e!name a!name) + (= (&/|length e!params) (&/|length a!params))) + (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + (return (&/T fixpoints nil))) + + (and (not invariant??) + ;; (do (println '[Data Data] [e!name a!name] + ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") + ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) + ;; true) + (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) + (catch Exception e + (prn 'FAILED_HERE e!name a!name)))) + (return (&/T fixpoints nil)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] -- cgit v1.2.3 From 506ec627005cca8a2e6f7c4fcf374634be3653de Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sat, 26 Sep 2015 18:10:00 -0400 Subject: - Added support for Java annotations. --- src/lux/analyser.clj | 14 ++++--- src/lux/analyser/host.clj | 93 ++++++++++++++++++++++++++++++++++------------- src/lux/compiler.clj | 8 ++-- src/lux/compiler/host.clj | 37 +++++++++++++++---- 4 files changed, 108 insertions(+), 44 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 190b34b03..5659a066e 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -160,18 +160,20 @@ (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TextS ?super-class)] (&/$Cons [_ (&/$TupleS ?interfaces)] - (&/$Cons [_ (&/$TupleS ?fields)] - (&/$Cons [_ (&/$TupleS ?methods)] - (&/$Nil)))))))) + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TupleS ?fields)] + (&/$Cons [_ (&/$TupleS ?methods)] + (&/$Nil))))))))) (|do [=interfaces (&/map% extract-text ?interfaces)] - (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?fields ?methods)) + (&&host/analyse-jvm-class analyse compile-token ?name ?super-class =interfaces ?anns ?fields ?methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_interface")] (&/$Cons [_ (&/$TextS ?name)] (&/$Cons [_ (&/$TupleS ?supers)] - ?methods)))) + (&/$Cons [_ (&/$TupleS ?anns)] + ?methods))))) (|do [=supers (&/map% extract-text ?supers)] - (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?methods)) + (&&host/analyse-jvm-interface analyse compile-token ?name =supers ?anns ?methods)) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anon-class")] (&/$Cons [_ (&/$TextS ?super-class)] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 53ab1de5b..5208b2883 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -411,15 +411,45 @@ :concurrency nil} modifiers)) +(let [failure (fail (str "[Analyser Error] Invalid annotation parameter."))] + (defn ^:private extract-ann-param [param] + (|case param + [[_ (&/$TextS param-name)] param-value] + (|case param-value + [_ (&/$BoolS param-value*)] (return (&/T param-name (boolean param-value*))) + [_ (&/$IntS param-value*)] (return (&/T param-name (int param-value*))) + [_ (&/$RealS param-value*)] (return (&/T param-name (float param-value*))) + [_ (&/$CharS param-value*)] (return (&/T param-name (char param-value*))) + [_ (&/$TextS param-value*)] (return (&/T param-name param-value*)) + + _ + failure) + + _ + failure))) + +(defn ^:private analyse-ann [ann] + (|case ann + [_ (&/$FormS (&/$Cons [_ (&/$TextS ann-name)] (&/$Cons [_ (&/$RecordS ann-params)] (&/$Nil))))] + (|do [=ann-params (&/map% extract-ann-param ann-params)] + (return {:name ann-name + :params ann-params})) + + _ + (fail (str "[Analyser Error] Invalid annotation: " (&/show-ast ann))))) + (defn ^:private analyse-field [field] (|case field [_ (&/$FormS (&/$Cons [_ (&/$TextS ?field-name)] (&/$Cons [_ (&/$TupleS ?field-modifiers)] - (&/$Cons [_ (&/$TextS ?field-type)] - (&/$Nil)))))] - (|do [=field-modifiers (analyse-modifiers ?field-modifiers)] + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TextS ?field-type)] + (&/$Nil))))))] + (|do [=field-modifiers (analyse-modifiers ?field-modifiers) + =anns (&/map% analyse-ann ?anns)] (return {:name ?field-name :modifiers =field-modifiers + :anns =anns :type ?field-type})) _ @@ -429,11 +459,12 @@ (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))] + (&/$Cons [_ (&/$TupleS method-anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil)))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] @@ -448,23 +479,26 @@ method-inputs)] (return {:name method-name :modifiers =method-modifiers + :anns (&/|list) :exceptions =method-exs :inputs (&/|map &/|second =method-inputs) :output method-output})) _ - (fail "[Analyser Error] Wrong syntax for method."))) + (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) (defn ^:private analyse-method [analyse owner-class method] (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS method-modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS method-inputs)] - (&/$Cons [_ (&/$TextS method-output)] - (&/$Cons method-body - (&/$Nil))))))))] + (&/$Cons [_ (&/$TupleS method-anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS method-inputs)] + (&/$Cons [_ (&/$TextS method-output)] + (&/$Cons method-body + (&/$Nil)))))))))] (|do [=method-modifiers (analyse-modifiers method-modifiers) + =anns (&/map% analyse-ann method-anns) =method-exs (&/map% extract-text method-exs) =method-inputs (&/map% (fn [minput] (|case minput @@ -487,27 +521,31 @@ =method-inputs)))] (return {:name method-name :modifiers =method-modifiers + :anns =anns :exceptions =method-exs :inputs (&/|map &/|second =method-inputs) :output method-output :body =method-body})) _ - (fail "[Analyser Error] Wrong syntax for method."))) + (fail (str "[Analyser Error] Wrong syntax for method: " (&/show-ast method))))) (defn ^:private analyse-method-decl [method] (|case method [_ (&/$FormS (&/$Cons [_ (&/$TextS method-name)] (&/$Cons [_ (&/$TupleS modifiers)] - (&/$Cons [_ (&/$TupleS method-exs)] - (&/$Cons [_ (&/$TupleS inputs)] - (&/$Cons [_ (&/$TextS output)] - (&/$Nil)))))))] - (|do [=inputs (&/map% extract-text inputs) - =modifiers (analyse-modifiers modifiers) + (&/$Cons [_ (&/$TupleS ?anns)] + (&/$Cons [_ (&/$TupleS method-exs)] + (&/$Cons [_ (&/$TupleS inputs)] + (&/$Cons [_ (&/$TextS output)] + (&/$Nil))))))))] + (|do [=modifiers (analyse-modifiers modifiers) + =anns (&/map% analyse-ann ?anns) + =inputs (&/map% extract-text inputs) =method-exs (&/map% extract-text method-exs)] (return {:name method-name :modifiers =modifiers + :anns =anns :exceptions =method-exs :inputs =inputs :output output})) @@ -544,11 +582,12 @@ (return nil) (fail (str "[Analyser Error] Missing method: " missing-method))))) -(defn analyse-jvm-class [analyse compile-token name super-class interfaces fields methods] +(defn analyse-jvm-class [analyse compile-token name super-class interfaces anns fields methods] (&/with-closure (|do [module &/get-module-name :let [full-name (str module "." name)] ;; :let [_ (prn 'analyse-jvm-class/_0)] + =anns (&/map% analyse-ann anns) =fields (&/map% analyse-field fields) ;; :let [_ (prn 'analyse-jvm-class/_1)] =method-descs (&/map% dummy-method-desc methods) @@ -557,14 +596,15 @@ ;; :let [_ (prn 'analyse-jvm-class/_2)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-class/_3)] - _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods nil))) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =anns =fields =methods nil))) :let [_ (println 'DEF (str module "." name))]] (return &/Nil$)))) -(defn analyse-jvm-interface [analyse compile-token name supers methods] +(defn analyse-jvm-interface [analyse compile-token name supers anns methods] (|do [module &/get-module-name + =anns (&/map% analyse-ann anns) =methods (&/map% analyse-method-decl methods) - _ (compile-token (&/V &&/$jvm-interface (&/T name supers =methods))) + _ (compile-token (&/V &&/$jvm-interface (&/T name supers =anns =methods))) :let [_ (println 'DEF (str module "." name))]] (return &/Nil$))) @@ -598,6 +638,7 @@ :let [=fields (&/|map (fn [idx+capt] {:name (str &c!base/closure-prefix (aget idx+capt 0)) :modifiers captured-slot-modifier + :anns (&/|list) :type captured-slot-type}) (&/enumerate =captured)) ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) @@ -606,7 +647,7 @@ :let [sources (&/|map captured-source =captured)] ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) - _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces =fields =methods =captured))) + _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) :let [_ (println 'DEF anon-class)] _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index d89684bcc..90b8bcc05 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -430,11 +430,11 @@ (&a/$jvm-program ?body) (&&host/compile-jvm-program compile-expression ?body) - (&a/$jvm-interface ?name ?supers ?methods) - (&&host/compile-jvm-interface compile-expression ?name ?supers ?methods) + (&a/$jvm-interface ?name ?supers ?anns ?methods) + (&&host/compile-jvm-interface compile-expression ?name ?supers ?anns ?methods) - (&a/$jvm-class ?name ?super-class ?interfaces ?fields ?methods ??env) - (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?fields ?methods ??env) + (&a/$jvm-class ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) + (&&host/compile-jvm-class compile-expression ?name ?super-class ?interfaces ?anns ?fields ?methods ??env) _ (compile-expression syntax))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 95d63b0fb..2322b0e32 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -410,6 +410,25 @@ (&&/wrap-boolean))]] (return nil))) +(defn ^:private compile-annotation [writer ann] + (doto (.visitAnnotation writer (&host/->class (:name ann)) true) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) + nil) + +(defn ^:private compile-field [writer field] + (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) + (&host/->type-signature (:type field)) nil nil)] + (&/|map (partial compile-annotation =field) (:anns field)) + (.visitEnd =field) + nil) + ;; (doto (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) + ;; (&host/->type-signature (:type field)) nil nil) + ;; (.visitEnd)) + ) + (defn ^:private compile-method-return [writer output] (case output "void" (.visitInsn writer Opcodes/RETURN) @@ -453,7 +472,8 @@ nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))) (|do [^MethodVisitor =method &/get-writer - :let [_ (.visitCode =method)] + :let [_ (&/|map (partial compile-annotation =method) (:anns method)) + _ (.visitCode =method)] _ (compile (:body method)) :let [_ (doto =method (compile-method-return (:output method)) @@ -464,7 +484,9 @@ (defn ^:private compile-method-decl [class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] - (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String))))) + (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))] + (&/|map (partial compile-annotation =method) (:anns method)) + nil))) (let [clo-field-sig (&host/->type-signature "java.lang.Object") -return "V"] @@ -489,7 +511,7 @@ (.visitEnd))) ) -(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?fields ?methods env] +(defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env] (|do [;; :let [_ (prn 'compile-jvm-class/_0)] module &/get-module-name ;; :let [_ (prn 'compile-jvm-class/_1)] @@ -500,10 +522,8 @@ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) full-name nil super-class* (->> ?interfaces (&/|map &host/->class) &/->seq (into-array String))) (.visitSource file-name nil)) - _ (&/|map (fn [field] - (doto (.visitField =class (&host/modifiers->int (:modifiers field)) (:name field) - (&host/->type-signature (:type field)) nil nil) - (.visitEnd))) + _ (&/|map (partial compile-annotation =class) ?anns) + _ (&/|map (partial compile-field =class) ?fields)] ;; :let [_ (prn 'compile-jvm-class/_2)] _ (&/map% (partial compile-method compile =class) ?methods) @@ -514,7 +534,7 @@ ] (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) -(defn compile-jvm-interface [compile ?name ?supers ?methods] +(defn compile-jvm-interface [compile ?name ?supers ?anns ?methods] ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) (|do [module &/get-module-name [file-name _ _] &/cursor] @@ -522,6 +542,7 @@ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_INTERFACE) (str module "/" ?name) nil "java/lang/Object" (->> ?supers (&/|map &host/->class) &/->seq (into-array String))) (.visitSource file-name nil)) + _ (&/|map (partial compile-annotation =interface) ?anns) _ (do (&/|map (partial compile-method-decl =interface) ?methods) (.visitEnd =interface))] (&&/save-class! ?name (.toByteArray =interface))))) -- cgit v1.2.3 From aa3b52309f2e920688d56b0b00ba12040bf0e841 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 27 Sep 2015 01:07:18 -0400 Subject: - Lux programs can now use libraries for both the JVM (.jar files) and pure Lux code (.tar.gz files). - Fixed a bug regarding indices and loading/storing from/to arrays. --- src/lux.clj | 28 ++++++++---- src/lux/analyser/lux.clj | 4 +- src/lux/base.clj | 1 + src/lux/compiler.clj | 8 ++-- src/lux/compiler/cache.clj | 2 +- src/lux/compiler/host.clj | 16 +++++-- src/lux/compiler/io.clj | 23 ++++++++-- src/lux/compiler/package.clj | 66 --------------------------- src/lux/lib/loader.clj | 55 +++++++++++++++++++++++ src/lux/packager/lib.clj | 40 +++++++++++++++++ src/lux/packager/program.clj | 103 +++++++++++++++++++++++++++++++++++++++++++ 11 files changed, 258 insertions(+), 88 deletions(-) delete mode 100644 src/lux/compiler/package.clj create mode 100644 src/lux/lib/loader.clj create mode 100644 src/lux/packager/lib.clj create mode 100644 src/lux/packager/program.clj (limited to 'src') diff --git a/src/lux.clj b/src/lux.clj index 03d09ebba..8cd2c4b80 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -5,17 +5,29 @@ (ns lux (:gen-class) - (:require [lux.base :as &] + (:require [lux.base :as & :refer [|let |do return fail return* fail* |case]] + [lux.compiler.base :as &compiler-base] [lux.compiler :as &compiler] - :reload-all)) + [lux.packager.lib :as &lib] + :reload-all) + (:import (java.io File))) -(defn -main [& [program-module & _]] - (if program-module - (time (&compiler/compile-program program-module)) - (println "Please provide a module name to compile.")) - (System/exit 0) +(defn -main [& args] + (|case (&/->list args) + (&/$Cons "compile" (&/$Cons program-module (&/$Nil))) + (if program-module + (time (&compiler/compile-program program-module)) + (println "Please provide a module name to compile.")) + + (&/$Cons "lib" (&/$Cons lib-module (&/$Nil))) + (&lib/package lib-module (new File &compiler-base/input-dir)) + + _ + (println "Can't understand command.")) + ;; (System/exit 0) ) (comment - (-main "program") + (-main "compile" "program") + (-main "lib" "lux") ) diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 488b7ae4f..9dd8cecdc 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -558,7 +558,9 @@ active? (&/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) - _ (&/when% (not already-compiled?) (compile-module path))] + _ (if (not already-compiled?) + (compile-module path) + (return nil))] (return &/Nil$))))) (defn analyse-export [analyse compile-token name] diff --git a/src/lux/base.clj b/src/lux/base.clj index 19f236ce1..d8bce5f87 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -118,6 +118,7 @@ (def tags-field "_tags") (def module-class-name "_") (def +name-separator+ ";") +(def lib-dir "lib") (defn T [& elems] (to-array elems)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 90b8bcc05..9e399205f 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -26,9 +26,9 @@ [host :as &&host] [case :as &&case] [lambda :as &&lambda] - [package :as &&package] [module :as &&module] - [io :as &&io])) + [io :as &&io]) + [lux.packager.program :as &packager-program]) (:import (org.objectweb.asm Opcodes Label ClassWriter @@ -473,7 +473,7 @@ (defn ^:private compile-module [name] ;; (prn 'compile-module name (&&cache/cached? name)) - (let [file-name (str &&/input-dir "/" name ".lux")] + (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file file-name) :let [file-hash (hash file-content)]] (if (&&cache/cached? name) @@ -551,7 +551,7 @@ (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state) - (&&package/package program-module)) + (&packager-program/package program-module)) (&/$Left ?message) (assert false ?message))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index d4ce7516d..4f37e8b62 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -89,7 +89,7 @@ ;; _ (prn 'load/IMPORTS module imports) ] (|do [loads (&/map% (fn [_import] - (|do [content (&&io/read-file (str &&/input-dir "/" _import ".lux")) + (|do [content (&&io/read-file (str _import ".lux")) _ (load _import (hash content) compile-module)] (&/cached-module? _import))) (if (= [""] imports) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 2322b0e32..afb3c9a49 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -300,7 +300,9 @@ _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] :let [_ (doto *writer* (.visitInsn ) )]] @@ -312,7 +314,9 @@ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] _ (compile ?elem) :let [_ (doto *writer* @@ -342,7 +346,9 @@ _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) @@ -352,7 +358,9 @@ :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] :let [_ (.visitInsn *writer* Opcodes/DUP)] _ (compile ?idx) - :let [_ (.visitInsn *writer* Opcodes/L2I)] + :let [_ (doto *writer* + &&/unwrap-long + (.visitInsn Opcodes/L2I))] _ (compile ?elem) :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] (return nil))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 93be57f17..d83ec1404 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -5,11 +5,26 @@ (ns lux.compiler.io (:require (lux [base :as & :refer [|let |do return* return fail fail*]]) - )) + (lux.compiler [base :as &&]) + [lux.lib.loader :as &lib])) + +;; [Utils] +(def ^:private !libs (atom nil)) + +(defn ^:private libs-imported? [] + (not (nil? @!libs))) + +(defn ^:private init-libs! [] + (reset! !libs (&lib/load &/lib-dir))) ;; [Resources] -(defn read-file [^String path] - (let [file (new java.io.File path)] +(defn read-file [^String file-name] + ;; (prn 'read-file file-name) + (let [file (new java.io.File (str &&/input-dir "/" file-name))] (if (.exists file) (return (slurp file)) - (fail (str "[I/O Error] File doesn't exist: " path))))) + (do (when (not (libs-imported?)) + (init-libs!)) + (if-let [code (get @!libs file-name)] + (return code) + (fail (str "[I/O Error] File doesn't exist: " file-name))))))) diff --git a/src/lux/compiler/package.clj b/src/lux/compiler/package.clj deleted file mode 100644 index 4f703f5d1..000000000 --- a/src/lux/compiler/package.clj +++ /dev/null @@ -1,66 +0,0 @@ -;; Copyright (c) Eduardo Julian. All rights reserved. -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, -;; You can obtain one at http://mozilla.org/MPL/2.0/. - -(ns lux.compiler.package - (:require [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail fail*]] - [host :as &host]) - (lux.compiler [base :as &&])) - (:import (java.io File - FileInputStream - FileOutputStream - BufferedInputStream) - (java.util.jar Manifest - Attributes$Name - JarEntry - JarOutputStream - ))) - -;; [Utils] -(def ^:private kilobyte 1024) - -(defn ^:private manifest [^String module] - "(-> Text Manifest)" - (doto (new Manifest) - (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) - (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) - -(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] - "(-> Text File JarOutputStream Unit)" - ;; (prn 'write-class! path file) - (with-open [in (new BufferedInputStream (new FileInputStream file))] - (let [buffer (byte-array (* 10 kilobyte))] - (doto out - (.putNextEntry (new JarEntry (str path "/" (.getName file)))) - (-> (.write buffer 0 bytes-read) - (->> (when (not= -1 bytes-read)) - (loop [bytes-read (.read in buffer)]))) - (.flush) - (.closeEntry) - )) - )) - -(let [output-dir-size (.length &&/output-dir)] - (defn ^:private write-module! [^File file ^JarOutputStream out] - "(-> File JarOutputStream Unit)" - (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) - ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) - inner-files (.listFiles file) - inner-modules (filter #(.isDirectory %) inner-files) - inner-classes (filter #(not (.isDirectory %)) inner-files)] - (doseq [$class inner-classes] - (write-class! module-name $class out)) - (doseq [$module inner-modules] - (write-module! $module out))))) - -;; [Resources] -(defn package [module] - "(-> Text (,))" - ;; (prn 'package module) - (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] - (doseq [$group (.listFiles (new File &&/output-dir))] - (write-module! $group out)) - )) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj new file mode 100644 index 000000000..6326fb835 --- /dev/null +++ b/src/lux/lib/loader.clj @@ -0,0 +1,55 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.lib.loader + (:refer-clojure :exclude [load]) + (:require (lux [base :as & :refer [|let |do return fail return* fail* |case]])) + (:import (java.io InputStream + File + FileInputStream + ByteArrayInputStream + ByteArrayOutputStream) + java.util.zip.GZIPInputStream + (org.apache.commons.compress.archivers.tar TarArchiveEntry + TarArchiveInputStream))) + +;; [Utils] +(defn ^:private fetch-libs [from] + (seq (.listFiles (new File from)))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private unpackage [^File lib-file] + (let [is (->> lib-file + (new FileInputStream) + (new GZIPInputStream) + (new TarArchiveInputStream))] + (loop [lib-data {} + entry (.getNextTarEntry is)] + (if entry + (recur (assoc lib-data (.getName entry) (new String (read-stream is))) + (.getNextTarEntry is)) + lib-data)))) + +;; [Exports] +(def lib-ext ".tar.gz") + +(defn load [from] + (reduce merge {} + (for [lib (fetch-libs from)] + (unpackage lib)))) + +(comment + (->> &/lib-dir load keys) + ) diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj new file mode 100644 index 000000000..41f3143a0 --- /dev/null +++ b/src/lux/packager/lib.clj @@ -0,0 +1,40 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.packager.lib + (:require [lux.lib.loader :as &lib]) + (:import (java.io File + FileOutputStream) + java.util.zip.GZIPOutputStream + (org.apache.commons.compress.archivers.tar TarArchiveEntry + TarArchiveOutputStream) + )) + +;; [Utils] +(defn ^:private read-file [file] + (with-open [is (java.io.FileInputStream. file)] + (let [data (byte-array (.length file))] + (.read is data) + data))) + +(defn ^:private add-to-tar! [prefix ^File file os] + "(-> Text File TarArchiveOutputStream Unit)" + (let [file-name (str prefix "/" (.getName file))] + (if (.isDirectory file) + (doseq [file (seq (.listFiles file))] + (add-to-tar! file-name file os)) + (doto os + (.putArchiveEntry (doto (new TarArchiveEntry file-name) + (.setSize (.length file)))) + (.write (read-file file)) + (.closeArchiveEntry))))) + +;; [Exports] +(defn package [output-lib-name ^File source-dir] + "(-> Text File Unit)" + (with-open [out (->> (str output-lib-name &lib/lib-ext) (new FileOutputStream) (new GZIPOutputStream) (new TarArchiveOutputStream))] + (doseq [file (seq (.listFiles source-dir))] + (add-to-tar! "" file out)) + )) diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj new file mode 100644 index 000000000..7337bcb02 --- /dev/null +++ b/src/lux/packager/program.clj @@ -0,0 +1,103 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.packager.program + (:require [clojure.core.match :as M :refer [matchv]] + clojure.core.match.array + (lux [base :as & :refer [|let |do return* return fail fail*]] + [host :as &host]) + (lux.compiler [base :as &&])) + (:import (java.io InputStream + File + FileInputStream + FileOutputStream + BufferedInputStream + ByteArrayOutputStream) + (java.util.jar Manifest + Attributes$Name + JarEntry + JarInputStream + JarOutputStream + ))) + +;; [Utils] +(def ^:private kilobyte 1024) + +(defn ^:private manifest [^String module] + "(-> Text Manifest)" + (doto (new Manifest) + (-> .getMainAttributes (doto (.put Attributes$Name/MAIN_CLASS (str (&host/->module-class module) "._")) + (.put Attributes$Name/MANIFEST_VERSION "1.0"))))) + +(defn ^:private write-class! [^String path ^File file ^JarOutputStream out] + "(-> Text File JarOutputStream Unit)" + ;; (prn 'write-class! path file) + (with-open [in (new BufferedInputStream (new FileInputStream file))] + (let [buffer (byte-array (* 10 kilobyte))] + (doto out + (.putNextEntry (new JarEntry (str path "/" (.getName file)))) + (-> (.write buffer 0 bytes-read) + (->> (when (not= -1 bytes-read)) + (loop [bytes-read (.read in buffer)]))) + (.flush) + (.closeEntry) + )) + )) + +(let [output-dir-size (.length &&/output-dir)] + (defn ^:private write-module! [^File file ^JarOutputStream out] + "(-> File JarOutputStream Unit)" + (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) + ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) + inner-files (.listFiles file) + inner-modules (filter #(.isDirectory ^File %) inner-files) + inner-classes (filter #(not (.isDirectory ^File %)) inner-files)] + (doseq [$class inner-classes] + (write-class! module-name $class out)) + (doseq [$module inner-modules] + (write-module! $module out))))) + +(defn ^:private fetch-available-jars [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".jar")))) + +(let [init-capacity (* 100 1024) + buffer-size 1024] + (defn ^:private ^"[B" read-stream [^InputStream is] + (let [buffer (byte-array buffer-size)] + (with-open [os (new ByteArrayOutputStream init-capacity)] + (loop [bytes-read (.read is buffer 0 buffer-size)] + (when (not= -1 bytes-read) + (do (.write os buffer 0 bytes-read) + (recur (.read is buffer 0 buffer-size))))) + (.toByteArray os))))) + +(defn ^:private add-jar! [^File jar-file ^JarOutputStream out] + (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] + (loop [^JarEntry entry (.getNextJarEntry is)] + (when entry + ;; (prn 'add-jar! (.getName entry) (.isDirectory entry)) + (when (and (not (.isDirectory entry)) + (not (.startsWith (.getName entry) "META-INF/"))) + (let [entry-data (read-stream is)] + (doto out + (.putNextEntry entry) + (.write entry-data 0 (alength entry-data)) + (.flush) + (.closeEntry)))) + (recur (.getNextJarEntry is)))))) + +;; [Resources] +(defn package [module] + "(-> Text (,))" + ;; (prn 'package module) + (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] + (doseq [$group (.listFiles (new File &&/output-dir))] + (write-module! $group out)) + (doseq [^String jar-file (fetch-available-jars)] + (add-jar! (new File jar-file) out)) + )) -- cgit v1.2.3 From f829e62d2102a60244b9f0950240dc71f74cccff Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 27 Sep 2015 18:59:38 -0400 Subject: - Added support for type-checking generic classes. - Added support for instancing generic objects. --- src/lux/analyser.clj | 10 ++- src/lux/analyser/host.clj | 75 +++++++++++++++++---- src/lux/base.clj | 12 ++++ src/lux/compiler/host.clj | 15 +++-- src/lux/compiler/io.clj | 2 +- src/lux/host.clj | 77 +++++++++------------- src/lux/lib/loader.clj | 17 +++-- src/lux/type.clj | 38 +++-------- src/lux/type/host.clj | 162 ++++++++++++++++++++++++++++++++++++++++++++++ 9 files changed, 305 insertions(+), 103 deletions(-) create mode 100644 src/lux/type/host.clj (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 5659a066e..0aa883c23 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -68,7 +68,7 @@ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) ))) -(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] +(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) @@ -155,6 +155,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) (&&host/analyse-jvm-arraylength analyse ?array) + _ + (do (prn 'aba8 (&/adt->text token)) + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token)))))))) + +(defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] + (|case token ;; Classes & interfaces (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_class")] (&/$Cons [_ (&/$TextS ?name)] @@ -191,7 +197,7 @@ (&&host/analyse-jvm-program analyse compile-token ?args ?body) _ - (fail ""))) + (aba8 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 5208b2883..9490c37c8 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -11,10 +11,12 @@ [parser :as &parser] [type :as &type] [host :as &host]) + [lux.type.host :as &host-type] (lux.analyser [base :as &&] [lambda :as &&lambda] [env :as &&env]) - [lux.compiler.base :as &c!base])) + [lux.compiler.base :as &c!base]) + (:import (java.lang.reflect TypeVariable))) ;; [Utils] (defn ^:private extract-text [ast] @@ -80,7 +82,7 @@ "(-> Type Type)" (|case type (&/$DataT class params) - (&type/Data$ (&type/as-obj class) params) + (&type/Data$ (&host-type/as-obj class) params) _ type)) @@ -279,19 +281,68 @@ (&/V &&/$jvm-null? =object)))))) (defn analyse-jvm-null [analyse exo-type] - (|do [:let [output-type (&type/Data$ &host/null-data-tag &/Nil$)] + (|do [:let [output-type (&type/Data$ &host-type/null-data-tag &/Nil$)] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-null nil)))))) +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T idx real-type))) + (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T idx* (&/Cons$ real-type types))))) + (&/T 0 (&/|list)) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&type/Univ$ &type/empty-env base-type) + + _ + base-type)) + (&type/Data$ class-name type-args) + type-args)) + +(defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + ;; :let [_ (prn 'analyse-jvm-new-helper/_0 gtype) + ;; _ (prn 'analyse-jvm-new-helper/_1 gtype (->> arg-types (&/|map &type/show-type) &/->seq)) + ;; _ (prn 'analyse-jvm-new-helper/_2 gtype (->> args (&/|map &/show-ast) &/->seq))] + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] + (return (&/T (make-gtype gtype gtype-vars*) + =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + ;; (prn 'analyse-jvm-new-helper gtype gtv $var (&/|length gtype-vars) (&/|length gtype-args)) + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) + )) + (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader - [=return exceptions] (&host/lookup-constructor class-loader class classes) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) + [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) + ;; :let [_ (prn 'analyse-jvm-new class (&/->seq gvars) (&/->seq gargs))] _ (ensure-catching exceptions) - :let [output-type (&type/Data$ class &/Nil$)] + [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) + ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor @@ -299,7 +350,7 @@ (do-template [ ] (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type)) + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) length-type &type/Int idx-type &type/Int] (defn [analyse length] @@ -338,7 +389,7 @@ idx-type &type/Int] (defn analyse-jvm-anewarray [analyse class length] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=length (&&/analyse-1 analyse length-type length) _cursor &/cursor] (return (&/|list (&&/|meta array-type _cursor @@ -346,7 +397,7 @@ (defn analyse-jvm-aaload [analyse class array idx] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) _cursor &/cursor] @@ -355,7 +406,7 @@ (defn analyse-jvm-aastore [analyse class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) @@ -368,7 +419,7 @@ (&type/with-var (fn [$var] (let [elem-type $var - array-type (&type/Data$ &host/array-data-tag (&/|list elem-type))] + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) _cursor &/cursor] (return (&/|list (&&/|meta length-type _cursor diff --git a/src/lux/base.clj b/src/lux/base.clj index d8bce5f87..d76348b9a 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -987,3 +987,15 @@ flag-compiled-module compiled-module? $Compiled flag-cached-module cached-module? $Cached ) + +(do-template [ ] + (defn [p xs] + (|case xs + ($Nil) + + + ($Cons x xs*) + ( (p x) (|every? p xs*)))) + + |every? true and + |any? false or) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index afb3c9a49..7f7509998 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -15,6 +15,7 @@ [parser :as &parser] [analyser :as &analyser] [host :as &host]) + [lux.type.host :as &host-type] [lux.analyser.base :as &a] [lux.compiler.base :as &&] :reload) @@ -208,13 +209,13 @@ (return ret))) ?classes ?args) :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&type/as-obj ?class)) ?method method-sig) + (.visitMethodInsn Opcodes/INVOKESTATIC (&host/->class (&host-type/as-obj ?class)) ?method method-sig) (prepare-return! ?output-type))]] (return nil))) (do-template [ ] (defn [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) @@ -235,7 +236,7 @@ ) (defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&type/as-obj ?class))] + (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) @@ -378,12 +379,12 @@ (defn compile-jvm-getstatic [compile ?class ?field ?output-type] (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) + (.visitFieldInsn Opcodes/GETSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type)) (prepare-return! ?output-type))]] (return nil))) (defn compile-jvm-getfield [compile ?class ?field ?object ?output-type] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (doto *writer* @@ -395,12 +396,12 @@ (defn compile-jvm-putstatic [compile ?class ?field ?value ?output-type] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?value) - :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] + :let [_ (.visitFieldInsn *writer* Opcodes/PUTSTATIC (&host/->class (&host-type/as-obj ?class)) ?field (&host/->java-sig ?output-type))] :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] (return nil))) (defn compile-jvm-putfield [compile ?class ?field ?object ?value ?output-type] - (|do [:let [class* (&host/->class (&type/as-obj ?class))] + (|do [:let [class* (&host/->class (&host-type/as-obj ?class))] ^MethodVisitor *writer* &/get-writer _ (compile ?object) :let [_ (.visitInsn *writer* Opcodes/DUP)] diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index d83ec1404..4cd6284b7 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -15,7 +15,7 @@ (not (nil? @!libs))) (defn ^:private init-libs! [] - (reset! !libs (&lib/load &/lib-dir))) + (reset! !libs (&lib/load))) ;; [Resources] (defn read-file [^String file-name] diff --git a/src/lux/host.clj b/src/lux/host.clj index b05c30ad3..74a8af66a 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -9,7 +9,8 @@ clojure.core.match clojure.core.match.array (lux [base :as & :refer [|do return* return fail fail* |let |case]] - [type :as &type])) + [type :as &type]) + [lux.type.host :as &host-type]) (:import (java.lang.reflect Field Method Constructor Modifier) java.util.regex.Pattern (org.objectweb.asm Opcodes @@ -23,30 +24,10 @@ (def module-separator "/") (def class-name-separator ".") (def class-separator "/") -(def array-data-tag "#Array") -(def null-data-tag "#Null") ;; [Utils] (def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") -(comment - (let [class (class (to-array []))] - (str (if-let [pkg (.getPackage class)] - (str (.getName pkg) ".") - "") - (.getSimpleName class))) - - (.getName String) "java.lang.String" - - (.getName (class (to-array []))) "[Ljava.lang.Object;" - - (re-find class-name-re "java.lang.String") - ["java.lang.String" "java.lang.String" nil nil "java.lang.String"] - - (re-find class-name-re "[Ljava.lang.Object;") - ["[Ljava.lang.Object;" "[Ljava.lang.Object;" "[" "java.lang.Object" nil] - ) - (defn ^:private class->type [^Class class] "(-> Class Type)" (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) @@ -55,7 +36,7 @@ ;; (prn 'class->type/_1 class base arr-brackets) (let [output-type (if (.equals "void" base) &type/Unit - (reduce (fn [inner _] (&type/Data$ array-data-tag (&/|list inner))) + (reduce (fn [inner _] (&type/Data$ &host-type/array-data-tag (&/|list inner))) (&type/Data$ base &/Nil$) (range (count (or arr-brackets "")))) )] @@ -113,16 +94,16 @@ "(-> Type Text)" (|case type (&/$DataT ?name params) - (cond (= array-data-tag ?name) (|let [[level base] (unfold-array type) - base-sig (|case base - (&/$DataT base-class _) - (->class base-class) - - _ - (->java-sig base))] - (str (->> (&/|repeat level "[") (&/fold str "")) - "L" base-sig ";")) - (= null-data-tag ?name) (->type-signature "java.lang.Object") + (cond (= &host-type/array-data-tag ?name) (|let [[level base] (unfold-array type) + base-sig (|case base + (&/$DataT base-class _) + (->class base-class) + + _ + (->java-sig base))] + (str (->> (&/|repeat level "[") (&/fold str "")) + "L" base-sig ";")) + (= &host-type/null-data-tag ?name) (->type-signature "java.lang.Object") :else (->type-signature ?name)) (&/$LambdaT _ _) @@ -140,7 +121,7 @@ (do-template [ ] (defn [class-loader target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&type/as-obj target) true class-loader)) + (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object field (.getName =field)) (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] (.getType =field)))] @@ -154,7 +135,7 @@ (do-template [ ] (defn [class-loader target method-name args] ;; (prn ' target method-name) - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj target) true class-loader)) + (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) (.equals ^Object (Modifier/isStatic (.getModifiers =method))) (let [param-types (&/->list (seq (.getParameterTypes =method)))] @@ -172,20 +153,24 @@ ) (defn lookup-constructor [class-loader target args] - ;; (prn 'lookup-constructor class-loader target (&type/as-obj target)) - (if-let [ctor (first (for [^Constructor =method (.getDeclaredConstructors (Class/forName (&type/as-obj target) true class-loader)) - :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types))))] - =method))] - (return (&/T &type/Unit (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %))))) - (fail (str "[Host Error] Constructor does not exist: " target)))) + ;; (prn 'lookup-constructor class-loader target (&host-type/as-obj target)) + (let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) + :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types))))] + =method))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list) + gargs (->> ctor .getGenericParameterTypes seq &/->list) + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %)))] + (return (&/T exs gvars gargs))) + (fail (str "[Host Error] Constructor does not exist: " target))))) (defn abstract-methods [class-loader class] - (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&type/as-obj class) true class-loader)) + (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) diff --git a/src/lux/lib/loader.clj b/src/lux/lib/loader.clj index 6326fb835..13810238a 100644 --- a/src/lux/lib/loader.clj +++ b/src/lux/lib/loader.clj @@ -16,8 +16,13 @@ TarArchiveInputStream))) ;; [Utils] -(defn ^:private fetch-libs [from] - (seq (.listFiles (new File from)))) +(defn ^:private fetch-libs [] + (->> ^java.net.URLClassLoader (ClassLoader/getSystemClassLoader) + (.getURLs) + seq + (map #(.getFile ^java.net.URL %)) + (filter #(.endsWith ^String % ".tar.gz")) + (map #(new File ^String %)))) (let [init-capacity (* 100 1024) buffer-size 1024] @@ -45,10 +50,10 @@ ;; [Exports] (def lib-ext ".tar.gz") -(defn load [from] - (reduce merge {} - (for [lib (fetch-libs from)] - (unpackage lib)))) +(defn load [] + (->> (fetch-libs) + (map unpackage) + (reduce merge {}))) (comment (->> &/lib-dir load keys) diff --git a/src/lux/type.clj b/src/lux/type.clj index 0495e6b02..723e169c4 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -7,7 +7,8 @@ (:refer-clojure :exclude [deref apply merge bound?]) (:require clojure.core.match clojure.core.match.array - [lux.base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]]) + [lux.type.host :as &&host])) (declare show-type) @@ -23,7 +24,7 @@ _ false)) -(def ^:private empty-env &/Nil$) +(def empty-env &/Nil$) (defn Data$ [name params] (&/V &/$DataT (&/T name params))) (defn Bound$ [idx] @@ -463,21 +464,6 @@ _ (fail (str "[Type System] Not a type function:\n" (show-type type-fn) "\n")))) -(defn as-obj [class] - (case class - "boolean" "java.lang.Boolean" - "byte" "java.lang.Byte" - "short" "java.lang.Short" - "int" "java.lang.Integer" - "long" "java.lang.Long" - "float" "java.lang.Float" - "double" "java.lang.Double" - "char" "java.lang.Character" - ;; else - class)) - -(def ^:private primitive-types #{"boolean" "byte" "short" "int" "long" "float" "double" "char"}) - (def ^:private init-fixpoints &/Nil$) (defn ^:private check* [class-loader fixpoints invariant?? expected actual] @@ -665,7 +651,7 @@ [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] (cond (= "#Null" a!name) - (if (not (contains? primitive-types e!name)) + (if (not (&&host/primitive-type? e!name)) (return (&/T fixpoints nil)) (fail (check-error expected actual))) @@ -675,22 +661,16 @@ (fail (check-error expected actual))) :else - (let [e!name (as-obj e!name) - a!name (as-obj a!name)] + (let [e!name (&&host/as-obj e!name) + a!name (&&host/as-obj a!name)] (cond (and (.equals ^Object e!name a!name) (= (&/|length e!params) (&/|length a!params))) (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] (return (&/T fixpoints nil))) - (and (not invariant??) - ;; (do (println '[Data Data] [e!name a!name] - ;; [(str "(" (->> e!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - ;; (str "(" (->> a!params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")]) - ;; true) - (try (.isAssignableFrom (Class/forName e!name true class-loader) (Class/forName a!name true class-loader)) - (catch Exception e - (prn 'FAILED_HERE e!name a!name)))) - (return (&/T fixpoints nil)) + (not invariant??) + (|do [actual& (&&host/->super-type existential class-loader e!name a!name a!params)] + (check* class-loader fixpoints invariant?? expected actual&)) :else (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj new file mode 100644 index 000000000..486205494 --- /dev/null +++ b/src/lux/type/host.clj @@ -0,0 +1,162 @@ +;; Copyright (c) Eduardo Julian. All rights reserved. +;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. +;; If a copy of the MPL was not distributed with this file, +;; You can obtain one at http://mozilla.org/MPL/2.0/. + +(ns lux.type.host + (:require clojure.core.match + clojure.core.match.array + (lux [base :as & :refer [|do return* return fail fail* assert! |let |case]])) + (:import (java.lang.reflect GenericArrayType + ParameterizedType + TypeVariable + WildcardType))) + +;; [Exports] +(def array-data-tag "#Array") +(def null-data-tag "#Null") + +;; [Utils] +(defn ^:private Data$ [name params] + (&/V &/$DataT (&/T name params))) + +(defn ^:private trace-lineage* [^Class super-class ^Class sub-class] + "(-> Class Class (List Class))" + ;; Either they're both interfaces, of they're both classes + (cond (.isInterface sub-class) + (let [interface<=interface? #(if (or (= super-class %) + (.isAssignableFrom super-class %)) + % + nil)] + (loop [sub-class sub-class + stack (&/|list)] + (let [super-interface (some interface<=interface? + (.getInterfaces sub-class))] + (if (= super-class super-interface) + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack))))))) + + (.isInterface super-class) + (let [class<=interface? #(if (= super-class %) % nil)] + (loop [sub-class sub-class + stack (&/|list)] + (if-let [super-interface (some class<=interface? (.getInterfaces sub-class))] + (&/Cons$ super-interface stack) + (let [super* (.getSuperclass sub-class)] + (recur super* (&/Cons$ super* stack)))))) + + :else + (loop [sub-class sub-class + stack (&/|list)] + (let [super* (.getSuperclass sub-class)] + (if (= super* super-class) + (&/Cons$ super* stack) + (recur super* (&/Cons$ super* stack))))))) + +(defn ^:private trace-lineage [^Class sub-class ^Class super-class] + "(-> Class Class (List Class))" + (&/|reverse (trace-lineage* super-class sub-class))) + +(let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))] + (defn ^:private match-params [sub-type-params params] + (assert (and (= (&/|length sub-type-params) (&/|length params)) + (&/|every? (partial instance? TypeVariable) sub-type-params))) + (&/fold2 matcher (&/|table) sub-type-params params))) + +;; [Exports] +(defn instance-param [existential matchings refl-type] + "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" + ;; (prn 'instance-param refl-type (class refl-type)) + (cond (instance? Class refl-type) + (return (Data$ (.getName ^Class refl-type) (&/|list))) + + (instance? GenericArrayType refl-type) + (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] + (return (Data$ array-data-tag (&/|list inner-type)))) + + (instance? ParameterizedType refl-type) + (|do [:let [refl-type* ^ParameterizedType refl-type] + params* (->> refl-type* + .getActualTypeArguments + seq &/->list + (&/map% (partial instance-param existential matchings)))] + (return (Data$ (->> refl-type* ^Class (.getRawType) .getName) + params*))) + + (instance? TypeVariable refl-type) + (let [gvar (.getName ^TypeVariable refl-type)] + (if-let [m-type (&/|get gvar matchings)] + (return m-type) + (fail (str "[Type Error] Unknown generic type variable: " gvar)))) + + (instance? WildcardType refl-type) + (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] + (instance-param existential matchings bound) + existential))) + +;; [Utils] +(defn ^:private translate-params [existential super-type-params sub-type-params params] + "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" + (|let [matchings (match-params sub-type-params params)] + (&/map% (partial instance-param existential matchings) super-type-params))) + +(defn ^:private raise* [existential sub+params super] + "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" + (|let [[^Class sub params] sub+params] + (if (.isInterface super) + (|do [:let [super-params (->> sub + .getGenericInterfaces + (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) + (if (instance? Class %) (&/|list) (->> % .getActualTypeArguments seq &/->list)) + nil)))] + params* (translate-params existential + super-params + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + (let [super* (.getGenericSuperclass sub)] + (cond (instance? Class super*) + (return (&/T super* (&/|list))) + + (instance? ParameterizedType super*) + (|do [params* (translate-params existential + (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) + (->> sub .getTypeParameters seq &/->list) + params)] + (return (&/T super params*))) + + :else + (assert false (prn-str super* (class super*) [sub super]))))))) + +(defn ^:private raise [existential lineage class params] + "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" + (&/fold% (partial raise* existential) (&/T class params) lineage)) + +;; [Exports] +(defn ->super-type [existential class-loader super-class sub-class sub-params] + "(-> Text Text (List Type) (Lux Type))" + (let [super-class+ (Class/forName super-class true class-loader) + sub-class+ (Class/forName sub-class true class-loader)] + (if (.isAssignableFrom super-class+ sub-class+) + (let [lineage (trace-lineage sub-class+ super-class+)] + (|do [[sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (Data$ (.getName sub-class*) sub-params*)))) + (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " text token)) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9490c37c8..cf361da22 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -69,14 +69,23 @@ output))))) )) -(defn ^:private ensure-object [token] - "(-> Analysis (Lux (,)))" - (|case token - [_ (&/$DataT _ _)] - (return nil) +(defn ^:private ensure-object [type] + "(-> Type (Lux (, Text (List Type))))" + (|case type + (&/$DataT payload) + (return payload) + + (&/$NamedT _ type*) + (ensure-object type*) + + (&/$UnivQ _ type*) + (ensure-object type*) + + (&/$ExQ _ type*) + (ensure-object type*) _ - (fail "[Analyser Error] Expecting object"))) + (fail (str "[Analyser Error] Expecting object: " (&type/show-type type))))) (defn ^:private as-object [type] "(-> Type Type)" @@ -110,6 +119,35 @@ _ type)) +(defn ^:private clean-gtype-var [idx gtype-var] + (|let [(&/$VarT id) gtype-var] + (|do [? (&type/bound? id)] + (if ? + (|do [real-type (&type/deref id)] + (return (&/T idx real-type))) + (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) + +(defn ^:private clean-gtype-vars [gtype-vars] + (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] + (|do [:let [[idx types] idx+types] + [idx* real-type] (clean-gtype-var idx gtype-var)] + (return (&/T idx* (&/Cons$ real-type types))))) + (&/T 0 (&/|list)) + gtype-vars)] + (return clean-types))) + +(defn ^:private make-gtype [class-name type-args] + "(-> Text (List Type) Type)" + (&/fold (fn [base-type type-arg] + (|case type-arg + (&/$BoundT _) + (&type/Univ$ &type/empty-env base-type) + + _ + base-type)) + (&type/Data$ class-name type-args) + type-args)) + ;; [Resources] (do-template [ ] (let [input-type (&type/Data$ &/Nil$) @@ -163,117 +201,142 @@ analyse-jvm-dgt &&/$jvm-dgt "java.lang.Double" "java.lang.Boolean" ) +(defn ^:private analyse-field-access-helper [obj-type gvars gtype] + "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" + (|case obj-type + (&/$DataT class targs) + (if (= (&/|length targs) (&/|length gvars)) + (|let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T (.getName g) t) m)) + (&/|table) + gvars + targs)] + (&host-type/instance-param &type/existential gtype-env gtype)) + (fail (str "[Type Error] Mismatched number of type-parameters: " (&/|length gvars) " - " (&type/show-type obj-type)))) + + _ + (fail (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) + (defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) + [gvars gtype] (&host/lookup-static-field class-loader class field) + ;; :let [_ (prn 'analyse-jvm-getstatic class field (&/->seq gvars) gtype)] + :let [=type (&host-type/class->type (cast Class gtype))] :let [output-type =type] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-getstatic (&/T class field output-type))))))) (defn analyse-jvm-getfield [analyse exo-type class field object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader class field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) :let [output-type =type] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-getfield (&/T class field =object output-type))))))) (defn analyse-jvm-putstatic [analyse exo-type class field value] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) + [gvars gtype] (&host/lookup-static-field class-loader class field) + :let [=type (&host-type/class->type (cast Class gtype))] =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-putstatic (&/T class field =value output-type))))))) (defn analyse-jvm-putfield [analyse exo-type class field value object] (|do [class-loader &/loader - =type (&host/lookup-static-field class-loader class field) =object (&&/analyse-1 analyse object) + _ (ensure-object (&&/expr-type* =object)) + [gvars gtype] (&host/lookup-field class-loader class field) + =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) =value (&&/analyse-1 analyse =type value) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-putfield (&/T class field =value =object (&&/expr-type* =object)))))))) -(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] - (|do [class-loader &/loader - =return+exceptions (&host/lookup-static-method class-loader class method classes) - :let [[=return exceptions] =return+exceptions] - ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] - _ (ensure-catching exceptions) - ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class &/Nil$]] - ;; (prn 'analyse-jvm-invokestatic class method _return-class))] - =args (&/map2% (fn [_class _arg] - (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) - classes - args) - :let [output-type =return] - _ (&type/check exo-type (as-otype+ output-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) - (defn analyse-jvm-instanceof [analyse exo-type class object] (|do [=object (&&/analyse-1+ analyse object) - _ (ensure-object =object) + _ (ensure-object (&&/expr-type* =object)) :let [output-type &type/Bool] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-instanceof (&/T class =object))))))) -(do-template [ ] - (defn [analyse exo-type class method classes object args] - (|do [class-loader &/loader - =return+exceptions (&host/lookup-virtual-method class-loader class method classes) - ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] - :let [[=return exceptions] =return+exceptions] - _ (ensure-catching exceptions) - =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) - =args (&/map2% (fn [c o] (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) - :let [output-type =return] - ;; :let [_ (prn ' [class method] '=return (&type/show-type =return))] - ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] - _ (&type/check exo-type (as-otype+ output-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&/V (&/T class method classes =object =args output-type))))))) +(defn ^:private analyse-method-call-helper [analyse gret gtype-env gtype-vars gtype-args args] + (|case gtype-vars + (&/$Nil) + (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) + =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) + =gret (&host-type/instance-param &type/existential gtype-env gret)] + (return (&/T =gret =args))) + + (&/$Cons ^TypeVariable gtv gtype-vars*) + (&type/with-var + (fn [$var] + (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] + (analyse-method-call-helper analyse gret gtype-env* gtype-vars* gtype-args args)))) + )) - analyse-jvm-invokevirtual &&/$jvm-invokevirtual - analyse-jvm-invokeinterface &&/$jvm-invokeinterface - ) +(let [dummy-type-param (&type/Data$ "java.lang.Object" (&/|list))] + (do-template [ ] + (defn [analyse exo-type class method classes object args] + (|do [class-loader &/loader + [gret exceptions parent-gvars gvars gargs] (if (= "" method) + (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$)) + (&host/lookup-virtual-method class-loader class method classes)) + ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] + _ (ensure-catching exceptions) + =object (&&/analyse-1+ analyse object) + [sub-class sub-params] (ensure-object (&&/expr-type* =object)) + (&/$DataT super-class* super-params*) (&host-type/->super-type &type/existential class-loader class sub-class sub-params) + :let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T g t) m)) + (&/|table) + parent-gvars + super-params*)] + [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) + ;; :let [_ (prn ' [class method] (&type/show-type exo-type) (&type/show-type output-type))] + ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] + _ (&type/check exo-type (as-otype+ output-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V (&/T class method classes =object =args output-type))))))) + + analyse-jvm-invokevirtual &&/$jvm-invokevirtual + analyse-jvm-invokeinterface &&/$jvm-invokeinterface + analyse-jvm-invokespecial &&/$jvm-invokespecial + )) -(defn analyse-jvm-invokespecial [analyse exo-type class method classes object args] +(defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader - =return+exceptions (if (= "" method) - (return (&/T &type/Unit &/Nil$)) - (&host/lookup-virtual-method class-loader class method classes)) - :let [[=return exceptions] =return+exceptions] - ;; :let [_ (prn 'analyse-jvm-invokespecial (&/adt->text =return+exceptions))] + [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) + ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] _ (ensure-catching exceptions) - =object (&&/analyse-1 analyse (&type/Data$ class &/Nil$) object) - =args (&/map2% (fn [c o] - (&&/analyse-1 analyse (&type/Data$ c &/Nil$) o)) - classes args) - :let [output-type =return] + ;; :let [_ (matchv ::M/objects [=return] + ;; [[&/$DataT _return-class &/Nil$]] + ;; (prn 'analyse-jvm-invokestatic class method _return-class))] + =args (&/map2% (fn [_class _arg] + (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) + classes + args) + :let [output-type (&host-type/class->type (cast Class gret))] _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor - (&/V &&/$jvm-invokespecial (&/T class method classes =object =args output-type))))))) + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-invokestatic (&/T class method classes =args output-type))))))) (defn analyse-jvm-null? [analyse exo-type object] (|do [=object (&&/analyse-1+ analyse object) - _ (ensure-object =object) + _ (ensure-object (&&/expr-type* =object)) :let [output-type &type/Bool] _ (&type/check exo-type output-type) _cursor &/cursor] @@ -287,35 +350,6 @@ (return (&/|list (&&/|meta output-type _cursor (&/V &&/$jvm-null nil)))))) -(defn ^:private clean-gtype-var [idx gtype-var] - (|let [(&/$VarT id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T idx real-type))) - (return (&/T (+ 2 idx) (&type/Bound$ idx))))))) - -(defn ^:private clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T idx* (&/Cons$ real-type types))))) - (&/T 0 (&/|list)) - gtype-vars)] - (return clean-types))) - -(defn ^:private make-gtype [class-name type-args] - "(-> Text (List Type) Type)" - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$BoundT _) - (&type/Univ$ &type/empty-env base-type) - - _ - base-type)) - (&type/Data$ class-name type-args) - type-args)) - (defn ^:private analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] (|case gtype-vars (&/$Nil) @@ -345,7 +379,7 @@ ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] - (return (&/|list (&&/|meta output-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-new (&/T class classes =args))))))) (do-template [ ] @@ -353,25 +387,28 @@ array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) length-type &type/Int idx-type &type/Int] - (defn [analyse length] + (defn [analyse exo-type length] (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V =length)))))) - (defn [analyse array idx] + (defn [analyse exo-type array idx] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) _cursor &/cursor] - (return (&/|list (&&/|meta elem-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V (&/T =array =idx))))))) - (defn [analyse array idx elem] + (defn [analyse exo-type array idx elem] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V (&/T =array =idx =elem))))))) ) @@ -387,44 +424,46 @@ (let [length-type &type/Int idx-type &type/Int] - (defn analyse-jvm-anewarray [analyse class length] + (defn analyse-jvm-anewarray [analyse exo-type class length] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-anewarray (&/T class =length)))))))) - (defn analyse-jvm-aaload [analyse class array idx] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _cursor &/cursor] - (return (&/|list (&&/|meta elem-type _cursor - (&/V &&/$jvm-aaload (&/T class =array =idx)))))))) + (defn analyse-jvm-aaload [analyse exo-type class array idx] + (|do [=array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type inner-arr-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-aaload (&/T class =array =idx))))))) - (defn analyse-jvm-aastore [analyse class array idx elem] + (defn analyse-jvm-aastore [analyse exo-type class array idx elem] (let [elem-type (&type/Data$ class &/Nil$) array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] (|do [=array (&&/analyse-1 analyse array-type array) =idx (&&/analyse-1 analyse idx-type idx) =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) _cursor &/cursor] - (return (&/|list (&&/|meta array-type _cursor + (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-aastore (&/T class =array =idx =elem))))))))) -(let [length-type (&type/Data$ "java.lang.Long" &/Nil$)] - (defn analyse-jvm-arraylength [analyse array] - (&type/with-var - (fn [$var] - (let [elem-type $var - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - _cursor &/cursor] - (return (&/|list (&&/|meta length-type _cursor - (&/V &&/$jvm-arraylength =array) - ))))))))) +(defn analyse-jvm-arraylength [analyse exo-type array] + (|do [=array (&&/analyse-1+ analyse array) + [arr-class arr-params] (ensure-object (&&/expr-type* =array)) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + _ (&type/check exo-type &type/Int) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-arraylength =array) + ))))) (defn ^:private analyse-modifiers [modifiers] (&/fold% (fn [so-far modif] @@ -734,7 +773,7 @@ (do-template [ ] (defn [analyse exo-type ?monitor] (|do [=monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object =monitor) + _ (ensure-object (&&/expr-type* =monitor)) :let [output-type &type/Unit] _ (&type/check exo-type output-type) _cursor &/cursor] diff --git a/src/lux/host.clj b/src/lux/host.clj index 74a8af66a..00f1307ad 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -11,7 +11,7 @@ (lux [base :as & :refer [|do return* return fail fail* |let |case]] [type :as &type]) [lux.type.host :as &host-type]) - (:import (java.lang.reflect Field Method Constructor Modifier) + (:import (java.lang.reflect Field Method Constructor Modifier Type) java.util.regex.Pattern (org.objectweb.asm Opcodes Label @@ -25,29 +25,6 @@ (def class-name-separator ".") (def class-separator "/") -;; [Utils] -(def class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))") - -(defn ^:private class->type [^Class class] - "(-> Class Type)" - (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) - (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] - (let [base (or arr-base simple-base)] - ;; (prn 'class->type/_1 class base arr-brackets) - (let [output-type (if (.equals "void" base) - &type/Unit - (reduce (fn [inner _] (&type/Data$ &host-type/array-data-tag (&/|list inner))) - (&type/Data$ base &/Nil$) - (range (count (or arr-brackets "")))) - )] - ;; (prn 'class->type/_2 class (&type/show-type output-type)) - output-type) - )))) - -(defn ^:private method->type [^Method method] - "(-> Method Type)" - (class->type (.getReturnType method))) - ;; [Resources] (do-template [ ] (let [regex (-> Pattern/quote re-pattern)] @@ -121,12 +98,14 @@ (do-template [ ] (defn [class-loader target field] - (if-let [type* (first (for [^Field =field (.getDeclaredFields (Class/forName (&host-type/as-obj target) true class-loader)) - :when (and (.equals ^Object field (.getName =field)) - (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] - (.getType =field)))] - (return (class->type type*)) - (fail (str "[Host Error] Field does not exist: " target "." field)))) + (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Type gtype (first (for [^Field =field (.getDeclaredFields target-class) + :when (and (.equals ^Object field (.getName =field)) + (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] + (.getGenericType =field)))] + (|let [gvars (->> target-class .getTypeParameters seq &/->list)] + (return (&/T gvars gtype))) + (fail (str "[Host Error] Field does not exist: " target "." field))))) lookup-static-field true lookup-field false @@ -135,18 +114,26 @@ (do-template [ ] (defn [class-loader target method-name args] ;; (prn ' target method-name) - (if-let [method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) - :when (and (.equals ^Object method-name (.getName =method)) - (.equals ^Object (Modifier/isStatic (.getModifiers =method))) - (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types)))))] - =method))] - (return (&/T (method->type method) (->> method .getExceptionTypes &/->list (&/|map #(.getName %))))) - (fail (str "[Host Error] Method does not exist: " target "." method-name)))) + (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] + (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) + :when (and (.equals ^Object method-name (.getName =method)) + (.equals ^Object (Modifier/isStatic (.getModifiers =method))) + (let [param-types (&/->list (seq (.getParameterTypes =method)))] + (and (= (&/|length args) (&/|length param-types)) + (&/fold2 #(and %1 (.equals ^Object %2 %3)) + true + args + (&/|map #(.getName ^Class %) param-types)))))] + =method))] + (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) + gvars (->> method .getTypeParameters seq &/->list) + gargs (->> method .getGenericParameterTypes seq &/->list)] + (return (&/T (.getGenericReturnType method) + (->> method .getExceptionTypes &/->list (&/|map #(.getName %))) + parent-gvars + gvars + gargs))) + (fail (str "[Host Error] Method does not exist: " target "." method-name))))) lookup-static-method true lookup-virtual-method false @@ -255,7 +242,7 @@ (.visitEnd)))) methods) bytecode (.toByteArray (doto =class .visitEnd))] - loader &/loader + ^ClassLoader loader &/loader !classes &/classes :let [real-name (str (->class-name module) "." name) _ (swap! !classes assoc real-name bytecode) diff --git a/src/lux/type.clj b/src/lux/type.clj index 723e169c4..7eae7e181 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -649,31 +649,40 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) - [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - (cond (= "#Null" a!name) - (if (not (&&host/primitive-type? e!name)) - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - (= "#Null" e!name) - (if (= "#Null" a!name) - (return (&/T fixpoints nil)) - (fail (check-error expected actual))) - - :else - (let [e!name (&&host/as-obj e!name) - a!name (&&host/as-obj a!name)] - (cond (and (.equals ^Object e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - (return (&/T fixpoints nil))) - - (not invariant??) - (|do [actual& (&&host/->super-type existential class-loader e!name a!name a!params)] - (check* class-loader fixpoints invariant?? expected actual&)) - - :else - (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) + [(&/$DataT e!data) (&/$DataT a!data)] + (&&host/check-host-types (partial check* class-loader fixpoints true) + check-error + fixpoints + existential + class-loader + invariant?? + e!data + a!data) + ;; [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] + ;; (cond (= "#Null" a!name) + ;; (if (not (&&host/primitive-type? e!name)) + ;; (return (&/T fixpoints nil)) + ;; (fail (check-error expected actual))) + + ;; (= "#Null" e!name) + ;; (if (= "#Null" a!name) + ;; (return (&/T fixpoints nil)) + ;; (fail (check-error expected actual))) + + ;; :else + ;; (let [e!name (&&host/as-obj e!name) + ;; a!name (&&host/as-obj a!name)] + ;; (cond (and (.equals ^Object e!name a!name) + ;; (= (&/|length e!params) (&/|length a!params))) + ;; (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] + ;; (return (&/T fixpoints nil))) + + ;; (not invariant??) + ;; (|do [actual* (&&host/->super-type existential class-loader e!name a!name a!params)] + ;; (check* class-loader fixpoints invariant?? expected actual*)) + + ;; :else + ;; (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 486205494..3121a2213 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -17,9 +17,6 @@ (def null-data-tag "#Null") ;; [Utils] -(defn ^:private Data$ [name params] - (&/V &/$DataT (&/T name params))) - (defn ^:private trace-lineage* [^Class super-class ^Class sub-class] "(-> Class Class (List Class))" ;; Either they're both interfaces, of they're both classes @@ -56,7 +53,9 @@ (defn ^:private trace-lineage [^Class sub-class ^Class super-class] "(-> Class Class (List Class))" - (&/|reverse (trace-lineage* super-class sub-class))) + (if (= sub-class super-class) + (&/|list) + (&/|reverse (trace-lineage* super-class sub-class)))) (let [matcher (fn [m ^TypeVariable jt lt] (&/Cons$ (&/T (.getName jt) lt) m))] (defn ^:private match-params [sub-type-params params] @@ -65,15 +64,30 @@ (&/fold2 matcher (&/|table) sub-type-params params))) ;; [Exports] +(let [class-name-re #"((\[+)L([\.a-zA-Z0-9]+);|([\.a-zA-Z0-9]+))" + Unit (&/V &/$TupleT (&/|list))] + (defn class->type [^Class class] + "(-> Class Type)" + (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + ;; (prn 'class->type/_1 class base arr-brackets) + (if (.equals "void" base) + Unit + (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) + (&/V &/$DataT (&/T base &/Nil$)) + (range (count (or arr-brackets ""))))) + ))))) + (defn instance-param [existential matchings refl-type] "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" ;; (prn 'instance-param refl-type (class refl-type)) (cond (instance? Class refl-type) - (return (Data$ (.getName ^Class refl-type) (&/|list))) + (return (class->type refl-type)) (instance? GenericArrayType refl-type) (let [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] - (return (Data$ array-data-tag (&/|list inner-type)))) + (return (&/V &/$DataT (&/T array-data-tag (&/|list inner-type))))) (instance? ParameterizedType refl-type) (|do [:let [refl-type* ^ParameterizedType refl-type] @@ -81,8 +95,8 @@ .getActualTypeArguments seq &/->list (&/map% (partial instance-param existential matchings)))] - (return (Data$ (->> refl-type* ^Class (.getRawType) .getName) - params*))) + (return (&/V &/$DataT (&/T (->> refl-type* ^Class (.getRawType) .getName) + params*)))) (instance? TypeVariable refl-type) (let [gvar (.getName ^TypeVariable refl-type)] @@ -140,8 +154,8 @@ sub-class+ (Class/forName sub-class true class-loader)] (if (.isAssignableFrom super-class+ sub-class+) (let [lineage (trace-lineage sub-class+ super-class+)] - (|do [[sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] - (return (Data$ (.getName sub-class*) sub-params*)))) + (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] + (return (&/V &/$DataT (&/T (.getName sub-class*) sub-params*))))) (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class " super-type existential class-loader e!name a!name a!params)] + (check (&/V &/$DataT expected) actual*)) + + :else + (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))))) -- cgit v1.2.3 From 968eb87adef6d62803543adf2ec51049527ccb33 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 28 Sep 2015 21:22:42 -0400 Subject: - Added a rule that Void is a subtype of every other type. - Added the type-checking rules for existential quantification (ExQ). - Fixed one of the rules for type-checking universal quantification (UnivQ). --- src/lux/analyser.clj | 17 +++++++++++++--- src/lux/type.clj | 56 +++++++++++++++++++++++++--------------------------- 2 files changed, 41 insertions(+), 32 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 4e1093cec..c02ba03d0 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -68,7 +68,7 @@ (&&lux/analyse-variant analyser (&/V &/$Right exo-type) idx values) ))) -(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] +(defn ^:private aba10 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_znewarray")] (&/$Cons ?length (&/$Nil)))) @@ -116,6 +116,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_laload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) + _ + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token))))))) + +(defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_fnewarray")] (&/$Cons [_ (&/$SymbolS _ ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-fnewarray analyse exo-type ?length) @@ -143,6 +149,12 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_caload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) (&&host/analyse-jvm-caload analyse exo-type ?array ?idx) + _ + (aba10 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba8 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Arrays (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length) @@ -156,8 +168,7 @@ (&&host/analyse-jvm-arraylength analyse exo-type ?array) _ - (do (prn 'aba8 (&/adt->text token)) - (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token)))))))) + (aba9 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba7 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/type.clj b/src/lux/type.clj index 7eae7e181..ed0dd8898 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -638,10 +638,13 @@ (check* class-loader fixpoints invariant?? expected actual*)) [(&/$UnivQ _) _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg)] - (check* class-loader fixpoints invariant?? expected* actual)))) + (|do [$arg existential + expected* (apply-type expected $arg)] + (check* class-loader fixpoints invariant?? expected* actual)) + ;; (with-var + ;; (fn [$arg] + ;; (|do [expected* (apply-type expected $arg)] + ;; (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$UnivQ _)] (with-var @@ -649,6 +652,23 @@ (|do [actual* (apply-type actual $arg)] (check* class-loader fixpoints invariant?? expected actual*)))) + [(&/$ExQ e!env e!def) _] + (with-var + (fn [$arg] + (|let [expected* (beta-reduce (->> e!env + (&/Cons$ expected) + (&/Cons$ $arg)) + e!def)] + (check* class-loader fixpoints invariant?? expected* actual)))) + + [_ (&/$ExQ a!env a!def)] + (|do [$arg existential] + (|let [actual* (beta-reduce (->> a!env + (&/Cons$ expected) + (&/Cons$ $arg)) + a!def)] + (check* class-loader fixpoints invariant?? expected actual*))) + [(&/$DataT e!data) (&/$DataT a!data)] (&&host/check-host-types (partial check* class-loader fixpoints true) check-error @@ -658,31 +678,6 @@ invariant?? e!data a!data) - ;; [(&/$DataT e!name e!params) (&/$DataT a!name a!params)] - ;; (cond (= "#Null" a!name) - ;; (if (not (&&host/primitive-type? e!name)) - ;; (return (&/T fixpoints nil)) - ;; (fail (check-error expected actual))) - - ;; (= "#Null" e!name) - ;; (if (= "#Null" a!name) - ;; (return (&/T fixpoints nil)) - ;; (fail (check-error expected actual))) - - ;; :else - ;; (let [e!name (&&host/as-obj e!name) - ;; a!name (&&host/as-obj a!name)] - ;; (cond (and (.equals ^Object e!name a!name) - ;; (= (&/|length e!params) (&/|length a!params))) - ;; (|do [_ (&/map2% (partial check* class-loader fixpoints true) e!params a!params)] - ;; (return (&/T fixpoints nil))) - - ;; (not invariant??) - ;; (|do [actual* (&&host/->super-type existential class-loader e!name a!name a!params)] - ;; (check* class-loader fixpoints invariant?? expected actual*)) - - ;; :else - ;; (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))) [(&/$LambdaT eI eO) (&/$LambdaT aI aO)] (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? aI eI)] @@ -696,6 +691,9 @@ e!members a!members)] (return (&/T fixpoints* nil))) + [_ (&/$VariantT (&/$Nil))] + (return (&/T fixpoints nil)) + [(&/$VariantT e!cases) (&/$VariantT a!cases)] (|do [fixpoints* (&/fold2% (fn [fp e a] (|do [[fp* _] (check* class-loader fp invariant?? e a)] -- cgit v1.2.3 From f5c046279de3c28e3d83dda116f2b3742766a93b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 28 Sep 2015 22:25:32 -0400 Subject: - Removed reflection warnings. - Made some improvements to working with object arrays. --- src/lux/analyser.clj | 10 ++-- src/lux/analyser/host.clj | 130 ++++++++++++++++++++++---------------------- src/lux/analyser/module.clj | 2 +- src/lux/compiler.clj | 8 +-- src/lux/compiler/cache.clj | 2 +- src/lux/compiler/host.clj | 27 ++++----- src/lux/host.clj | 8 +-- src/lux/packager/lib.clj | 15 ++--- src/lux/type/host.clj | 16 +++++- 9 files changed, 115 insertions(+), 103 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index c02ba03d0..0b911f9ed 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -117,7 +117,7 @@ (&&host/analyse-jvm-laload analyse exo-type ?array ?idx) _ - (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&&/|meta (&/T "" -1 -1) token))))))) + (assert false (str "Unknown syntax: " (prn-str (&/show-ast (&/T (&/T "" -1 -1) token))))))) (defn ^:private aba9 [analyse eval! compile-module compile-token exo-type token] (|case token @@ -158,11 +158,11 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_anewarray")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?length (&/$Nil))))) (&&host/analyse-jvm-anewarray analyse exo-type ?class ?length) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil))))))) - (&&host/analyse-jvm-aastore analyse exo-type ?class ?array ?idx ?elem) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aastore")] (&/$Cons ?array (&/$Cons ?idx (&/$Cons ?elem (&/$Nil)))))) + (&&host/analyse-jvm-aastore analyse exo-type ?array ?idx ?elem) - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons [_ (&/$TextS ?class)] (&/$Cons ?array (&/$Cons ?idx (&/$Nil)))))) - (&&host/analyse-jvm-aaload analyse exo-type ?class ?array ?idx) + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_aaload")] (&/$Cons ?array (&/$Cons ?idx (&/$Nil))))) + (&&host/analyse-jvm-aaload analyse exo-type ?array ?idx) (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_arraylength")] (&/$Cons ?array (&/$Nil)))) (&&host/analyse-jvm-arraylength analyse exo-type ?array) diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index cf361da22..9a38022d8 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -34,9 +34,9 @@ (let [exceptions (&/|map #(Class/forName % true class-loader) exceptions) catching (->> state (&/get$ &/$host) (&/get$ &/$catching) (&/|map #(Class/forName % true class-loader)))] - (if-let [missing-ex (&/fold (fn [prev now] + (if-let [missing-ex (&/fold (fn [prev ^Class now] (or prev - (if (&/fold (fn [found? ex-catch] + (if (&/fold (fn [found? ^Class ex-catch] (or found? (.isAssignableFrom ex-catch now))) false @@ -206,7 +206,7 @@ (|case obj-type (&/$DataT class targs) (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m g t] (&/Cons$ (&/T (.getName g) t) m)) + (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/Cons$ (&/T (.getName g) t) m)) (&/|table) gvars targs)] @@ -382,58 +382,58 @@ (return (&/|list (&&/|meta exo-type _cursor (&/V &&/$jvm-new (&/T class classes =args))))))) -(do-template [ ] - (let [elem-type (&type/Data$ &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type)) - length-type &type/Int - idx-type &type/Int] - (defn [analyse exo-type length] - (|do [=length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V =length)))))) - - (defn [analyse exo-type array idx] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T =array =idx))))))) - - (defn [analyse exo-type array idx elem] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V (&/T =array =idx =elem))))))) - ) - - "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore - "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore - "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore - "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore - "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore - "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore - "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore - "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore - ) +(let [length-type &type/Int + idx-type &type/Int] + (do-template [ ] + (let [elem-type (&type/Data$ &/Nil$) + array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + (defn [analyse exo-type length] + (|do [=length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V =length)))))) + + (defn [analyse exo-type array idx] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + _ (&type/check exo-type elem-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V (&/T =array =idx))))))) + + (defn [analyse exo-type array idx elem] + (|do [=array (&&/analyse-1 analyse array-type array) + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse elem-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V (&/T =array =idx =elem))))))) + ) + + "java.lang.Boolean" analyse-jvm-znewarray &&/$jvm-znewarray analyse-jvm-zaload &&/$jvm-zaload analyse-jvm-zastore &&/$jvm-zastore + "java.lang.Byte" analyse-jvm-bnewarray &&/$jvm-bnewarray analyse-jvm-baload &&/$jvm-baload analyse-jvm-bastore &&/$jvm-bastore + "java.lang.Short" analyse-jvm-snewarray &&/$jvm-snewarray analyse-jvm-saload &&/$jvm-saload analyse-jvm-sastore &&/$jvm-sastore + "java.lang.Integer" analyse-jvm-inewarray &&/$jvm-inewarray analyse-jvm-iaload &&/$jvm-iaload analyse-jvm-iastore &&/$jvm-iastore + "java.lang.Long" analyse-jvm-lnewarray &&/$jvm-lnewarray analyse-jvm-laload &&/$jvm-laload analyse-jvm-lastore &&/$jvm-lastore + "java.lang.Float" analyse-jvm-fnewarray &&/$jvm-fnewarray analyse-jvm-faload &&/$jvm-faload analyse-jvm-fastore &&/$jvm-fastore + "java.lang.Double" analyse-jvm-dnewarray &&/$jvm-dnewarray analyse-jvm-daload &&/$jvm-daload analyse-jvm-dastore &&/$jvm-dastore + "java.lang.Character" analyse-jvm-cnewarray &&/$jvm-cnewarray analyse-jvm-caload &&/$jvm-caload analyse-jvm-castore &&/$jvm-castore + )) (let [length-type &type/Int idx-type &type/Int] (defn analyse-jvm-anewarray [analyse exo-type class length] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-anewarray (&/T class =length)))))))) + (|do [elem-type (&host-type/dummy-gtype class) + :let [array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] + =length (&&/analyse-1 analyse length-type length) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-anewarray (&/T class =length))))))) - (defn analyse-jvm-aaload [analyse exo-type class array idx] + (defn analyse-jvm-aaload [analyse exo-type array idx] (|do [=array (&&/analyse-1+ analyse array) [arr-class arr-params] (ensure-object (&&/expr-type* =array)) _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) @@ -442,18 +442,20 @@ _ (&type/check exo-type inner-arr-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-aaload (&/T class =array =idx))))))) + (&/V &&/$jvm-aaload (&/T =array =idx))))))) - (defn analyse-jvm-aastore [analyse exo-type class array idx elem] - (let [elem-type (&type/Data$ class &/Nil$) - array-type (&type/Data$ &host-type/array-data-tag (&/|list elem-type))] - (|do [=array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _cursor &/cursor] - (return (&/|list (&&/|meta exo-type _cursor - (&/V &&/$jvm-aastore (&/T class =array =idx =elem))))))))) + (defn analyse-jvm-aastore [analyse exo-type array idx elem] + (|do [=array (&&/analyse-1+ analyse array) + :let [array-type (&&/expr-type* =array)] + [arr-class arr-params] (ensure-object array-type) + _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) + :let [(&/$Cons inner-arr-type (&/$Nil)) arr-params] + =idx (&&/analyse-1 analyse idx-type idx) + =elem (&&/analyse-1 analyse inner-arr-type elem) + _ (&type/check exo-type array-type) + _cursor &/cursor] + (return (&/|list (&&/|meta exo-type _cursor + (&/V &&/$jvm-aastore (&/T =array =idx =elem)))))))) (defn analyse-jvm-arraylength [analyse exo-type array] (|do [=array (&&/analyse-1+ analyse array) @@ -725,7 +727,7 @@ _ (check-method-completion (&/Cons$ super-class interfaces) =methods) ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] =captured &&env/captured-vars - :let [=fields (&/|map (fn [idx+capt] + :let [=fields (&/|map (fn [^objects idx+capt] {:name (str &c!base/closure-prefix (aget idx+capt 0)) :modifiers captured-slot-modifier :anns (&/|list) @@ -738,7 +740,7 @@ ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) - :let [_ (println 'DEF anon-class)] + ;; :let [_ (println 'DEF anon-class)] _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) @@ -754,7 +756,7 @@ idx &&env/next-local-idx] (return (&/T ?ex-class idx =catch-body)))) ?catches) - :let [catched-exceptions (&/|map #(aget % 0) =catches)] + :let [catched-exceptions (&/|map #(aget ^objects % 0) =catches)] =body (with-catches catched-exceptions (&&/analyse-1 analyse exo-type ?body)) =finally (|case ?finally diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index 63ba9b741..c645a9566 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -59,7 +59,7 @@ state) nil)))) -(defn define [module name def-data type] +(defn define [module name ^objects def-data type] ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (when (and (= "Macro" name) (= "lux" module)) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 9e399205f..76d3a1eb2 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -309,11 +309,11 @@ (&a/$jvm-anewarray ?class ?length) (&&host/compile-jvm-anewarray compile-expression ?class ?length) - (&a/$jvm-aastore ?class ?array ?idx ?elem) - (&&host/compile-jvm-aastore compile-expression ?class ?array ?idx ?elem) + (&a/$jvm-aastore ?array ?idx ?elem) + (&&host/compile-jvm-aastore compile-expression ?array ?idx ?elem) - (&a/$jvm-aaload ?class ?array ?idx) - (&&host/compile-jvm-aaload compile-expression ?class ?array ?idx) + (&a/$jvm-aaload ?array ?idx) + (&&host/compile-jvm-aaload compile-expression ?array ?idx) (&a/$jvm-arraylength ?array) (&&host/compile-jvm-arraylength compile-expression ?array) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index 4f37e8b62..f1b21f6fd 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -32,7 +32,7 @@ (defn ^:private clean-file [^File file] "(-> File (,))" - (doseq [f (seq (.listFiles file)) + (doseq [^File f (seq (.listFiles file)) :when (not (.isDirectory f))] (.delete f))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 7f7509998..6d926e6da 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -22,7 +22,8 @@ (:import (org.objectweb.asm Opcodes Label ClassWriter - MethodVisitor))) + MethodVisitor + AnnotationVisitor))) ;; [Utils] (let [class+method+sig {"boolean" [(&host/->class "java.lang.Boolean") "booleanValue" "()Z"] @@ -342,7 +343,7 @@ :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host/->class ?class))]] (return nil))) -(defn compile-jvm-aaload [compile ?class ?array ?idx] +(defn compile-jvm-aaload [compile ?array ?idx] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -353,7 +354,7 @@ :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] (return nil))) -(defn compile-jvm-aastore [compile ?class ?array ?idx ?elem] +(defn compile-jvm-aastore [compile ?array ?idx ?elem] (|do [^MethodVisitor *writer* &/get-writer _ (compile ?array) :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST "[Ljava/lang/Object;")] @@ -420,25 +421,21 @@ (return nil))) (defn ^:private compile-annotation [writer ann] - (doto (.visitAnnotation writer (&host/->class (:name ann)) true) + (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true) (-> (.visit param-name param-value) (->> (|let [[param-name param-value] param]) (doseq [param (&/->seq (:params ann))]))) (.visitEnd)) nil) -(defn ^:private compile-field [writer field] +(defn ^:private compile-field [^ClassWriter writer field] (let [=field (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) (&host/->type-signature (:type field)) nil nil)] (&/|map (partial compile-annotation =field) (:anns field)) (.visitEnd =field) - nil) - ;; (doto (.visitField writer (&host/modifiers->int (:modifiers field)) (:name field) - ;; (&host/->type-signature (:type field)) nil nil) - ;; (.visitEnd)) - ) + nil)) -(defn ^:private compile-method-return [writer output] +(defn ^:private compile-method-return [^MethodVisitor writer output] (case output "void" (.visitInsn writer Opcodes/RETURN) "boolean" (doto writer @@ -468,7 +465,7 @@ ;; else (.visitInsn writer Opcodes/ARETURN))) -(defn ^:private compile-method [compile class-writer method] +(defn ^:private compile-method [compile ^ClassWriter class-writer method] ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) ;; (prn 'compile-method/_2 (&/adt->text (:output method))) @@ -490,7 +487,7 @@ (.visitEnd))]] (return nil))))) -(defn ^:private compile-method-decl [class-writer method] +(defn ^:private compile-method-decl [^ClassWriter class-writer method] (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] (let [=method (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) (:name method) signature nil (->> (:exceptions method) (&/|map &host/->class) &/->seq (into-array java.lang.String)))] @@ -503,8 +500,8 @@ (str "(" (&/fold str "" (&/|repeat (&/|length env) clo-field-sig)) ")" -return)) - (defn ^:private add-anon-class- [class-writer class-name env] - (doto (.visitMethod ^ClassWriter class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) + (defn ^:private add-anon-class- [^ClassWriter class-writer class-name env] + (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "" (anon-class--signature env) nil nil) (.visitCode) (.visitVarInsn Opcodes/ALOAD 0) (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "" "()V") diff --git a/src/lux/host.clj b/src/lux/host.clj index 00f1307ad..133c50e9b 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -129,7 +129,7 @@ gvars (->> method .getTypeParameters seq &/->list) gargs (->> method .getGenericParameterTypes seq &/->list)] (return (&/T (.getGenericReturnType method) - (->> method .getExceptionTypes &/->list (&/|map #(.getName %))) + (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) parent-gvars gvars gargs))) @@ -152,13 +152,13 @@ =method))] (|let [gvars (->> target-class .getTypeParameters seq &/->list) gargs (->> ctor .getGenericParameterTypes seq &/->list) - exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName %)))] + exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %)))] (return (&/T exs gvars gargs))) (fail (str "[Host Error] Constructor does not exist: " target))))) (defn abstract-methods [class-loader class] (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj class) true class-loader)) - :when (.equals true (Modifier/isAbstract (.getModifiers =method)))] + :when (Modifier/isAbstract (.getModifiers =method))] (&/T (.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))))))) (defn location [scope] @@ -180,7 +180,7 @@ 0))) (let [object-real-class (->class "java.lang.Object")] - (defn ^:private dummy-return [writer name output] + (defn ^:private dummy-return [^MethodVisitor writer name output] (case output "void" (if (= "" name) (doto writer diff --git a/src/lux/packager/lib.clj b/src/lux/packager/lib.clj index 41f3143a0..af48e31eb 100644 --- a/src/lux/packager/lib.clj +++ b/src/lux/packager/lib.clj @@ -13,23 +13,24 @@ )) ;; [Utils] -(defn ^:private read-file [file] +(defn ^:private read-file ^objects [^File file] (with-open [is (java.io.FileInputStream. file)] (let [data (byte-array (.length file))] (.read is data) data))) -(defn ^:private add-to-tar! [prefix ^File file os] +(defn ^:private add-to-tar! [prefix ^File file ^TarArchiveOutputStream os] "(-> Text File TarArchiveOutputStream Unit)" (let [file-name (str prefix "/" (.getName file))] (if (.isDirectory file) (doseq [file (seq (.listFiles file))] (add-to-tar! file-name file os)) - (doto os - (.putArchiveEntry (doto (new TarArchiveEntry file-name) - (.setSize (.length file)))) - (.write (read-file file)) - (.closeArchiveEntry))))) + (let [data (read-file file)] + (doto os + (.putArchiveEntry (doto (new TarArchiveEntry file-name) + (.setSize (.length file)))) + (.write data 0 (alength data)) + (.closeArchiveEntry)))))) ;; [Exports] (defn package [output-lib-name ^File source-dir] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 3121a2213..e121cee86 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -115,14 +115,16 @@ (|let [matchings (match-params sub-type-params params)] (&/map% (partial instance-param existential matchings) super-type-params))) -(defn ^:private raise* [existential sub+params super] +(defn ^:private raise* [existential sub+params ^Class super] "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" (|let [[^Class sub params] sub+params] (if (.isInterface super) (|do [:let [super-params (->> sub .getGenericInterfaces (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) - (if (instance? Class %) (&/|list) (->> % .getActualTypeArguments seq &/->list)) + (if (instance? Class %) + (&/|list) + (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) nil)))] params* (translate-params existential super-params @@ -209,3 +211,13 @@ :else (fail (str "[Type Error] Names don't match: " e!name " =/= " a!name))))))) + +(let [Void$ (&/V &/$VariantT (&/|list)) + gen-type (constantly Void$)] + (defn dummy-gtype [class] + (|do [class-loader &/loader] + (try (|let [=class (Class/forName class true class-loader) + params (->> =class .getTypeParameters seq &/->list (&/|map gen-type))] + (return (&/V &/$DataT (&/T class params)))) + (catch Exception e + (fail (str "[Type Error] Unknown type: " class))))))) -- cgit v1.2.3 From 8760f9bc9399cdc0d862f4d841bf920818d4c7bb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 29 Sep 2015 07:21:11 -0400 Subject: - Cleaned-up the comments from the codebase. --- src/lux/analyser.clj | 4 +- src/lux/analyser/case.clj | 65 +++++------------ src/lux/analyser/env.clj | 2 - src/lux/analyser/host.clj | 46 ++---------- src/lux/analyser/lux.clj | 165 ++++++++++++++---------------------------- src/lux/analyser/module.clj | 33 ++++----- src/lux/base.clj | 4 -- src/lux/compiler.clj | 11 +-- src/lux/compiler/cache.clj | 166 +++++++++++++++++++------------------------ src/lux/compiler/host.clj | 69 ++++-------------- src/lux/compiler/io.clj | 1 - src/lux/compiler/lambda.clj | 1 - src/lux/compiler/lux.clj | 13 +--- src/lux/host.clj | 1 - src/lux/lexer.clj | 6 +- src/lux/packager/program.clj | 6 +- src/lux/type.clj | 65 +---------------- src/lux/type/host.clj | 19 +++-- 18 files changed, 199 insertions(+), 478 deletions(-) (limited to 'src') diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 0b911f9ed..4ead47916 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -694,7 +694,6 @@ )))) (defn ^:private analyse-ast [eval! compile-module compile-token exo-type token] - ;; (prn 'analyse-ast (&/show-ast token)) (|let [[cursor _] token] (&/with-cursor cursor (&/with-expected-type exo-type @@ -709,8 +708,7 @@ (fn [state] (|case ((just-analyse (partial analyse-ast eval! compile-module compile-token) ?fn) state) (&/$Right state* =fn) - (do ;; (prn 'GOT_FUN (&/show-ast ?fn) (&/show-ast token) (aget =fn 0 0) (aget =fn 1 0)) - ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*)) + ((&&lux/analyse-apply (partial analyse-ast eval! compile-module compile-token) exo-type meta =fn ?args) state*) _ ((analyse-basic-ast (partial analyse-ast eval! compile-module compile-token) eval! compile-module compile-token exo-type token) state))) diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 325b6cdd8..9640cf88a 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -62,7 +62,6 @@ (defn adjust-type* [up type] "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" - ;; (prn 'adjust-type* (&type/show-type type)) (|case type (&/$UnivQ _aenv _abody) (&type/with-var @@ -159,63 +158,47 @@ (&/$TupleS ?members) (|do [value-type* (adjust-type value-type)] - (do ;; (prn 'PM/TUPLE-1 (&type/show-type value-type*)) - (|case value-type* - (&/$TupleT ?member-types) - (do ;; (prn 'PM/TUPLE-2 (&/|length ?member-types) (&/|length ?members)) - (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) - (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] - (return (&/T (&/Cons$ =test =tests) =kont))))) - (|do [=kont kont] - (return (&/T &/Nil$ =kont))) - (&/|reverse (&/zip2 ?member-types ?members)))] - (return (&/T (&/V $TupleTestAC =tests) =kont))))) + (|case value-type* + (&/$TupleT ?member-types) + (if (not (.equals ^Object (&/|length ?member-types) (&/|length ?members))) + (fail (str "[Pattern-matching Error] Pattern-matching mismatch. Require tuple[" (&/|length ?member-types) "]. Given tuple [" (&/|length ?members) "]")) + (|do [[=tests =kont] (&/fold (fn [kont* vm] + (|let [[v m] vm] + (|do [[=test [=tests =kont]] (analyse-pattern v m kont*)] + (return (&/T (&/Cons$ =test =tests) =kont))))) + (|do [=kont kont] + (return (&/T &/Nil$ =kont))) + (&/|reverse (&/zip2 ?member-types ?members)))] + (return (&/T (&/V $TupleTestAC =tests) =kont)))) - _ - (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*)))))) + _ + (fail (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type*))))) (&/$RecordS pairs) (|do [[rec-members rec-type] (&&record/order-record pairs)] (analyse-pattern value-type (&/T meta (&/V &/$TupleS rec-members)) kont)) (&/$TagS ?ident) - (|do [;; :let [_ (println "#00" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#01")] + (|do [[=module =name] (&&/resolved-ident ?ident) value-type* (adjust-type value-type) - ;; :let [_ (println "#02")] idx (&module/tag-index =module =name) group (&module/tag-group =module =name) - ;; :let [_ (println "#03")] case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#04")] - [=test =kont] (analyse-pattern case-type unit kont) - ;; :let [_ (println "#05")] - ] + [=test =kont] (analyse-pattern case-type unit kont)] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) (&/$FormS (&/$Cons [_ (&/$TagS ?ident)] ?values)) - (|do [;; :let [_ (println "#10" (&/ident->text ?ident))] - [=module =name] (&&/resolved-ident ?ident) - ;; :let [_ (println "#11")] + (|do [[=module =name] (&&/resolved-ident ?ident) value-type* (adjust-type value-type) - ;; :let [_ (println "#12" (&type/show-type value-type*))] idx (&module/tag-index =module =name) group (&module/tag-group =module =name) - ;; :let [_ (println "#13")] case-type (&type/variant-case idx value-type*) - ;; :let [_ (println "#14" (&type/show-type case-type))] [=test =kont] (case (int (&/|length ?values)) 0 (analyse-pattern case-type unit kont) 1 (analyse-pattern case-type (&/|head ?values) kont) ;; 1+ - (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont)) - ;; :let [_ (println "#15")] - ] + (analyse-pattern case-type (&/T (&/T "" -1 -1) (&/V &/$TupleS ?values)) kont))] (return (&/T (&/V $VariantTestAC (&/T idx (&/|length group) =test)) =kont))) _ @@ -319,7 +302,6 @@ (return (&/T =output =type))))))) (defn ^:private check-totality [value-type struct] - ;; (prn 'check-totality (&type/show-type value-type) (&/adt->text struct)) (|case struct ($DefaultTotal ?total) (return ?total) @@ -371,20 +353,11 @@ (|do [value-type* (resolve-type value-type)] (|case value-type* (&/$VariantT ?members) - (|do [totals (&/map2% (fn [sub-struct ?member] - ;; (prn '$VariantTotal - ;; (&/adt->text sub-struct) - ;; (&type/show-type ?member)) - (check-totality ?member sub-struct)) - ?structs ?members)] + (|do [totals (&/map2% check-totality ?members ?structs)] (return (&/fold #(and %1 %2) true totals))) _ (fail "[Pattern-maching Error] Variant is not total.")))) - - ;; _ - ;; (assert false (prn-str 'check-totality (&type/show-type value-type) - ;; (&/adt->text struct))) )) ;; [Exports] diff --git a/src/lux/analyser/env.clj b/src/lux/analyser/env.clj index a7ce52c1f..81397a3f6 100644 --- a/src/lux/analyser/env.clj +++ b/src/lux/analyser/env.clj @@ -15,9 +15,7 @@ (return* state (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) (defn with-local [name type body] - ;; (prn 'with-local name) (fn [state] - ;; (prn 'with-local name) (let [old-mappings (->> state (&/get$ &/$envs) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) =return (body (&/update$ &/$envs (fn [stack] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 9a38022d8..33553985b 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -45,28 +45,22 @@ now))) nil exceptions)] - (assert false (str "[Analyser Error] Unhandled exception: " missing-ex)) - ;; (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) + (&/fail* (str "[Analyser Error] Unhandled exception: " missing-ex)) (&/return* state nil))) ))) (defn ^:private with-catches [catches body] "(All [a] (-> (List Text) (Lux a) (Lux a)))" (fn [state] - (let [;; _ (prn 'with-catches/_0 (&/->seq catches)) - old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) - ;; _ (prn 'with-catches/_1 (&/->seq (->> state (&/get$ &/$host) (&/get$ &/$catching)))) - state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %))) - ;; _ (prn 'with-catches/_2 (&/->seq (->> state* (&/get$ &/$host) (&/get$ &/$catching)))) - ] + (let [old-catches (->> state (&/get$ &/$host) (&/get$ &/$catching)) + state* (->> state (&/update$ &/$host #(&/update$ &/$catching (partial &/|++ catches) %)))] (|case (&/run-state body state*) (&/$Left msg) (&/V &/$Left msg) (&/$Right state** output) - (do ;; (prn 'with-catches/_3 (&/->seq (->> state** (&/get$ &/$host) (&/get$ &/$catching)))) - (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) - output))))) + (&/V &/$Right (&/T (->> state** (&/update$ &/$host #(&/set$ &/$catching old-catches %))) + output)))) )) (defn ^:private ensure-object [type] @@ -219,7 +213,6 @@ (defn analyse-jvm-getstatic [analyse exo-type class field] (|do [class-loader &/loader [gvars gtype] (&host/lookup-static-field class-loader class field) - ;; :let [_ (prn 'analyse-jvm-getstatic class field (&/->seq gvars) gtype)] :let [=type (&host-type/class->type (cast Class gtype))] :let [output-type =type] _ (&type/check exo-type output-type) @@ -294,7 +287,6 @@ [gret exceptions parent-gvars gvars gargs] (if (= "" method) (return (&/T Void/TYPE &/Nil$ &/Nil$ &/Nil$ &/Nil$)) (&host/lookup-virtual-method class-loader class method classes)) - ;; :let [_ (prn ' [class method] (&/adt->text =return+exceptions))] _ (ensure-catching exceptions) =object (&&/analyse-1+ analyse object) [sub-class sub-params] (ensure-object (&&/expr-type* =object)) @@ -304,8 +296,6 @@ parent-gvars super-params*)] [output-type =args] (analyse-method-call-helper analyse gret gtype-env gvars gargs args) - ;; :let [_ (prn ' [class method] (&type/show-type exo-type) (&type/show-type output-type))] - ;; :let [_ (prn ' '(as-otype+ output-type) (&type/show-type (as-otype+ output-type)))] _ (&type/check exo-type (as-otype+ output-type)) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor @@ -319,11 +309,7 @@ (defn analyse-jvm-invokestatic [analyse exo-type class method classes args] (|do [class-loader &/loader [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader class method classes) - ;; :let [_ (prn 'analyse-jvm-invokestatic (&/adt->text =return+exceptions))] _ (ensure-catching exceptions) - ;; :let [_ (matchv ::M/objects [=return] - ;; [[&/$DataT _return-class &/Nil$]] - ;; (prn 'analyse-jvm-invokestatic class method _return-class))] =args (&/map2% (fn [_class _arg] (&&/analyse-1 analyse (&type/Data$ _class &/Nil$) _arg)) classes @@ -354,9 +340,6 @@ (|case gtype-vars (&/$Nil) (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - ;; :let [_ (prn 'analyse-jvm-new-helper/_0 gtype) - ;; _ (prn 'analyse-jvm-new-helper/_1 gtype (->> arg-types (&/|map &type/show-type) &/->seq)) - ;; _ (prn 'analyse-jvm-new-helper/_2 gtype (->> args (&/|map &/show-ast) &/->seq))] =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] (return (&/T (make-gtype gtype gtype-vars*) @@ -365,7 +348,6 @@ (&/$Cons ^TypeVariable gtv gtype-vars*) (&type/with-var (fn [$var] - ;; (prn 'analyse-jvm-new-helper gtype gtv $var (&/|length gtype-vars) (&/|length gtype-args)) (|let [gtype-env* (&/Cons$ (&/T (.getName gtv) $var) gtype-env)] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args)))) )) @@ -373,10 +355,8 @@ (defn analyse-jvm-new [analyse exo-type class classes args] (|do [class-loader &/loader [exceptions gvars gargs] (&host/lookup-constructor class-loader class classes) - ;; :let [_ (prn 'analyse-jvm-new class (&/->seq gvars) (&/->seq gargs))] _ (ensure-catching exceptions) [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - ;; :let [_ (prn 'analyse-jvm-new/POST class (->> classes &/->seq vec) (&type/show-type output-type))] _ (&type/check exo-type output-type) _cursor &/cursor] (return (&/|list (&&/|meta exo-type _cursor @@ -713,39 +693,27 @@ captured-slot-type "java.lang.Object"] (defn analyse-jvm-anon-class [analyse compile-token exo-type super-class interfaces methods] (&/with-closure - (|do [;; :let [_ (prn 'analyse-jvm-anon-class/_0 super-class)] - module &/get-module-name + (|do [module &/get-module-name scope &/get-scope-name - ;; :let [_ (prn 'analyse-jvm-anon-class/_1 super-class)] :let [name (&host/location (&/|tail scope)) anon-class (str module "." name)] - ;; :let [_ (prn 'analyse-jvm-anon-class/_2 name anon-class)] =method-descs (&/map% dummy-method-desc methods) _ (&host/use-dummy-class name super-class interfaces (&/|list) =method-descs) =methods (&/map% (partial analyse-method analyse anon-class) methods) - ;; :let [_ (prn 'analyse-jvm-anon-class/_3 name anon-class)] _ (check-method-completion (&/Cons$ super-class interfaces) =methods) - ;; :let [_ (prn 'analyse-jvm-anon-class/_4 name anon-class)] =captured &&env/captured-vars :let [=fields (&/|map (fn [^objects idx+capt] {:name (str &c!base/closure-prefix (aget idx+capt 0)) :modifiers captured-slot-modifier :anns (&/|list) :type captured-slot-type}) - (&/enumerate =captured)) - ;; _ (prn '=methods (&/adt->text (&/|map :body =methods))) - ;; =methods* (rename-captured-vars) - ] + (&/enumerate =captured))] :let [sources (&/|map captured-source =captured)] - ;; :let [_ (prn 'analyse-jvm-anon-class/_5 name anon-class)] - ;; _ (compile-token (&/T (&/V &&/$jvm-anon-class (&/T name super-class interfaces =captured =methods)) exo-type)) _ (compile-token (&/V &&/$jvm-class (&/T name super-class interfaces (&/|list) =fields =methods =captured))) - ;; :let [_ (println 'DEF anon-class)] _cursor &/cursor] (return (&/|list (&&/|meta (&type/Data$ anon-class (&/|list)) _cursor (&/V &&/$jvm-new (&/T anon-class (&/|repeat (&/|length sources) captured-slot-type) sources)) ))) - ;; (analyse-jvm-new analyse exo-type anon-class (&/|repeat (&/|length sources) captured-slot-type) sources) )))) (defn analyse-jvm-try [analyse exo-type ?body ?catches+?finally] diff --git a/src/lux/analyser/lux.clj b/src/lux/analyser/lux.clj index 9dd8cecdc..e938fa343 100644 --- a/src/lux/analyser/lux.clj +++ b/src/lux/analyser/lux.clj @@ -45,8 +45,7 @@ (defn analyse-tuple [analyse ?exo-type ?elems] (|case ?exo-type (&/$Left exo-type) - (|do [;; :let [_ (println 'analyse-tuple/$Left (&type/show-type exo-type))] - exo-type* (&type/actual-type exo-type)] + (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* (&/$UnivQ _) (&type/with-var @@ -100,7 +99,6 @@ _ (fail (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) - ;; (assert false (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*) " " (&type/show-type exo-type) " " "[" (->> ?elems (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) "]")) )))))) (defn with-attempt [m-value on-error] @@ -127,10 +125,6 @@ (fail (str err "\n" 'analyse-variant-body " " (&type/show-type exo-type) " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) - ;; (assert false - ;; (str err "\n" - ;; 'analyse-variant-body " " (&type/show-type exo-type) - ;; " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")))) ))] (|case output (&/$Cons x (&/$Nil)) @@ -142,20 +136,14 @@ (defn analyse-variant [analyse ?exo-type idx ?values] (|case ?exo-type (&/$Left exo-type) - (|do [;; :let [_ (println 'analyse-variant/Left 0 (&type/show-type exo-type))] - exo-type* (&type/actual-type exo-type) - ;; :let [_ (println 'analyse-variant/Left 1 (&type/show-type exo-type*))] - ] + (|do [exo-type* (&type/actual-type exo-type)] (|case exo-type* (&/$UnivQ _) (&type/with-var (fn [$var] (|do [exo-type** (&type/apply-type exo-type* $var) - ;; :let [_ (println 'analyse-variant/Left 2 (&type/show-type exo-type**))] [[variant-type variant-cursor] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/V &/$Left exo-type**) idx ?values)) - ;; :let [_ (println 'analyse-variant/Left 3 (&type/show-type variant-type))] =var (&type/resolve-type $var) - ;; :let [_ (println 'analyse-variant/Left 4 (&type/show-type =var))] inferred-type (|case =var (&/$VarT iid) (|do [:let [=var* (next-bound-type variant-type)] @@ -164,9 +152,7 @@ (return (&type/Univ$ &/Nil$ variant-type*))) _ - (&type/clean $var variant-type)) - ;; :let [_ (println 'analyse-variant/Left 5 (&type/show-type inferred-type))] - ] + (&type/clean $var variant-type))] (return (&/|list (&&/|meta inferred-type variant-cursor variant-analysis)))))) @@ -174,9 +160,7 @@ (analyse-variant analyse (&/V &/$Right exo-type*) idx ?values))) (&/$Right exo-type) - ;; [_ exo-type] - (|do [;; :let [_ (println 'analyse-variant/Right 0 (&type/show-type exo-type))] - exo-type* (|case exo-type + (|do [exo-type* (|case exo-type (&/$VarT ?id) (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] (&type/actual-type exo-type*)) @@ -230,8 +214,6 @@ (defn ^:private analyse-global [analyse exo-type module name] (|do [[[r-module r-name] $def] (&&module/find-def module name) - ;; :let [_ (prn 'analyse-symbol/_1.1 r-module r-name)] - ;; :let [_ (prn 'analyse-global/$def (aget $def 0))] endo-type (|case $def (&/$ValueD ?type _) (return ?type) @@ -263,52 +245,48 @@ state) (&/$Cons ?genv (&/$Nil)) - (do ;; (prn 'analyse-symbol/_2 ?module name name (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) &/|keys &/->seq)) - (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] - (do ;; (prn 'analyse-symbol/_2.1 ?module name name (aget global 0)) - (|case global - [(&/$Global ?module* name*) _] - ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) - ;; :let [_ (prn 'analyse-symbol/_2.1.1 r-module r-name)] - endo-type (|case $def - (&/$ValueD ?type _) - (return ?type) - - (&/$MacroD _) - (return &type/Macro) - - (&/$TypeD _) - (return &type/Type)) - _ (if (and (clojure.lang.Util/identical &type/Type endo-type) - (clojure.lang.Util/identical &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type)) - _cursor &/cursor] - (return (&/|list (&&/|meta endo-type _cursor - (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) - )))) - state) + (if-let [global (->> ?genv (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name))] + (|case global + [(&/$Global ?module* name*) _] + ((|do [[[r-module r-name] $def] (&&module/find-def ?module* name*) + endo-type (|case $def + (&/$ValueD ?type _) + (return ?type) + + (&/$MacroD _) + (return &type/Macro) + + (&/$TypeD _) + (return &type/Type)) + _ (if (and (clojure.lang.Util/identical &type/Type endo-type) + (clojure.lang.Util/identical &type/Type exo-type)) + (return nil) + (&type/check exo-type endo-type)) + _cursor &/cursor] + (return (&/|list (&&/|meta endo-type _cursor + (&/V &&/$var (&/V &/$Global (&/T r-module r-name))) + )))) + state) - _ - (fail* "[Analyser Error] Can't have anything other than a global def in the global environment."))) - (fail* ""))) + _ + (fail* "[Analyser Error] Can't have anything other than a global def in the global environment.")) + (fail* "")) (&/$Cons top-outer _) - (do ;; (prn 'analyse-symbol/_3 ?module name) - (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) - (&/|map #(&/get$ &/$name %) outer) - (&/|reverse inner))) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] - (&/T register* (&/Cons$ frame* new-inner)))) - (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) - &/Nil$) - (&/|reverse inner) scopes)] - ((|do [_ (&type/check exo-type (&&/expr-type* =local))] - (return (&/|list =local))) - (&/set$ &/$envs (&/|++ inner* outer) state)))) + (|let [scopes (&/|tail (&/folds #(&/Cons$ (&/get$ &/$name %2) %1) + (&/|map #(&/get$ &/$name %) outer) + (&/|reverse inner))) + [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] + (|let [[register new-inner] register+new-inner + [register* frame*] (&&lambda/close-over (&/|reverse in-scope) name register frame)] + (&/T register* (&/Cons$ frame* new-inner)))) + (&/T (or (->> top-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) + (->> top-outer (&/get$ &/$closure) (&/get$ &/$mappings) (&/|get name))) + &/Nil$) + (&/|reverse inner) scopes)] + ((|do [_ (&type/check exo-type (&&/expr-type* =local))] + (return (&/|list =local))) + (&/set$ &/$envs (&/|++ inner* outer) state))) )))) (defn analyse-symbol [analyse exo-type ident] @@ -319,22 +297,15 @@ )) (defn ^:private analyse-apply* [analyse exo-type fun-type ?args] - ;; (prn 'analyse-apply* (aget fun-type 0)) (|case ?args (&/$Nil) - (|do [;; :let [_ (prn 'analyse-apply*/_0 (&type/show-type exo-type) (&type/show-type fun-type))] - _ (&type/check exo-type fun-type) - ;; :let [_ (prn 'analyse-apply*/_1 'SUCCESS (str "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))] - ] + (|do [_ (&type/check exo-type fun-type)] (return (&/T fun-type &/Nil$))) (&/$Cons ?arg ?args*) (|do [?fun-type* (&type/actual-type fun-type)] (|case ?fun-type* (&/$UnivQ _) - ;; (|do [$var &type/existential - ;; type* (&type/apply-type ?fun-type* $var)] - ;; (analyse-apply* analyse exo-type type* ?args)) (&type/with-var (fn [$var] (|do [type* (&type/apply-type ?fun-type* $var) @@ -359,9 +330,6 @@ " " "(_ " (->> ?args (&/|map &/show-ast) (&/|interpose " ") (&/fold str "")) ")"))))] (return (&/T =output-t (&/Cons$ =arg =args)))) - ;; [[&/$VarT ?id-t]] - ;; (|do [ (&type/deref ?id-t)]) - _ (fail (str "[Analyser Error] Can't apply a non-function: " (&type/show-type ?fun-type*))))) )) @@ -374,9 +342,7 @@ (|do [[real-name $def] (&&module/find-def ?module ?name)] (|case $def (&/$MacroD macro) - (|do [;; :let [_ (prn 'MACRO-EXPAND|PRE (&/ident->text real-name))] - macro-expansion #(-> macro (.apply ?args) (.apply %)) - ;; :let [_ (prn 'MACRO-EXPAND|POST (&/ident->text real-name))] + (|do [macro-expansion #(-> macro (.apply ?args) (.apply %)) ;; :let [_ (when (or (= "do" (aget real-name 1)) ;; ;; (= "..?" (aget real-name 1)) ;; ;; (= "try$" (aget real-name 1)) @@ -494,11 +460,7 @@ (return (&/|list output)))) (defn analyse-def [analyse compile-token ?name ?value] - ;; (prn 'analyse-def/BEGIN ?name) - ;; (when (= "monoid$" ?name) - ;; (reset! &type/!flag true)) (|do [module-name &/get-module-name - ;; :let [_ (println 'DEF/PRE (str module-name ";" ?name))] ? (&&module/defined? module-name ?name)] (if ? (fail (str "[Analyser Error] Can't redefine " (str module-name ";" ?name))) @@ -506,55 +468,36 @@ (&&/analyse-1+ analyse ?value))] (|case =value [_ (&&/$var (&/$Global ?r-module ?r-name))] - (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value)) - ;; :let [_ (println 'analyse-def/ALIAS (str module-name ";" ?name) '=> (str ?r-module ";" ?r-name)) - ;; _ (println)] - ] + (|do [_ (&&module/def-alias module-name ?name ?r-module ?r-name (&&/expr-type* =value))] (return &/Nil$)) _ - (do ;; (println 'DEF (str module-name ";" ?name)) - (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) - ;; _ (if (and (= "lux" module-name) - ;; (= "Type" ?name)) - ;; (|do [newly-defined-Type - ;; :let [_ (&type/redefine-type! newly-defined-Type)]] - ;; (return nil)) - ;; (return nil)) - :let [;; _ (println 'DEF/COMPILED (str module-name ";" ?name)) - [[def-type def-cursor] def-analysis] =value - _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) - )]] - (return &/Nil$)))) + (|do [_ (compile-token (&/V &&/$def (&/T ?name =value))) + :let [[[def-type def-cursor] def-analysis] =value + _ (println 'DEF (str module-name ";" ?name) ;; (&type/show-type def-type) + )]] + (return &/Nil$))) )))) (defn analyse-declare-macro [analyse compile-token ?name] - (|do [;; :let [_ (prn 'analyse-declare-macro ?name "0")] - module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-macro ?name "1")] - _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name))) - ;; :let [_ (prn 'analyse-declare-macro ?name "2")] - ] + (|do [module-name &/get-module-name + _ (compile-token (&/V &&/$declare-macro (&/T module-name ?name)))] (return &/Nil$))) (defn analyse-declare-tags [tags type-name] (|do [module-name &/get-module-name - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags))] [_ def-data] (&&module/find-def module-name type-name) - ;; :let [_ (prn 'analyse-declare-tags (&/ident->text (&/T module-name type-name)) (&/->seq tags) (&/adt->text def-data))] def-type (&&module/ensure-type-def def-data) _ (&&module/declare-tags module-name tags def-type)] (return &/Nil$))) (defn analyse-import [analyse compile-module compile-token path] - ;; (prn 'analyse-import path) (|do [module-name &/get-module-name _ (if (= module-name path) (fail (str "[Analyser Error] Module can't import itself: " path)) (return nil))] (&/save-module (|do [already-compiled? (&&module/exists? path) - ;; :let [_ (prn 'analyse-import module-name path already-compiled?)] active? (&/active-module? path) _ (&/assert! (not active?) (str "[Analyser Error] Can't import a module that is mid-compilation: " path " @ " module-name)) _ (&&module/add-import path) @@ -576,10 +519,8 @@ (defn analyse-check [analyse eval! exo-type ?type ?value] (|do [=type (&&/analyse-1 analyse &type/Type ?type) ==type (eval! =type) - ;; :let [_ (prn 'analyse-check/_0 (&type/show-type ==type))] _ (&type/check exo-type ==type) =value (&&/analyse-1 analyse ==type ?value) - ;; :let [_ (prn 'analyse-check/_1 (&/adt->text =value))] _cursor &/cursor ] (return (&/|list (&&/|meta ==type _cursor diff --git a/src/lux/analyser/module.clj b/src/lux/analyser/module.clj index c645a9566..192e80153 100644 --- a/src/lux/analyser/module.clj +++ b/src/lux/analyser/module.clj @@ -60,7 +60,6 @@ nil)))) (defn define [module name ^objects def-data type] - ;; (prn 'define module name (aget def-data 0) (&type/show-type type)) (fn [state] (when (and (= "Macro" name) (= "lux" module)) (&type/set-macro-type! (aget def-data 1))) @@ -116,7 +115,6 @@ (fail* (str "[Analyser Error] Unknown module: " module))))) (defn def-alias [a-module a-name r-module r-name type] - ;; (prn 'def-alias [a-module a-name] [r-module r-name] (&type/show-type type)) (fn [state] (|case (&/get$ &/$envs state) (&/$Cons ?env (&/$Nil)) @@ -165,23 +163,19 @@ (defn find-def [module name] (|do [current-module &/get-module-name] (fn [state] - ;; (prn 'find-def/_0 module name 'current-module current-module) (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (do ;; (prn 'find-def/_0.1 module (&/->seq (&/|keys $module))) - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|let [[exported? $$def] $def] - (do ;; (prn 'find-def/_1 module name 'exported? exported? (.equals ^Object current-module module)) - (if (or exported? (.equals ^Object current-module module)) - (|case $$def - (&/$AliasD ?r-module ?r-name) - (do ;; (prn 'find-def/_2 [module name] [?r-module ?r-name]) - ((find-def ?r-module ?r-name) - state)) - - _ - (return* state (&/T (&/T module name) $$def))) - (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name)))))) - (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name))))) + (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] + (|let [[exported? $$def] $def] + (if (or exported? (.equals ^Object current-module module)) + (|case $$def + (&/$AliasD ?r-module ?r-name) + ((find-def ?r-module ?r-name) + state) + + _ + (return* state (&/T (&/T module name) $$def))) + (fail* (str "[Analyser Error] Can't use unexported definition: " (str module &/+name-separator+ name))))) + (fail* (str "[Analyser Error] Definition does not exist: " (str module &/+name-separator+ name)))) (fail* (str "[Analyser Error] Module doesn't exist: " module)))))) (defn ensure-type-def [def-data] @@ -321,8 +315,7 @@ (defn declare-tags [module tag-names type] "(-> Text (List Text) Type (Lux (,)))" - (|do [;; :let [_ (prn 'declare-tags module (&/->seq tag-names) (&type/show-type type))] - _ (ensure-undeclared-tags module tag-names) + (|do [_ (ensure-undeclared-tags module tag-names) type-name (&type/type-name type) :let [[_module _name] type-name] _ (&/assert! (= module _module) diff --git a/src/lux/base.clj b/src/lux/base.clj index d76348b9a..7357bd483 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -217,9 +217,6 @@ (if (.equals ^Object k slot) (V $Cons (T (T slot value) table*)) (V $Cons (T (T k v) (|put slot value table*)))) - - ;; _ - ;; (assert false (prn-str '|put (aget table 0))) )) (defn |remove [slot table] @@ -801,7 +798,6 @@ (return* state (get$ $cursor state)))) (defn show-ast [ast] - ;; (prn 'show-ast/GOOD (aget ast 0) (aget ast 1 1 0)) (|case ast [_ ($BoolS ?value)] (pr-str ?value) diff --git a/src/lux/compiler.clj b/src/lux/compiler.clj index 76d3a1eb2..3052ead09 100644 --- a/src/lux/compiler.clj +++ b/src/lux/compiler.clj @@ -38,7 +38,6 @@ (def ^:private !source->last-line (atom nil)) (defn ^:private compile-expression [syntax] - ;; (prn 'compile-expression (&/adt->text syntax)) (|let [[[?type [_file-name _line _column]] ?form] syntax] (|do [^MethodVisitor *writer* &/get-writer :let [debug-label (new Label) @@ -52,8 +51,7 @@ (&&lux/compile-bool compile-expression ?value) (&a/$int ?value) - (do ;; (prn 'compile-expression (&/adt->text syntax)) - (&&lux/compile-int compile-expression ?value)) + (&&lux/compile-int compile-expression ?value) (&a/$real ?value) (&&lux/compile-real compile-expression ?value) @@ -445,7 +443,6 @@ id &/gen-id [file-name _ _] &/cursor :let [class-name (str (&host/->module-class module) "/" id) - ;; _ (prn 'eval! id class-name) =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) class-name nil "java/lang/Object" nil) @@ -472,7 +469,6 @@ return)))) (defn ^:private compile-module [name] - ;; (prn 'compile-module name (&&cache/cached? name)) (let [file-name (str name ".lux")] (|do [file-content (&&io/read-file file-name) :let [file-hash (hash file-content)]] @@ -492,9 +488,7 @@ .visitEnd) (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/compiler-field "Ljava/lang/String;" nil &&/version) .visitEnd) - (.visitSource file-name nil)) - ;; _ (prn 'compile-module name =class) - ]] + (.visitSource file-name nil))]] (fn [state] (|case ((&/with-writer =class (&/exhaust% compiler-step)) @@ -529,7 +523,6 @@ (&/fold str ""))) .visitEnd) (.visitEnd)) - ;; _ (prn 'CLOSED name =class) ] _ (&/flag-compiled-module name)] (&&/save-class! &/module-class-name (.toByteArray =class))) diff --git a/src/lux/compiler/cache.clj b/src/lux/compiler/cache.clj index f1b21f6fd..a35225acf 100644 --- a/src/lux/compiler/cache.clj +++ b/src/lux/compiler/cache.clj @@ -72,94 +72,78 @@ :let [redo-cache (|do [_ (delete module) _ (compile-module module)] (return false))]] - (do ;; (prn 'load module 'sources already-loaded? - ;; (&/->seq _modules)) - (if already-loaded? - (return true) - (if (cached? module) - (do ;; (prn 'load/HASH module module-hash) - (let [module* (&host/->class-name module) - module-path (str &&/output-dir module) - class-name (str module* "._") - ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) - (&&/load-class! loader class-name))] - (if (and (= module-hash (get-field &/hash-field module-meta)) - (= &&/version (get-field &/compiler-field module-meta))) - (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator))) - ;; _ (prn 'load/IMPORTS module imports) - ] - (|do [loads (&/map% (fn [_import] - (|do [content (&&io/read-file (str _import ".lux")) - _ (load _import (hash content) compile-module)] - (&/cached-module? _import))) - (if (= [""] imports) - &/Nil$ - (&/->list imports)))] - (if (->> loads &/->seq (every? true?)) - (do (doseq [^File file (seq (.listFiles (File. module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)] - :when (not= "_.class" file-name)] - (let [real-name (second (re-find #"^(.*)\.class$" file-name)) - bytecode (read-file file) - ;; _ (prn 'load module real-name) - ] - (swap! !classes assoc (str module* "." real-name) bytecode))) - (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) - ;; _ (prn module '(get-field &/tags-field module-meta) - ;; (string/split (get-field &/tags-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator)))) - tag-groups (let [all-tags (get-field &/tags-field module-meta)] - (if (= "" all-tags) - &/Nil$ - (-> all-tags - (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) - (->> (map (fn [_group] - ;; (prn '_group _group) - (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] - ;; (prn '[_type _tags] [_type _tags]) - (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) - &/->list)))] - ;; (prn 'load module defs) - (|do [_ (&a-module/enter-module module) - _ (&/flag-cached-module module) - _ (&a-module/set-imports imports) - _ (&/map% (fn [_def] - (let [[_exported? _name _ann] (string/split _def #" ") - ;; _ (prn '[_exported? _name _ann] [_exported? _name _ann]) - ] - (|do [_ (case _ann - "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field &/datum-field def-class)] - (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) - "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - def-value (get-field &/datum-field def-class)] - (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] - (&a-module/declare-macro module _name))) - "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) - ;; _ (println "Fetching _meta" module _name (str module* "." (&/normalize-name _name)) def-class) - def-meta (get-field &/meta-field def-class)] - (|case def-meta - (&/$ValueD def-type _) - (&a-module/define module _name def-meta def-type))) - ;; else - (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] - (|do [__type (&a-module/def-type __module __name)] - (do ;; (prn '__type [__module __name] (&type/show-type __type)) - (&a-module/def-alias module _name __module __name __type)))))] - (if (= &&/exported-true _exported?) - (&a-module/export module _name) - (return nil))) - )) - (if (= [""] defs) - &/Nil$ - (&/->list defs))) - _ (&/map% (fn [group] - (|let [[_type _tags] group] - (|do [=type (&a-module/type-def module _type)] - (&a-module/declare-tags module _tags =type)))) - tag-groups)] - (return true)))) - redo-cache))) - redo-cache) - )) - redo-cache))))) + (if already-loaded? + (return true) + (if (cached? module) + (let [module* (&host/->class-name module) + module-path (str &&/output-dir module) + class-name (str module* "._") + ^Class module-meta (do (swap! !classes assoc class-name (read-file (File. (str module-path "/_.class")))) + (&&/load-class! loader class-name))] + (if (and (= module-hash (get-field &/hash-field module-meta)) + (= &&/version (get-field &/compiler-field module-meta))) + (let [imports (string/split (get-field &/imports-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/import-separator)))] + (|do [loads (&/map% (fn [_import] + (|do [content (&&io/read-file (str _import ".lux")) + _ (load _import (hash content) compile-module)] + (&/cached-module? _import))) + (if (= [""] imports) + &/Nil$ + (&/->list imports)))] + (if (->> loads &/->seq (every? true?)) + (do (doseq [^File file (seq (.listFiles (File. module-path))) + :when (not (.isDirectory file)) + :let [file-name (.getName file)] + :when (not= "_.class" file-name)] + (let [real-name (second (re-find #"^(.*)\.class$" file-name)) + bytecode (read-file file)] + (swap! !classes assoc (str module* "." real-name) bytecode))) + (let [defs (string/split (get-field &/defs-field module-meta) (re-pattern (java.util.regex.Pattern/quote &&/def-separator))) + tag-groups (let [all-tags (get-field &/tags-field module-meta)] + (if (= "" all-tags) + &/Nil$ + (-> all-tags + (string/split (re-pattern (java.util.regex.Pattern/quote &&/tag-group-separator))) + (->> (map (fn [_group] + (let [[_type _tags] (string/split _group (re-pattern (java.util.regex.Pattern/quote &&/type-separator)))] + (&/T _type (&/->list (string/split _tags (re-pattern (java.util.regex.Pattern/quote &&/tag-separator))))))))) + &/->list)))] + (|do [_ (&a-module/enter-module module) + _ (&/flag-cached-module module) + _ (&a-module/set-imports imports) + _ (&/map% (fn [_def] + (let [[_exported? _name _ann] (string/split _def #" ")] + (|do [_ (case _ann + "T" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field &/datum-field def-class)] + (&a-module/define module _name (&/V &/$TypeD def-value) &type/Type)) + "M" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-value (get-field &/datum-field def-class)] + (|do [_ (&a-module/define module _name (&/V &/$ValueD (&/T &type/Macro def-value)) &type/Macro)] + (&a-module/declare-macro module _name))) + "V" (let [def-class (&&/load-class! loader (str module* "." (&/normalize-name _name))) + def-meta (get-field &/meta-field def-class)] + (|case def-meta + (&/$ValueD def-type _) + (&a-module/define module _name def-meta def-type))) + ;; else + (let [[_ __module __name] (re-find #"^A(.*);(.*)$" _ann)] + (|do [__type (&a-module/def-type __module __name)] + (&a-module/def-alias module _name __module __name __type))))] + (if (= &&/exported-true _exported?) + (&a-module/export module _name) + (return nil))) + )) + (if (= [""] defs) + &/Nil$ + (&/->list defs))) + _ (&/map% (fn [group] + (|let [[_type _tags] group] + (|do [=type (&a-module/type-def module _type)] + (&a-module/declare-tags module _tags =type)))) + tag-groups)] + (return true)))) + redo-cache))) + redo-cache) + ) + redo-cache)))) diff --git a/src/lux/compiler/host.clj b/src/lux/compiler/host.clj index 6d926e6da..c364091ba 100644 --- a/src/lux/compiler/host.clj +++ b/src/lux/compiler/host.clj @@ -220,7 +220,8 @@ ^MethodVisitor *writer* &/get-writer :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] + :let [_ (when (not= "" ?method) + (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] _ (&/map2% (fn [class-name arg] (|do [ret (compile arg) :let [_ (prepare-arg! *writer* class-name)]] @@ -233,27 +234,9 @@ compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ;; compile-jvm-invokespecial Opcodes/INVOKESPECIAL + compile-jvm-invokespecial Opcodes/INVOKESPECIAL ) -(defn compile-jvm-invokespecial [compile ?class ?method ?classes ?object ?args ?output-type] - (|do [:let [?class* (&host/->class (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host/->type-signature ?classes)) ")" (&host/->java-sig ?output-type))] - _ (compile ?object) - ;; :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*)] - :let [_ (when (not= "" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - (defn compile-jvm-null [compile] (|do [^MethodVisitor *writer* &/get-writer :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] @@ -422,10 +405,10 @@ (defn ^:private compile-annotation [writer ann] (doto ^AnnotationVisitor (.visitAnnotation writer (&host/->class (:name ann)) true) - (-> (.visit param-name param-value) - (->> (|let [[param-name param-value] param]) - (doseq [param (&/->seq (:params ann))]))) - (.visitEnd)) + (-> (.visit param-name param-value) + (->> (|let [[param-name param-value] param]) + (doseq [param (&/->seq (:params ann))]))) + (.visitEnd)) nil) (defn ^:private compile-field [^ClassWriter writer field] @@ -466,10 +449,6 @@ (.visitInsn writer Opcodes/ARETURN))) (defn ^:private compile-method [compile ^ClassWriter class-writer method] - ;; (prn 'compile-method/_0 (dissoc method :inputs :output :body)) - ;; (prn 'compile-method/_1 (&/adt->text (:inputs method))) - ;; (prn 'compile-method/_2 (&/adt->text (:output method))) - ;; (prn 'compile-method/_3 (&/adt->text (:body method))) (|let [signature (str "(" (&/fold str "" (&/|map &host/->type-signature (:inputs method))) ")" (&host/->type-signature (:output method)))] (&/with-writer (.visitMethod class-writer (&host/modifiers->int (:modifiers method)) @@ -518,9 +497,7 @@ ) (defn compile-jvm-class [compile ?name ?super-class ?interfaces ?anns ?fields ?methods env] - (|do [;; :let [_ (prn 'compile-jvm-class/_0)] - module &/get-module-name - ;; :let [_ (prn 'compile-jvm-class/_1)] + (|do [module &/get-module-name [file-name _ _] &/cursor :let [full-name (str module "/" ?name) super-class* (&host/->class ?super-class) @@ -531,17 +508,12 @@ _ (&/|map (partial compile-annotation =class) ?anns) _ (&/|map (partial compile-field =class) ?fields)] - ;; :let [_ (prn 'compile-jvm-class/_2)] _ (&/map% (partial compile-method compile =class) ?methods) - ;; :let [_ (prn 'compile-jvm-class/_3)] :let [_ (when env - (add-anon-class- =class full-name env))] - ;; :let [_ (prn 'compile-jvm-class/_4)] - ] + (add-anon-class- =class full-name env))]] (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) (defn compile-jvm-interface [compile ?name ?supers ?anns ?methods] - ;; (prn 'compile-jvm-interface (->> ?supers &/->seq pr-str)) (|do [module &/get-module-name [file-name _ _] &/cursor] (let [=interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) @@ -571,9 +543,7 @@ (return nil))) catch-boundaries (&/|map (fn [[?ex-class ?ex-idx ?catch-body]] [?ex-class (new Label) (new Label)]) ?catches) - _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries) - ;; :let [_ (prn 'HANDLER ?ex-class (&host/->class ?ex-class) $handler-start $handler-end $from $to $catch-finally)] - ] + _ (doseq [[?ex-class $handler-start $handler-end] (&/->seq catch-boundaries)] (doto *writer* (.visitTryCatchBlock $from $to $handler-start (&host/->class ?ex-class)) (.visitTryCatchBlock $handler-start $handler-end $catch-finally nil))) @@ -591,7 +561,6 @@ compile-finally)) ?catches catch-boundaries) - ;; :let [_ (prn 'handlers (&/->seq handlers))] :let [_ (.visitLabel *writer* $catch-finally)] _ (|case ?finally (&/$Some ?finally*) (|do [_ (compile ?finally*) @@ -694,16 +663,12 @@ (defn compile-jvm-program [compile ?body] (|do [module-name &/get-module-name - ;; :let [_ (prn 'compile-jvm-program module-name)] ^ClassWriter *writer* &/get-writer] (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) (.visitCode)) (|do [^MethodVisitor main-writer &/get-writer - :let [;; _ (prn "#1" module-name *writer*) - $loop (new Label) - ;; _ (prn "#2") + :let [$loop (new Label) $end (new Label) - ;; _ (prn "#3") _ (doto main-writer ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S @@ -772,20 +737,14 @@ (.visitInsn Opcodes/POP) ;; V (.visitVarInsn Opcodes/ASTORE (int 0)) ;; ) - ;; _ (prn "#4") ] _ (compile ?body) - :let [;; _ (prn "#5") - _ (doto main-writer + :let [_ (doto main-writer (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature)) - ;; _ (prn "#6") - ] + (.visitMethodInsn Opcodes/INVOKEINTERFACE &&/function-class "apply" &&/apply-signature))] :let [_ (doto main-writer (.visitInsn Opcodes/POP) (.visitInsn Opcodes/RETURN) (.visitMaxs 0 0) - (.visitEnd)) - ;; _ (prn "#7") - ]] + (.visitEnd))]] (return nil))))) diff --git a/src/lux/compiler/io.clj b/src/lux/compiler/io.clj index 4cd6284b7..bc6fa854d 100644 --- a/src/lux/compiler/io.clj +++ b/src/lux/compiler/io.clj @@ -19,7 +19,6 @@ ;; [Resources] (defn read-file [^String file-name] - ;; (prn 'read-file file-name) (let [file (new java.io.File (str &&/input-dir "/" file-name))] (if (.exists file) (return (slurp file)) diff --git a/src/lux/compiler/lambda.clj b/src/lux/compiler/lambda.clj index 77dc316b8..cb8ad0037 100644 --- a/src/lux/compiler/lambda.clj +++ b/src/lux/compiler/lambda.clj @@ -92,7 +92,6 @@ (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 [[file-name _ _] &/cursor :let [name (&host/location (&/|tail ?scope)) class-name (str (&host/->module-class (&/|head ?scope)) "/" name) diff --git a/src/lux/compiler/lux.clj b/src/lux/compiler/lux.clj index f7cd905e8..01e4ffd5b 100644 --- a/src/lux/compiler/lux.clj +++ b/src/lux/compiler/lux.clj @@ -68,7 +68,6 @@ (return nil))) (defn compile-variant [compile ?tag ?value] - ;; (prn 'compile-variant ?tag (class ?tag)) (|do [^MethodVisitor *writer* &/get-writer :let [_ (doto *writer* (.visitLdcInsn (int 2)) @@ -118,8 +117,7 @@ (|do [^MethodVisitor **writer** &/get-writer] (|case def-type "type" - (|do [:let [;; ?type* (&&type/->analysis ?type) - _ (doto **writer** + (|do [:let [_ (doto **writer** ;; Tail: Begin (.visitLdcInsn (int 2)) ;; S (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; V @@ -131,17 +129,12 @@ (.visitInsn Opcodes/DUP) ;; VV (.visitLdcInsn (int 1)) ;; VVI (.visitFieldInsn Opcodes/GETSTATIC current-class &/datum-field "Ljava/lang/Object;") - ;; (.visitInsn Opcodes/ACONST_NULL) ;; VVIN (.visitInsn Opcodes/AASTORE) ;; V - )] - ;; _ (compile ?type*) - ;; :let [_ (.visitInsn **writer** Opcodes/AASTORE)] - ] + )]] (return nil)) "value" - (|let [;; _ (prn '?body (aget ?body 0) (aget ?body 1 0)) - ?def-type (|case ?body + (|let [?def-type (|case ?body [[?def-type ?def-cursor] (&a/$ann ?def-value ?type-expr)] ?type-expr diff --git a/src/lux/host.clj b/src/lux/host.clj index 133c50e9b..916f94419 100644 --- a/src/lux/host.clj +++ b/src/lux/host.clj @@ -113,7 +113,6 @@ (do-template [ ] (defn [class-loader target method-name args] - ;; (prn ' target method-name) (|let [target-class (Class/forName (&host-type/as-obj target) true class-loader)] (if-let [^Method method (first (for [^Method =method (.getDeclaredMethods (Class/forName (&host-type/as-obj target) true class-loader)) :when (and (.equals ^Object method-name (.getName =method)) diff --git a/src/lux/lexer.clj b/src/lux/lexer.clj index fd694c51c..651f9ecce 100644 --- a/src/lux/lexer.clj +++ b/src/lux/lexer.clj @@ -109,10 +109,8 @@ ? (&module/exists? token)] (if ? (return (&/T meta (&/T token local-token))) - (|do [unaliased (do ;; (prn "Unaliasing: " token ";" local-token) - (&module/dealias token))] - (do ;; (prn "Unaliased: " unaliased ";" local-token) - (return (&/T meta (&/T unaliased local-token))))))) + (|do [unaliased (&module/dealias token)] + (return (&/T meta (&/T unaliased local-token)))))) (return (&/T meta (&/T "" token))) ))) (|do [[meta _] (&reader/read-text ";;") diff --git a/src/lux/packager/program.clj b/src/lux/packager/program.clj index 7337bcb02..83927ba0d 100644 --- a/src/lux/packager/program.clj +++ b/src/lux/packager/program.clj @@ -33,7 +33,6 @@ (defn ^:private write-class! [^String path ^File file ^JarOutputStream out] "(-> Text File JarOutputStream Unit)" - ;; (prn 'write-class! path file) (with-open [in (new BufferedInputStream (new FileInputStream file))] (let [buffer (byte-array (* 10 kilobyte))] (doto out @@ -49,8 +48,7 @@ (let [output-dir-size (.length &&/output-dir)] (defn ^:private write-module! [^File file ^JarOutputStream out] "(-> File JarOutputStream Unit)" - (let [module-name (.substring (.getPath file) output-dir-size) ;; (.getName file) - ;; _ (prn 'write-module! module-name file (.getPath file) (.substring (.getPath file) output-dir-size)) + (let [module-name (.substring (.getPath file) output-dir-size) inner-files (.listFiles file) inner-modules (filter #(.isDirectory ^File %) inner-files) inner-classes (filter #(not (.isDirectory ^File %)) inner-files)] @@ -80,7 +78,6 @@ (with-open [is (->> jar-file (new FileInputStream) (new JarInputStream))] (loop [^JarEntry entry (.getNextJarEntry is)] (when entry - ;; (prn 'add-jar! (.getName entry) (.isDirectory entry)) (when (and (not (.isDirectory entry)) (not (.startsWith (.getName entry) "META-INF/"))) (let [entry-data (read-stream is)] @@ -94,7 +91,6 @@ ;; [Resources] (defn package [module] "(-> Text (,))" - ;; (prn 'package module) (with-open [out (new JarOutputStream (->> &&/output-package (new File) (new FileOutputStream)) (manifest module))] (doseq [$group (.listFiles (new File &&/output-dir))] (write-module! $group out)) diff --git a/src/lux/type.clj b/src/lux/type.clj index ed0dd8898..fb9c63783 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -36,10 +36,8 @@ (defn App$ [fun arg] (&/V &/$AppT (&/T fun arg))) (defn Tuple$ [members] - ;; (assert (|list? members)) (&/V &/$TupleT members)) (defn Variant$ [members] - ;; (assert (|list? members)) (&/V &/$VariantT members)) (defn Univ$ [env body] (&/V &/$UnivQ (&/T env body))) @@ -149,7 +147,6 @@ (deref id) _ - ;; (assert false (str "[Type Error] Type is not a variable: " (show-type type))) (fail (str "[Type Error] Type is not a variable: " (show-type type))) )) @@ -406,8 +403,6 @@ "\n")) (defn beta-reduce [env type] - ;; (when @!flag - ;; (prn 'beta-reduce (show-type type))) (|case type (&/$VariantT ?members) (Variant$ (&/|map (partial beta-reduce env) ?members)) @@ -442,8 +437,6 @@ )) (defn apply-type [type-fn param] - ;; (when @!flag - ;; (prn 'apply-type (show-type type-fn) (show-type param))) (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env @@ -528,40 +521,6 @@ (check* class-loader fixpoints invariant?? 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 invariant?? (App$ F1 A1) (App$ F2 A2))) - ;; state) - ;; (&/$Right state* output) - ;; (return* state* output) - - ;; (&/$Left _) - ;; ((check* class-loader fixpoints invariant?? (App$ F1 A1) actual) - ;; state)))) - ;; state) - ;; (&/$Right state* output) - ;; (return* state* output) - - ;; (&/$Left _) - ;; (|case ((|do [F2 (deref ?aid)] - ;; (check* class-loader fixpoints invariant?? expected (App$ F2 A2))) - ;; state) - ;; (&/$Right state* output) - ;; (return* state* output) - - ;; (&/$Left _) - ;; ((|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) - ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? A1 A2)] - ;; (return (&/T fixpoints** nil))) - ;; state)))) - - ;; (|do [_ (check* class-loader fixpoints invariant?? (Var$ ?eid) (Var$ ?aid)) - ;; _ (check* class-loader fixpoints invariant?? A1 A2)] - ;; (return (&/T fixpoints nil))) - [(&/$AppT (&/$VarT ?id) A1) (&/$AppT F2 A2)] (fn [state] (|case ((|do [F1 (deref ?id)] @@ -578,13 +537,6 @@ (return (&/T fixpoints** nil))) state))) - ;; [[&/$AppT [[&/$VarT ?id] A1]] [&/$AppT [F2 A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? (Var$ ?id) F2) - ;; e* (apply-type F2 A1) - ;; a* (apply-type F2 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] - ;; (return (&/T fixpoints** nil))) - [(&/$AppT F1 A1) (&/$AppT (&/$VarT ?id) A2)] (fn [state] (|case ((|do [F2 (deref ?id)] @@ -601,17 +553,6 @@ (return (&/T fixpoints** nil))) state))) - ;; [[&/$AppT [F1 A1]] [&/$AppT [[&/$VarT ?id] A2]]] - ;; (|do [[fixpoints* _] (check* class-loader fixpoints invariant?? F1 (Var$ ?id)) - ;; e* (apply-type F1 A1) - ;; a* (apply-type F1 A2) - ;; [fixpoints** _] (check* class-loader fixpoints* invariant?? e* a*)] - ;; (return (&/T fixpoints** nil))) - - ;; [(&/$AppT eF eA) (&/$AppT aF aA)] - ;; (|do [_ (check* class-loader fixpoints invariant?? eF aF)] - ;; (check* class-loader fixpoints invariant?? eA aA)) - [(&/$AppT F A) _] (let [fp-pair (&/T expected actual) _ (when (> (&/|length fixpoints) 40) @@ -641,11 +582,7 @@ (|do [$arg existential expected* (apply-type expected $arg)] (check* class-loader fixpoints invariant?? expected* actual)) - ;; (with-var - ;; (fn [$arg] - ;; (|do [expected* (apply-type expected $arg)] - ;; (check* class-loader fixpoints invariant?? expected* actual)))) - + [_ (&/$UnivQ _)] (with-var (fn [$arg] diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index e121cee86..989c0d665 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -68,20 +68,17 @@ Unit (&/V &/$TupleT (&/|list))] (defn class->type [^Class class] "(-> Class Type)" - (do ;; (prn 'class->type/_0 class (.getSimpleName class) (.getName class)) - (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] - (let [base (or arr-base simple-base)] - ;; (prn 'class->type/_1 class base arr-brackets) - (if (.equals "void" base) - Unit - (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) - (&/V &/$DataT (&/T base &/Nil$)) - (range (count (or arr-brackets ""))))) - ))))) + (if-let [[_ _ arr-brackets arr-base simple-base] (re-find class-name-re (.getName class))] + (let [base (or arr-base simple-base)] + (if (.equals "void" base) + Unit + (reduce (fn [inner _] (&/V &/$DataT (&/T array-data-tag (&/|list inner)))) + (&/V &/$DataT (&/T base &/Nil$)) + (range (count (or arr-brackets ""))))) + )))) (defn instance-param [existential matchings refl-type] "(-> (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" - ;; (prn 'instance-param refl-type (class refl-type)) (cond (instance? Class refl-type) (return (class->type refl-type)) -- cgit v1.2.3 From 57ed0ef20db8f6ae926c1f7580f5bfa26928612b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 29 Sep 2015 07:40:29 -0400 Subject: - Returned to old format of type-environments where odds are arguments & evens are quantifiers. --- src/lux/analyser/case.clj | 2 +- src/lux/analyser/host.clj | 2 +- src/lux/type.clj | 24 ++++++++++++------------ 3 files changed, 14 insertions(+), 14 deletions(-) (limited to 'src') diff --git a/src/lux/analyser/case.clj b/src/lux/analyser/case.clj index 9640cf88a..ca4e0edeb 100644 --- a/src/lux/analyser/case.clj +++ b/src/lux/analyser/case.clj @@ -67,7 +67,7 @@ (&type/with-var (fn [$var] (|do [=type (&type/apply-type type $var)] - (adjust-type* (&/Cons$ (&/T _aenv 0 $var) (&/|map update-up-frame up)) =type)))) + (adjust-type* (&/Cons$ (&/T _aenv 1 $var) (&/|map update-up-frame up)) =type)))) (&/$TupleT ?members) (|do [(&/$TupleT ?members*) (&/fold% (fn [_abody ena] diff --git a/src/lux/analyser/host.clj b/src/lux/analyser/host.clj index 33553985b..7e1f92d19 100644 --- a/src/lux/analyser/host.clj +++ b/src/lux/analyser/host.clj @@ -126,7 +126,7 @@ (|do [:let [[idx types] idx+types] [idx* real-type] (clean-gtype-var idx gtype-var)] (return (&/T idx* (&/Cons$ real-type types))))) - (&/T 0 (&/|list)) + (&/T 1 (&/|list)) gtype-vars)] (return clean-types))) diff --git a/src/lux/type.clj b/src/lux/type.clj index fb9c63783..6ae542b68 100644 --- a/src/lux/type.clj +++ b/src/lux/type.clj @@ -57,7 +57,7 @@ (def IO (Named$ (&/T "lux/data" "IO") (Univ$ empty-env - (Lambda$ Unit (Bound$ 0))))) + (Lambda$ Unit (Bound$ 1))))) (def List (Named$ (&/T "lux" "List") @@ -66,9 +66,9 @@ ;; lux;Nil Unit ;; lux;Cons - (Tuple$ (&/|list (Bound$ 0) - (App$ (Bound$ 1) - (Bound$ 0)))) + (Tuple$ (&/|list (Bound$ 1) + (App$ (Bound$ 0) + (Bound$ 1)))) ))))) (def Maybe @@ -78,12 +78,12 @@ ;; lux;None Unit ;; lux;Some - (Bound$ 0) + (Bound$ 1) ))))) (def Type (Named$ (&/T "lux" "Type") - (let [Type (App$ (Bound$ 1) (Bound$ 0)) + (let [Type (App$ (Bound$ 0) (Bound$ 1)) TypeList (App$ List Type) TypePair (Tuple$ (&/|list Type Type))] (App$ (Univ$ empty-env @@ -440,8 +440,8 @@ (|case type-fn (&/$UnivQ local-env local-def) (return (beta-reduce (->> local-env - (&/Cons$ type-fn) - (&/Cons$ param)) + (&/Cons$ param) + (&/Cons$ type-fn)) local-def)) (&/$AppT F A) @@ -593,16 +593,16 @@ (with-var (fn [$arg] (|let [expected* (beta-reduce (->> e!env - (&/Cons$ expected) - (&/Cons$ $arg)) + (&/Cons$ $arg) + (&/Cons$ expected)) e!def)] (check* class-loader fixpoints invariant?? expected* actual)))) [_ (&/$ExQ a!env a!def)] (|do [$arg existential] (|let [actual* (beta-reduce (->> a!env - (&/Cons$ expected) - (&/Cons$ $arg)) + (&/Cons$ $arg) + (&/Cons$ expected)) a!def)] (check* class-loader fixpoints invariant?? expected actual*))) -- cgit v1.2.3 From 1ff2c6ced65171a68ef761275a75ba4dc56caf7b Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 30 Sep 2015 16:44:42 -0400 Subject: - Changed the license in the project.clj file (had forgotten until now). - Some minor updates to the standard library. - Some minor bug fixes & improvements. - program.lux has been removed. --- src/lux.clj | 2 +- src/lux/analyser.clj | 83 +++++++++++++++++++++++++++------------------------ src/lux/base.clj | 2 +- src/lux/type/host.clj | 2 +- 4 files changed, 47 insertions(+), 42 deletions(-) (limited to 'src') diff --git a/src/lux.clj b/src/lux.clj index 8cd2c4b80..4b1c15ef7 100644 --- a/src/lux.clj +++ b/src/lux.clj @@ -24,7 +24,7 @@ _ (println "Can't understand command.")) - ;; (System/exit 0) + (System/exit 0) ) (comment diff --git a/src/lux/analyser.clj b/src/lux/analyser.clj index 4ead47916..70a4a6ee9 100644 --- a/src/lux/analyser.clj +++ b/src/lux/analyser.clj @@ -211,6 +211,48 @@ (aba8 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba6 [analyse eval! compile-module compile-token exo-type token] + (|case token + ;; Bitwise operators + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-iand analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ior analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-land analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) + + (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) + (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) + + _ + (aba7 analyse eval! compile-module compile-token exo-type token))) + +(defn ^:private aba5_5 [analyse eval! compile-module compile-token exo-type token] (|case token ;; Primitive conversions (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_d2f")] (&/$Cons ?value (&/$Nil)))) @@ -258,45 +300,8 @@ (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_l2i")] (&/$Cons ?value (&/$Nil)))) (&&host/analyse-jvm-l2i analyse exo-type ?value) - ;; Bitwise operators - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iand")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-iand analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ior")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ior analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ixor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ixor analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ishl analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_ishr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-ishr analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_iushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-iushr analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_land")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-land analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lor analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lxor")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lxor analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshl")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lshl analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lshr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lshr analyse exo-type ?x ?y) - - (&/$FormS (&/$Cons [_ (&/$SymbolS _ "_jvm_lushr")] (&/$Cons ?x (&/$Cons ?y (&/$Nil))))) - (&&host/analyse-jvm-lushr analyse exo-type ?x ?y) - _ - (aba7 analyse eval! compile-module compile-token exo-type token))) + (aba6 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba5 [analyse eval! compile-module compile-token exo-type token] (|case token @@ -411,7 +416,7 @@ (&&host/analyse-jvm-monitorexit analyse exo-type ?monitor) _ - (aba6 analyse eval! compile-module compile-token exo-type token))) + (aba5_5 analyse eval! compile-module compile-token exo-type token))) (defn ^:private aba4 [analyse eval! compile-module compile-token exo-type token] (|case token diff --git a/src/lux/base.clj b/src/lux/base.clj index 7357bd483..e9b8896bf 100644 --- a/src/lux/base.clj +++ b/src/lux/base.clj @@ -376,7 +376,7 @@ init ($Cons x xs*) - (fold f (f init x) xs*))) + (recur f (f init x) xs*))) (defn fold% [f init xs] (|case xs diff --git a/src/lux/type/host.clj b/src/lux/type/host.clj index 989c0d665..d4627b273 100644 --- a/src/lux/type/host.clj +++ b/src/lux/type/host.clj @@ -155,7 +155,7 @@ (let [lineage (trace-lineage sub-class+ super-class+)] (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] (return (&/V &/$DataT (&/T (.getName sub-class*) sub-params*))))) - (fail (str "[Type Error] Classes don't have a subtyping relationship: " sub-class "