aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore3
-rw-r--r--src/lang.clj26
-rw-r--r--src/lang/analyser.clj72
-rw-r--r--src/lang/compiler.clj106
-rw-r--r--src/lang/parser.clj6
-rw-r--r--src/lang/type.clj3
-rw-r--r--test2.lang11
7 files changed, 198 insertions, 29 deletions
diff --git a/.gitignore b/.gitignore
index e04714ba8..fdc7212fc 100644
--- a/.gitignore
+++ b/.gitignore
@@ -7,3 +7,6 @@ pom.xml.asc
*.class
/.lein-*
/.nrepl-port
+LICENSE
+README.md
+doc/intro.md
diff --git a/src/lang.clj b/src/lang.clj
index c497c9923..0bbd74bf6 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -11,25 +11,29 @@
(.write stream data)))
(comment
- ;; TODO: Add lambdas.
;; TODO: Add pattern-matching.
- ;; TODO: Add thunks.
- ;; TODO: Add Java-interop.
- ;; TODO: Do tail-call optimization.
- ;; TODO: Add macros.
- ;; TODO: Add signatures & structures OR type-classes.
- ;; TODO: Add type-level computations.
- ;; TODO: Add interpreter.
- ;; TODO: Re-implement compiler in language.
+ ;; TODO: Add "do" expressions.
;; TODO: Add all the missing literal types.
;; TODO: Allow strings to have escape characters.
- ;; TODO: Add "do" expressions.
;; TODO: Fold all closure classes into one.
;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly.
;; TODO: Add extra arities (apply2, apply3, ..., apply16)
+ ;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples).
+ ;; TODO: Allow "lambdas" to be closures.
+ ;; TODO: Add Java-interop.
+ ;; TODO: Add interpreter.
+ ;; TODO: Add macros.
+ ;; TODO: Re-implement compiler in language.
+ ;; TODO: Add signatures & structures OR type-classes.
+ ;; TODO: Add type-level computations.
+ ;; TODO: Add thunks.
+ ;; TODO: Do tail-call optimization.
+ ;; TODO: Adding metadata to global vars.
+ ;; TODO: Add records.
;; TODO:
;; TODO:
-
+ ;; TODO:
+
(let [source-code (slurp "test2.lang")
tokens (&lexer/lex source-code)
;; _ (prn 'tokens tokens)
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 122d6353d..d00fb7319 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -41,6 +41,28 @@
_
=return))))
+(defn ^:private with-fresh-env [body]
+ (fn [state]
+ (let [=return (body (update-in state [:env]
+ #(-> %
+ (assoc :counter 0)
+ (update-in [:mappings] (fn [ms]
+ (let [ms* (into {} (for [[k v] ms
+ :when (match (:form v)
+ [::local _]
+ false
+ _
+ true)]
+ [k v]))]
+ (prn 'ms ms 'ms* ms*)
+ ms*))))))]
+ (match =return
+ [::&util/ok [?state ?value]]
+ [::&util/ok [(assoc ?state :env (:env state)) ?value]]
+
+ _
+ =return))))
+
(defn ^:private import-class [long-name short-name]
(fn [state]
(let [=class (annotated [::class long-name] ::&type/nothing)]
@@ -73,6 +95,7 @@
(fail* (str "Unmatched token: " token#))))))
(defn analyse-form* [form]
+ (prn 'analyse-form* form)
(fn [state]
(let [old-forms (:forms state)
=return (analyse-form (assoc state :forms (list form)))]
@@ -103,7 +126,9 @@
(defanalyser analyse-ident
[::&parser/ident ?ident]
- (resolve ?ident))
+ (exec [_env (fn [state] [::&util/ok [state (:env state)]])
+ :let [_ (prn 'analyse-ident ?ident _env)]]
+ (resolve ?ident)))
(defanalyser analyse-ann-class
[::&parser/ann-class ?class ?members]
@@ -127,15 +152,22 @@
(defanalyser analyse-fn-call
[::&parser/fn-call ?fn ?args]
- (exec [=fn (analyse-form* ?fn)
- =args (map-m analyse-form* ?args)]
- (return (annotated [::call =fn =args] ::&type/nothing))))
+ (exec [:let [_ (prn 'PRE '?fn ?fn)]
+ =fn (analyse-form* ?fn)
+ :let [_ (prn '=fn =fn)]
+ =args (map-m analyse-form* ?args)
+ :let [_ (prn '=args =args)]]
+ (return (annotated [::call =fn =args] [::&type/object "java.lang.Object" []]))))
(defanalyser analyse-if
[::&parser/if ?test ?then ?else]
(exec [=test (analyse-form* ?test)
+ :let [_ (prn '=test =test)]
+ :let [_ (prn 'PRE '?then ?then)]
=then (analyse-form* ?then)
- =else (analyse-form* ?else)]
+ :let [_ (prn '=then =then)]
+ =else (analyse-form* ?else)
+ :let [_ (prn '=else =else)]]
(return (annotated [::if =test =then =else] ::&type/nothing))))
(defanalyser analyse-let
@@ -181,14 +213,14 @@
?ident))]
(exec [[=function =args =return] (within :types (&type/fresh-function (count args)))
:let [_ (prn '[=function =args =return] [=function =args =return])]
- :let [env (-> {}
- (assoc ?name =function)
- (into (map vector args =args)))
- _ (prn 'env env)]
+ ;; :let [env (-> {}
+ ;; (assoc ?name =function)
+ ;; (into (map vector args =args)))
+ ;; _ (prn 'env env)]
=value (reduce (fn [inner [label type]]
(with-local label type inner))
(analyse-form* ?value)
- (map vector args =args))
+ (reverse (map vector args =args)))
:let [_ (prn '=value =value)]
=function (within :types (exec [_ (&type/solve =return (:type =value))]
(&type/clean =function)))
@@ -199,6 +231,25 @@
(return (annotated [::def [?name args] =value] ::&type/nothing))))
))
+(defanalyser analyse-lambda
+ [::&parser/lambda ?args ?body]
+ (exec [:let [_ (prn 'analyse-lambda ?args ?body)]
+ [=function =args =return] (within :types (&type/fresh-function (count ?args)))
+ :let [_ (prn '[=function =args =return] [=function =args =return])]
+ :let [_ (prn 'PRE/?body ?body)]
+ _env (fn [state] [::&util/ok [state (:env state)]])
+ :let [_ (prn 'analyse-lambda _env)]
+ =body (with-fresh-env
+ (reduce (fn [inner [label type]]
+ (with-local label type inner))
+ (analyse-form* ?body)
+ (reverse (map vector ?args =args))))
+ :let [_ (prn '=body =body)]
+ =function (within :types (exec [_ (&type/solve =return (:type =body))]
+ (&type/clean =function)))
+ :let [_ (prn '=function =function)]]
+ (return (annotated [::lambda ?args =body] =function))))
+
(defanalyser analyse-import
[::&parser/import ?class]
(exec [_ (import-class ?class (last (string/split ?class #"\.")))]
@@ -217,6 +268,7 @@
analyse-string
analyse-variant
analyse-tuple
+ analyse-lambda
analyse-ident
analyse-ann-class
analyse-static-access
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index e8f0207b3..b7079fecf 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -26,6 +26,7 @@
`(defn ~name [~'*state*]
(let [~'*class-name* (:class-name ~'*state*)
~'*writer* (:writer ~'*state*)
+ ~'*parent* (:parent ~'*state*)
~'*type* (:type (:form ~'*state*))]
(match (:form (:form ~'*state*))
~match
@@ -61,7 +62,10 @@
(->type-signature ?name)
[::&type/variant ?tag ?value]
- (->type-signature +variant-class+)))
+ (->type-signature +variant-class+)
+
+ [::&type/function ?args ?return]
+ (->java-sig [::&type/object "test2/Function" []])))
;; [Utils/Compilers]
(defcompiler ^:private compile-literal
@@ -119,6 +123,20 @@
[::&analyser/call ?fn ?args]
(do (prn 'compile-call (:form ?fn) ?fn ?args)
(match (:form ?fn)
+ [::&analyser/local _]
+ (do (compile-form (assoc *state* :form ?fn))
+ (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
+ (doseq [arg ?args]
+ (compile-form (assoc *state* :form arg))
+ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
+
+ [::&analyser/lambda _ ?body]
+ (do (compile-form (assoc *state* :form ?fn))
+ (let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"]
+ (doseq [arg ?args]
+ (compile-form (assoc *state* :form arg))
+ (.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))))
+
[::&analyser/global ?owner-class ?fn-name]
(let [apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
signature "()V"
@@ -127,7 +145,7 @@
(.visitTypeInsn Opcodes/NEW call-class)
(.visitInsn Opcodes/DUP)
(.visitMethodInsn Opcodes/INVOKESPECIAL call-class "<init>" signature))
- (doseq [arg (reverse ?args)]
+ (doseq [arg ?args]
(compile-form (assoc *state* :form arg))
(.visitMethodInsn *writer* Opcodes/INVOKEINTERFACE "test2/Function" "apply" apply-signature))
))))
@@ -143,7 +161,8 @@
(doseq [arg ?args]
(compile-form (assoc *state* :form arg)))
(doto *writer*
- (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") ?method "(Ljava/lang/Object;)V"))))
+ (.visitMethodInsn Opcodes/INVOKEVIRTUAL (->class "java.io.PrintStream") ?method "(Ljava/lang/Object;)V")
+ (.visitInsn Opcodes/ACONST_NULL))))
(defcompiler ^:private compile-ann-class
[::&analyser/ann-class ?class ?members]
@@ -170,6 +189,7 @@
(let [start-label (new Label)
end-label (new Label)
?idx (int ?idx)]
+ (prn '(:type ?value) (:type ?value) (->java-sig (:type ?value)))
(.visitLocalVariable *writer* ?label (->java-sig (:type ?value)) nil start-label end-label ?idx)
(assert (compile-form (assoc *state* :form ?value)) "CAN't COMPILE LET-VALUE")
(doto *writer*
@@ -249,7 +269,7 @@
=method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
(.visitCode))]
;; (prn 'FN/?body ?body)
- (assert (compile-form (assoc *state* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body)))
+ (assert (compile-form (assoc *state* :parent *writer* :writer =method :form ?body)) (str "Body couldn't compile: " (pr-str ?body)))
(doto =method
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
@@ -258,7 +278,7 @@
_ (prn 'signature signature)
=method (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) ?name signature nil nil)
(.visitCode))]
- (compile-form (assoc *state* :writer =method :form ?body))
+ (compile-form (assoc *state* :parent *writer* :writer =method :form ?body))
(doto =method
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
@@ -266,6 +286,78 @@
(compile-method-function *writer* *class-name* ?name (count ?args)))))
)))
+(defcompiler ^:private compile-lambda
+ [::&analyser/lambda ?args ?body]
+ (let [num-args (count ?args)
+ signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")
+ outer-class (->class *class-name*)
+ clo-field-sig (->type-signature "java.lang.Object")
+ apply-signature "(Ljava/lang/Object;)Ljava/lang/Object;"
+ real-signature (str "(" (apply str (repeat num-args "Ljava/lang/Object;")) ")" "Ljava/lang/Object;")]
+ (doseq [idx (range num-args)
+ :let [has-next? (not= idx (dec num-args))
+ local-name (str "lambda_" idx)
+ current-class (str outer-class "$" local-name)
+ next-class (str outer-class "$" "lambda_" (inc idx))
+ current-signature (str "(" (apply str (repeat idx "Ljava/lang/Object;")) ")" "V")
+ next-signature (str "(" (apply str (repeat (inc idx) "Ljava/lang/Object;")) ")" "V")]]
+ (.visitInnerClass *parent* current-class outer-class local-name (+ Opcodes/ACC_STATIC Opcodes/ACC_SYNTHETIC))
+ (let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
+ (.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
+ current-class nil "java/lang/Object" (into-array ["test2/Function"])))
+ _ (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" current-signature nil nil)
+ (.visitCode)
+ (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Object" "<init>" "()V")
+ (-> (doto (.visitVarInsn Opcodes/ALOAD 0)
+ (.visitVarInsn Opcodes/ALOAD (inc clo_idx))
+ (.visitFieldInsn Opcodes/PUTFIELD current-class field-name clo-field-sig))
+ (->> (let [field-name (str "_" clo_idx)]
+ (doto (.visitField =class Opcodes/ACC_PUBLIC field-name clo-field-sig nil nil)
+ (.visitEnd)))
+ (dotimes [clo_idx idx])))
+ (.visitInsn Opcodes/RETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ =method (doto (.visitMethod =class Opcodes/ACC_PUBLIC "apply" apply-signature nil nil)
+ (.visitCode))
+ _ (do (when has-next?
+ (doto =method
+ (.visitTypeInsn Opcodes/NEW next-class)
+ (.visitInsn Opcodes/DUP)))
+ (doto =method
+ (-> (doto (.visitVarInsn Opcodes/ALOAD (int 0))
+ (.visitFieldInsn Opcodes/GETFIELD current-class (str "_" clo_idx) clo-field-sig))
+ (->> (dotimes [clo_idx idx])))
+ (.visitVarInsn Opcodes/ALOAD (int 1)))
+ (if has-next?
+ (.visitMethodInsn =method Opcodes/INVOKESPECIAL next-class "<init>" next-signature)
+ (.visitMethodInsn =method Opcodes/INVOKESTATIC outer-class "lambda_impl" real-signature))
+ (doto =method
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ (.visitEnd =class))]
+ (println "OUTPUT LAMBDA:" (str current-class ".class"))
+ (write-file (str current-class ".class") (.toByteArray =class))))
+ (let [=method (doto (.visitMethod *parent* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "lambda_impl" real-signature nil nil)
+ (.visitCode))]
+ (prn '(:form ?body) (:form ?body))
+ (compile-form (assoc *state* :parent *parent* :writer =method :form ?body))
+ (doto =method
+ (.visitInsn Opcodes/ARETURN)
+ (.visitMaxs 0 0)
+ (.visitEnd))
+ ;; (compile-form (assoc *state* :writer =method :form ?body))
+ ;; (compile-method-function *writer* *class-name* ?name (count ?args))
+ )
+ (let [init-class (str outer-class "$" "lambda_0")]
+ (doto *writer*
+ (.visitTypeInsn Opcodes/NEW init-class)
+ (.visitInsn Opcodes/DUP)
+ (.visitMethodInsn Opcodes/INVOKESPECIAL init-class "<init>" "()V")))
+ ))
+
(defcompiler ^:private compile-defclass
[::&analyser/defclass [?package ?name] ?members]
(let [parent-dir (->package ?package)
@@ -351,6 +443,7 @@
compile-ann-class
compile-if
compile-let
+ compile-lambda
compile-def
compile-defclass
compile-definterface
@@ -372,7 +465,8 @@
;; "output" nil "java/lang/Object" nil))
state {:class-name class-name
:writer =class
- :form nil}]
+ :form nil
+ :parent nil}]
;; (doto (.visitMethod =class Opcodes/ACC_PUBLIC "<init>" "()V" nil nil)
;; (.visitCode)
;; (.visitVarInsn Opcodes/ALOAD 0)
diff --git a/src/lang/parser.clj b/src/lang/parser.clj
index 3149cf5d4..2f9a26c66 100644
--- a/src/lang/parser.clj
+++ b/src/lang/parser.clj
@@ -56,6 +56,11 @@
(partition 2 ?parts)))]
(return [::record =kvs])))
+(defparser ^:private parse-lambda
+ [::&lexer/list ([[::&lexer/ident "lambda"] [::&lexer/tuple ?args] ?body] :seq)]
+ (exec [=body (apply-m parse-form (list ?body))]
+ (return [::lambda (mapv ident->string ?args) =body])))
+
(defparser ^:private parse-def
[::&lexer/list ([[::&lexer/ident "def"] ?name ?body] :seq)]
(exec [=name (apply-m parse-form (list ?name))
@@ -192,6 +197,7 @@
parse-ident
parse-tuple
parse-record
+ parse-lambda
parse-def
parse-defdata
parse-if
diff --git a/src/lang/type.clj b/src/lang/type.clj
index 2f708867e..465f6e9fc 100644
--- a/src/lang/type.clj
+++ b/src/lang/type.clj
@@ -79,5 +79,8 @@
=return (clean ?return)]
(return [::function =args =return]))
+ ;; ::any
+ ;; (return [::object "java.lang.Object" []])
+
_
(return type)))
diff --git a/test2.lang b/test2.lang
index e52e667d7..c8f2147ed 100644
--- a/test2.lang
+++ b/test2.lang
@@ -25,9 +25,16 @@
(def sample (#Tag "value"))
(def (constant x y)
- y)
+ x)
(def (main args)
(if true
- (_. (_.. System out) (println ["TRUE" "YOLO"]))
+ (_. (_.. System out) (println ((lambda [x y] x) "TRUE" "YOLO")))
(_. (_.. System out) (println "FALSE"))))
+
+#( (let output ((lambda [x y] x) "TRUE" "YOLO")
+ (_. (_.. System out) (println output))) )#
+#( (let f (lambda [x y] x)
+ (_. (_.. System out) (println (f "TRUE" "YOLO")))) )#
+## ((lambda [x y] (_. (_.. System out) (println x))) "TRUE" "YOLO")
+## (_. (_.. System out) (println ((lambda [x y] x) "TRUE" "YOLO")))
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-05 00:25:57 +0000