From 648110a554a13e1caaf846a60c85cccadcda6e0d Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Sat, 3 Jan 2015 01:48:08 -0400
Subject: The language now supports macros.
---
src/lang.clj | 181 ++++-----------------------------------------
src/lang/analyser.clj | 169 +++++++++++++++++++++++++++++++++++++++---
src/lang/compiler.clj | 199 ++++++++++++++++++++++++++++----------------------
src/lang/lexer.clj | 2 +-
src/lang/parser.clj | 7 ++
src/lang/util.clj | 25 +++++++
6 files changed, 316 insertions(+), 267 deletions(-)
(limited to 'src')
diff --git a/src/lang.clj b/src/lang.clj
index 5e4316db4..0777812b7 100644
--- a/src/lang.clj
+++ b/src/lang.clj
@@ -16,7 +16,6 @@
;; TODO: Adding metadata to global vars.
;; TODO: Add records.
;; TODO: throw, try, catch, finally
- ;; TODO: Finish implementing pattern matching.
;; TODO: Tuple8 and Tuple8X (for arbitrary-size tuples).
;; TODO: Add extra arities (apply2, apply3, ..., apply16)
;; TODO: When doing partial application, skip "apply" and just call constructor appropiatedly.
@@ -32,176 +31,24 @@
;; _ (prn 'tokens tokens)
syntax (&parser/parse tokens)
;; _ (prn 'syntax syntax)
- ann-syntax (&analyser/analyse "test2" syntax)
+ ;; ann-syntax (&analyser/analyse "test2" syntax)
;; _ (prn 'ann-syntax ann-syntax)
- class-data (&compiler/compile "test2" ann-syntax)
+ ;; class-data (&compiler/compile "test2" ann-syntax)
+ class-data (&compiler/compile "test2" syntax)
;; _ (prn 'class-data class-data)
]
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))]
- (.write stream class-data)))
-
- ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
- )
-
-(comment
- ;; (let [branches '([::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~"])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/ident "unquoted"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]]
- ;; [::&parser/case-branch [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "~@"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/variant "Nil" ()])])] [::&parser/variant "Cons" ([::&parser/variant "Symbol" ([::&parser/string "++"])] [::&parser/variant "Cons" ([::&parser/ident "spliced"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])])]]
- ;; [::&parser/case-branch [::&parser/ident "_"] [::&parser/variant "Cons" ([::&parser/ident "head"] [::&parser/fn-call [::&parser/ident "template"] ([::&parser/ident "tail"])])]])
- ;; ;; Step 1: Get all vars
- ;; get-vars (fn get-vars [pattern]
- ;; (clojure.core.match/match pattern
- ;; [::&parser/ident ?name]
- ;; (list ?name)
-
- ;; [::&parser/variant ?tag ?members]
- ;; (mapcat get-vars ?members)
-
- ;; [::&parser/string ?text]
- ;; '()))
- ;; vars+body (for [branch branches]
- ;; (clojure.core.match/match branch
- ;; [::&parser/case-branch ?pattern ?body]
- ;; [(get-vars ?pattern) ?body]))
- ;; ;; _ (prn 'vars+body vars+body)
- ;; max-registers (reduce max 0 (map (comp count first) vars+body))
- ;; ;; _ (prn 'max-registers max-registers)
- ;; ;; Step 2: Analyse bodies
- ;; ;; all-analysis (map (fn [[vars body]]
- ;; ;; (reduce #(with-local %2 [::&type/object "java.lang.Object" []] %1)
- ;; ;; (analyse-form* body)
- ;; ;; (reverse vars)))
- ;; ;; vars+body)
- ;; ;; Step 3: Extract bodies
- ;; [_ branch-mappings branches*] (reduce (fn [[$link links branches*] branch]
- ;; (clojure.core.match/match branch
- ;; [::&parser/case-branch ?pattern ?body]
- ;; [(inc $link) (assoc links $link ?body) (conj branches* [::&parser/case-branch ?pattern $link])]))
- ;; [0 {} []]
- ;; branches)
- ;; ;; Step 4: Pattens -> Instructions
- ;; ;; ->instructions (fn ->instructions [locals pattern]
- ;; ;; (clojure.core.match/match pattern
- ;; ;; [::&parser/variant ?tag ?members]
- ;; ;; [::pm-variant ?tag (map (partial ->instructions locals) ?members)]
-
- ;; ;; [::&parser/ident ?name]
- ;; ;; [::pm-local (get locals ?name)]
-
- ;; ;; [::&parser/string ?text]
- ;; ;; [::pm-text ?text]
- ;; ;; ))
- ;; ;; $scope 0 ;; scope-id
- ;; ;; $local 11 ;; next-local-idx
- ;; ;; branches** (for [[branch branch-vars] (map vector branches* (map first vars+body))
- ;; ;; :let [[_ locals] (reduce (fn [[$local =locals] $var]
- ;; ;; [(inc $local) (assoc =locals $var [::local $scope $local])])
- ;; ;; [$local {}] branch-vars)]]
- ;; ;; (clojure.core.match/match branch
- ;; ;; [::&parser/case-branch ?pattern ?body]
- ;; ;; [(->instructions locals ?pattern) ?body]))
- ;; ;; _ (prn branches**)
- ;; ;; Step 5: Re-structure branching
- ;; ]
- ;; ;; [branch-mappings branches**]
- ;; branches*)
-
-
-
+ ;; (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. "test2.class"))]
+ ;; (.write stream class-data))
+ )
+ (Class/forName "test2.Variant")
- ;; (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0]
- ;; [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1]
- ;; [[:lang/pm-local [:lang/local 0 11]] 2])
- ;; classify-outer (fn [struct [branch $body]]
- ;; (clojure.core.match/match branch
- ;; [::pm-variant ?tag ?members]
- ;; (update-in struct [:cases ?tag] conj {:members ?members
- ;; :body $body})
-
- ;; [::pm-text ?text]
- ;; (update-in struct [:tests] conj {:test [::text ?text]
- ;; :body $body})
-
- ;; [::pm-local ?binding]
- ;; (assoc struct :default {:storage ?binding
- ;; :body $body})))
- ;; outer-classification (reduce classify-outer
- ;; {:cases {}
- ;; :tests '()
- ;; :default nil}
- ;; data)
- ;; full-classifier (fn full-classifier [global]
- ;; (prn 'full-classifier global)
- ;; (let [subcases (:cases global)]
- ;; (if (empty? subcases)
- ;; global
- ;; (let [crossed (sort (fn [x1 x2] (> (-> x1 second :cases count) (-> x2 second :cases count)))
- ;; (for [[tag subs] subcases
- ;; :let [_ (prn 'subcases tag subs)]
- ;; :let [parts (for [cross (apply map list (map :members subs))
- ;; :let [_ (prn 'cross tag cross)]
- ;; ;; :let [_ (prn '(map :body subs) (map :body subs))]
- ;; ;; :let [_ (prn (class cross) (count cross)
- ;; ;; (class (map :body subs)) (count (map :body subs)))]
- ;; :let [cross+ (map vector cross (map :body subs))]
- ;; ;; :let [_ (prn 'cross+ tag (class cross+) (count cross+))]
- ;; ;; :let [_ (prn 'cross+ tag cross+)]
- ;; :let [cross++ (reduce classify-outer
- ;; {:cases {}
- ;; :tests '()
- ;; :default nil}
- ;; cross+)]
- ;; ;; :let [_ (prn 'cross++ tag cross++)]
- ;; ]
- ;; cross++)]
- ;; :let [_ (prn 'parts parts)]]
- ;; [tag parts]))
-
- ;; ]
- ;; (assoc global :cases (reduce (fn [tree [tag subcases]]
- ;; (update-in tree [tag] #(conj (or % []) (full-classifier subcases))))
- ;; {}
- ;; crossed))))))]
- ;; (full-classifier outer-classification))
+ ;; jar cvf test2.jar *.class test2 && java -cp "test2.jar" test2
)
-(comment
- [{2 [:lang.parser/variant "Cons" ([:lang.parser/ident "head"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])],
- 1 [:lang.parser/variant "Cons" ([:lang.parser/variant "Symbol" ([:lang.parser/string "++"])] [:lang.parser/variant "Cons" ([:lang.parser/ident "spliced"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])])],
- 0 [:lang.parser/variant "Cons" ([:lang.parser/ident "unquoted"] [:lang.parser/fn-call [:lang.parser/ident "template"] ([:lang.parser/ident "tail"])])]}
- {:type :lang/adt*,
- :patterns {"Cons" ({:type :lang/adt*,
- :patterns {"Symbol" ({:type :lang/text-tests,
- :patterns {"~@" #{1},
- "~" #{0}},
- :defaults [],
- :branches #{0 1}})},
- :default nil,
- :branches #{0 1}}
- {:type :lang/adt*,
- :patterns {"Cons" ({:type :lang/defaults,
- :stores {[:lang/local 0 11] #{0 1}},
- :branches #{0 1}}
- {:type :lang/adt*,
- :patterns {"Nil" ()},
- :default nil,
- :branches #{0 1}})},
- :default nil,
- :branches #{0 1}})},
- :default [:lang/default [:lang/local 0 11] 2],
- :branches #{0 1 2}}]
-
- (let [data '([[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 0]
- [[:lang/pm-variant "Cons" ([:lang/pm-variant "Symbol" ([:lang/pm-text "~@"])] [:lang/pm-variant "Cons" ([:lang/pm-local [:lang/local 0 11]] [:lang/pm-variant "Nil" ()])])] 1]
- [[:lang/pm-local [:lang/local 0 11]] 2])
- ]
- (generate-branches data))
-
- ;; (def (workday? d)
- ;; (case d
- ;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday]
- ;; true)
- ;; (or [#Saturday #Sunday]
- ;; false)))
-
- )
+;; (def (workday? d)
+;; (case d
+;; (or [#Monday #Tuesday #Wednesday #Thursday #Friday]
+;; true)
+;; (or [#Saturday #Sunday]
+;; false)))
diff --git a/src/lang/analyser.clj b/src/lang/analyser.clj
index 21117a7b7..1e2c684bb 100644
--- a/src/lang/analyser.clj
+++ b/src/lang/analyser.clj
@@ -5,18 +5,22 @@
[clojure.core.match :refer [match]]
(lang [util :as &util :refer [exec return* return fail fail*
repeat-m try-m try-all-m map-m reduce-m
- apply-m within]]
+ apply-m within
+ normalize-ident
+ loader]]
[parser :as &parser]
[type :as &type])))
-(declare analyse-form)
+(declare analyse-form
+ ->tokens
+ tokens->clojure)
;; [Util]
(defn ^:private annotated [form type]
{:form form
:type type})
-(defn ^:private fresh-env [id]
+(defn fresh-env [id]
{:id id
:counter 0
:mappings {}
@@ -33,6 +37,13 @@
(assoc-in [:defs-env name] (annotated [::global (:name state) name] (:type desc))))
nil]]))
+(defn ^:private is-macro? [name]
+ (fn [state]
+ (prn 'is-macro? (nth name 1)
+ (get-in state [:defs (:name state) (nth name 1) :mode])
+ (= (get-in state [:defs (:name state) (nth name 1) :mode]) ::macro))
+ [::&util/ok [state (= (get-in state [:defs (:name state) (nth name 1) :mode]) ::macro)]]))
+
(def ^:private next-local-idx
(fn [state]
[::&util/ok [state (-> state :env first :counter)]]))
@@ -45,7 +56,21 @@
(fn [state]
[::&util/ok [state (-> state :env first)]]))
-(defn ^:private with-scope [scope body]
+(defn ^:private in-scope? [scope]
+ (fn [state]
+ (match scope
+ [::&parser/ident ?macro-name]
+ (do ;; (prn 'in-scope?
+ ;; ?macro-name
+ ;; (get-in state [:lambda-scope 0])
+ ;; (some (partial = ?macro-name) (get-in state [:lambda-scope 0])))
+ [::&util/ok [state (some (partial = ?macro-name) (get-in state [:lambda-scope 0]))]])
+
+ _
+ [::&util/ok [state false]])
+ ))
+
+(defn with-scope [scope body]
(fn [state]
(let [=return (body (-> state
(update-in [:lambda-scope 0] conj scope)
@@ -237,8 +262,9 @@
[::&util/ok [?state ?value]]
[::&util/ok [(assoc ?state :forms old-forms) ?value]]
- _
- =return))))
+ [::&util/failure ?message]
+ (do (prn 'analyse-form* ?message)
+ [::&util/failure ?message])))))
(do-template [<name> <tag> <class>]
(defanalyser <name>
@@ -380,15 +406,118 @@
]
(return (annotated [::dynamic-method =target =owner ?method =method =args] (&type/return-type =method))))]))))
+(defn ->token [x]
+ (prn '->token x)
+ (let [variant (.newInstance (.loadClass loader "test2.Variant"))]
+ (match x
+ [::&parser/string ?text]
+ (doto variant
+ (-> .-tag (set! "Text"))
+ (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1"))
+ (-> .-_0 (set! ?text))))))
+ [::&parser/ident ?ident]
+ (doto variant
+ (-> .-tag (set! "Ident"))
+ (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1"))
+ (-> .-_0 (set! ?ident))))))
+ [::&parser/fn-call ?fn ?args]
+ (doto variant
+ (-> .-tag (set! "Form"))
+ (-> .-value (set! (doto (.newInstance (.loadClass loader "test2.Tuple1"))
+ (-> .-_0 (set! (->tokens (cons ?fn ?args))))))
+ ))
+ )))
+
+(defn ->tokens [xs]
+ (let [variant (.loadClass loader "test2.Variant")
+ tuple2 (.loadClass loader "test2.Tuple2")]
+ (reduce (fn [tail x]
+ ;; (prn 'tail (.-tag tail) 'x x)
+ (doto (.newInstance variant)
+ (-> .-tag (set! "Cons"))
+ (-> .-value (set! (doto (.newInstance tuple2)
+ (-> .-_0 (set! (->token x)))
+ (-> .-_1 (set! tail))
+ ;; (-> prn)
+ )))
+ ;; (-> prn)
+ ))
+ (doto (.newInstance variant)
+ (-> .-tag (set! "Nil"))
+ (-> .-value (set! (.newInstance (.loadClass loader "test2.Tuple0")))))
+ (reverse xs))))
+
+(defn ->clojure-token [x]
+ (prn '->clojure-token x (.-tag x))
+ (case (.-tag x)
+ "Text" [::&parser/string (-> x .-value .-_0 (doto (-> string? assert)))]
+ "Ident" [::&parser/ident (-> x .-value .-_0 (doto (-> string? assert)))]
+ "Form" (let [[?fn & ?args] (-> x .-value .-_0 tokens->clojure)]
+ [::&parser/fn-call ?fn ?args])
+ "Quote" [::&parser/quote (-> x .-value .-_0 ->clojure-token)]))
+
+(defn tokens->clojure [xs]
+ (prn 'tokens->clojure xs (.-tag xs))
+ (case (.-tag xs)
+ "Nil" '()
+ "Cons" (let [tuple2 (.-value xs)]
+ (cons (->clojure-token (.-_0 tuple2))
+ (tokens->clojure (.-_1 tuple2))))
+ ))
+
+;; (defn ->clojure-tokens [xs]
+;; (case (.-tag xs)
+;; "Cons" (let [tuple2 (.-value xs)]
+;; (cons (->clojure-token (.-_0 tuple2)) (->clojure-tokens (.-_1 tuple2))))
+;; "Nil" '()))
+
+(comment
+ (-> (->token [::&parser/string "YOLO"])
+ .-value
+ .-_0)
+
+ (-> (->tokens (list [::&parser/string "YOLO"]))
+ ;; .-tag
+ .-value
+ .-_1
+ .-tag
+ )
+
+ (let [_ (prn 'loader loader)
+ macro (-> loader (.loadClass "test2$_QUOTE_") .newInstance)
+ tokens (->tokens (list [::&parser/string "YOLO"]))]
+ (prn macro)
+ (prn tokens)
+ (prn (.apply macro tokens))
+ (prn (->clojure-token (.apply macro tokens)))
+ )
+
+
+ )
+
(defanalyser analyse-fn-call
[::&parser/fn-call ?fn ?args]
(exec [;; :let [_ (prn 'PRE '?fn ?fn)]
+ macro? (is-macro? ?fn)
+ scoped? (in-scope? ?fn)
+ :let [;; _ (prn 'macro? ?fn macro?)
+ ;; _ (prn 'scoped? scoped?)
+ ]
=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" []]))))
+ (if (and macro? (not scoped?))
+ (do ;; (prn "MACRO CALL!" ?fn ?args =fn)
+ (let [macro (match (:form =fn)
+ [::global ?module ?name]
+ (.newInstance (.loadClass loader (str ?module "$" (normalize-ident ?name)))))
+ output (->clojure-token (.apply macro (->tokens ?args)))]
+ (prn "MACRO CALL!" macro output)
+ (analyse-form* output)))
+ (exec [=args (map-m analyse-form* ?args)]
+ (return (annotated [::call =fn =args] [::&type/object "java.lang.Object" []]))))
+ ))
(defanalyser analyse-if
[::&parser/if ?test ?then ?else]
@@ -630,6 +759,20 @@
(return (annotated [::def [?name args] =value] ::&type/nothing))))
))
+(defanalyser analyse-defmacro
+ [::&parser/defmacro [::&parser/fn-call [::&parser/ident ?name] ([[::&parser/ident ?tokens]] :seq)] ?value]
+ (exec [[=function =tokens =return] (within :types (&type/fresh-function 1))
+ =value (with-scope ?name
+ (with-scoped-name ?name =function
+ (with-local ?tokens =tokens
+ (analyse-form* ?value))))
+ =function (within :types (exec [_ (&type/solve =return (:type =value))]
+ (&type/clean =function)))
+ _ (define ?name {:mode ::macro
+ :access ::public
+ :type =function})]
+ (return (annotated [::def [?name (list ?tokens)] =value] ::&type/nothing))))
+
(defanalyser analyse-lambda
[::&parser/lambda ?args ?body]
(exec [;; :let [_ (prn 'analyse-lambda ?args ?body)]
@@ -661,7 +804,11 @@
(exec [_ (require-module module-name ?alias)]
(return (annotated [::require ?file ?alias] ::&type/nothing)))))
-(def ^:private analyse-form
+(defanalyser analyse-quote
+ [::&parser/quote ?quoted]
+ (return (annotated [::quote ?quoted] ::&type/nothing)))
+
+(def analyse-form
(try-all-m [analyse-boolean
analyse-int
analyse-float
@@ -680,8 +827,10 @@
analyse-defclass
analyse-definterface
analyse-def
+ analyse-defmacro
analyse-import
- analyse-require]))
+ analyse-require
+ analyse-quote]))
;; [Interface]
(defn analyse [module-name tokens]
diff --git a/src/lang/compiler.clj b/src/lang/compiler.clj
index 2ead6daec..113cb2fed 100644
--- a/src/lang/compiler.clj
+++ b/src/lang/compiler.clj
@@ -3,7 +3,12 @@
(:require [clojure.string :as string]
[clojure.set :as set]
[clojure.core.match :refer [match]]
- (lang [type :as &type]
+ (lang [util :as &util :refer [exec return* return fail fail*
+ repeat-m try-m try-all-m map-m reduce-m
+ apply-m within
+ normalize-ident
+ loader]]
+ [type :as &type]
[lexer :as &lexer]
[parser :as &parser]
[analyser :as &analyser])
@@ -18,30 +23,22 @@
;; [Utils/General]
(defn ^:private write-file [file data]
+ (println 'write-file file (alength data))
(with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. file))]
- (.write stream data)))
-
-(defn ^:private normalize-char [char]
- (case char
- \* "_ASTER_"
- \+ "_PLUS_"
- \- "_DASH_"
- \/ "_SLASH_"
- \_ "_UNDERS_"
- \% "_PERCENT_"
- \$ "_DOLLAR_"
- \! "_BANG_"
- \' "_QUOTE_"
- \` "_BQUOTE_"
- \@ "_AT_"
- \^ "_CARET_"
- \& "_AMPERS_"
- \= "_EQ_"
- ;; default
- char))
-
-(defn ^:private normalize-ident [ident]
- (reduce str "" (map normalize-char ident)))
+ (.write stream data))
+ ;; (Thread/sleep 2000)
+ )
+
+(let [;; loader (proxy [ClassLoader] [])
+ ]
+ (defn load-class! [name file-name]
+ (println "Defining..." name "@" file-name ;; (alength bytecode)
+ )
+ ;; (prn 'loader loader)
+ (.loadClass loader name)
+ (println "SUCCESFUL LOAD!")
+ ;; (.defineClass loader name bytecode 0 (alength bytecode))
+ ))
(def ^:private +variant-class+ "test2.Variant")
@@ -290,7 +287,7 @@
+tuple-field-sig+ (->type-signature "java.lang.Object")
equals-sig (str "(" (->type-signature "java.lang.Object") ")Z")]
(defn compile-decision-tree [writer mappings cleanup-level next-label default-label decision-tree]
- (prn 'compile-decision-tree cleanup-level decision-tree)
+ ;; (prn 'compile-decision-tree cleanup-level decision-tree)
(match decision-tree
[::test-text ?text $body]
(let [$else (new Label)]
@@ -326,7 +323,8 @@
(.visitInsn Opcodes/POP) ;; variant
(do (let [arity (-> ?subcases first (nth 2) count)
tuple-class (str "test2/Tuple" arity)
- _ (prn ?tag arity tuple-class)]
+ ;; _ (prn ?tag arity tuple-class)
+ ]
(when (> arity 0)
(doto writer
(.visitInsn Opcodes/DUP) ;; variant, variant
@@ -355,48 +353,15 @@
;; variant, tag ->
(.visitLabel tag-else-label))
(->> (doseq [[?tag ?subcases] ?cases
- :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))]
+ ;; :let [_ (.print System/out (prn-str 'COMPILE-PATTERN ?tag ?subcases))]
:let [tag-else-label (new Label)]])))
(-> (doto (.visitInsn Opcodes/POP))
(->> (dotimes [_ (+ cleanup-level 2)])))
(.visitJumpInsn Opcodes/GOTO default-label)))
))
-;; ([:lang.compiler/subcase 0 ([:lang.compiler/test-adt #{0} {"Symbol" ()}]
-;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])]
-;; [:lang.compiler/subcase 0 ([:lang.compiler/test-adt #{0} {"Symbol" ()}]
-;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])]
-;; [:lang.compiler/subcase 0 ([:lang.compiler/store [:lang.analyser/local 0 1] 0]
-;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])]
-;; [:lang.compiler/subcase 0 ([:lang.compiler/store [:lang.analyser/local 0 1] 0]
-;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])]
-;; [:lang.compiler/subcase 1 ([:lang.compiler/test-adt #{1} {"Symbol" ([:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 1])])}]
-;; [:lang.compiler/test-adt #{1} {"Nil" ()}])]
-;; [:lang.compiler/subcase 1 ([:lang.compiler/test-adt #{1} {"Symbol" ([:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 1])])}]
-;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])]
-;; [:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 0]
-;; [:lang.compiler/test-adt #{0} {"Nil" ([:lang.compiler/subcase 0 ()])}])]
-;; [:lang.compiler/subcase 1 ([:lang.compiler/store [:lang.analyser/local 0 1] 0]
-;; [:lang.compiler/store [:lang.analyser/local 0 2] 1])])
-
-;; ({:type :lang.analyser/adt*,
-;; :patterns {"Cons" {:parts ({:type :lang.analyser/adt*,
-;; :patterns {"Symbol" {:parts ({:type :lang.analyser/defaults,
-;; :stores {[:lang.analyser/local 0 1] #{1}},
-;; :branches #{1}}),
-;; :branches #{1}}},
-;; :default [:lang.analyser/default [:lang.analyser/local 0 1] 0],
-;; :branches #{0 1}}
-;; {:type :lang.analyser/adt*,
-;; :patterns {"Nil" {:parts (), :branches #{0}}},
-;; :default [:lang.analyser/default [:lang.analyser/local 0 2] 1],
-;; :branches #{0 1}}),
-;; :branches #{0 1}}},
-;; :default nil,
-;; :branches #{0 1}})
-
(defn sequence-parts [branches parts]
- (.print System/out (prn-str 'sequence-parts branches parts))
+ ;; (.print System/out (prn-str 'sequence-parts branches parts))
(if (empty? parts)
'(())
(let [[head & tail] parts
@@ -422,14 +387,14 @@
(do ;; (prn '(:default head) (:default head))
;; (assert (nil? (:default head)))
(concat (let [patterns (into {} (for [[?tag ?struct] (:patterns head)
- :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))]
+ ;; :let [_ (.print System/out (prn-str 'PATTERN ?tag ?struct))]
:let [?parts (:parts ?struct)
num-parts (count ?parts)
?supports (:branches ?struct)
subcases (for [?body (set/intersection branches ?supports)
subseq (sequence-parts #{?body} ?parts)
- :let [_ (when (= "Symbol" ?tag)
- (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))]
+ ;; :let [_ (when (= "Symbol" ?tag)
+ ;; (.print System/out (prn-str 'counting ?tag num-parts (count subseq) subseq)))]
:when (= num-parts (count subseq))]
[::subcase ?body subseq])]
:when (not (empty? subcases))]
@@ -593,8 +558,10 @@
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd)))
- _ (.visitEnd =class)]
- (write-file (str current-class ".class") (.toByteArray =class)))
+ _ (.visitEnd =class)
+ bytecode (.toByteArray =class)]
+ (write-file (str current-class ".class") bytecode)
+ (load-class! (string/replace current-class #"/" ".") (str current-class ".class")))
))
(defn compile-field [writer class-name ?name body state]
@@ -614,8 +581,10 @@
(.visitInsn Opcodes/RETURN)
(.visitMaxs 0 0)
(.visitEnd)))
- (.visitEnd))]
- (write-file (str current-class ".class") (.toByteArray =class)))
+ (.visitEnd))
+ bytecode (.toByteArray =class)]
+ (write-file (str current-class ".class") bytecode)
+ (load-class! (string/replace current-class #"/" ".") (str current-class ".class")))
))
(defcompiler ^:private compile-def
@@ -757,8 +726,10 @@
(.visitInsn Opcodes/ARETURN)
(.visitMaxs 0 0)
(.visitEnd))
- _ (.visitEnd =class)]
- (write-file (str current-class ".class") (.toByteArray =class))
+ _ (.visitEnd =class)
+ bytecode (.toByteArray =class)]
+ (write-file (str current-class ".class") bytecode)
+ (load-class! (string/replace current-class #"/" ".") (str current-class ".class"))
;; (apply prn 'LAMBDA ?scope ?args (->> (:mappings ?frame)
;; (map second)
;; (map :form)
@@ -797,8 +768,8 @@
(.visitEnd))
(.visitEnd =class)
(.mkdirs (java.io.File. parent-dir))
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))]
- (.write stream (.toByteArray =class)))))
+ (write-file (str parent-dir "/" ?name ".class") (.toByteArray =class))
+ (load-class! (string/replace (str parent-dir "/" ?name) #"/" ".") (str parent-dir "/" ?name ".class"))))
(defcompiler ^:private compile-definterface
[::&analyser/definterface [?package ?name] ?members]
@@ -813,8 +784,8 @@
(.visitMethod =interface (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) ?method signature nil nil))
(.visitEnd =interface)
(.mkdirs (java.io.File. parent-dir))
- (with-open [stream (java.io.BufferedOutputStream. (java.io.FileOutputStream. (str parent-dir "/" ?name ".class")))]
- (.write stream (.toByteArray =interface)))))
+ (write-file (str parent-dir "/" ?name ".class") (.toByteArray =interface))
+ (load-class! (string/replace (str parent-dir "/" ?name) #"/" ".") (str parent-dir "/" ?name ".class"))))
(defcompiler ^:private compile-variant
[::&analyser/variant ?tag ?members]
@@ -856,12 +827,40 @@
;; _ (prn 'tokens tokens)
syntax (&parser/parse tokens)
;; _ (prn 'syntax syntax)
- ann-syntax (&analyser/analyse module-name syntax)
+ ;; ann-syntax (&analyser/analyse module-name syntax)
;; _ (prn 'ann-syntax ann-syntax)
- class-data (compile module-name ann-syntax)]
- (write-file (str module-name ".class") class-data)
+ bytecode (compile module-name syntax)]
+ ;; (write-file (str module-name ".class") bytecode)
+ ;; (load-class! (string/replace module-name #"/" ".") (str module-name ".class"))
nil))
+(defn quoted->token [quoted]
+ (prn 'quoted->token quoted)
+ (match quoted
+ [::&parser/string ?text]
+ {:form [::&analyser/variant "Text" (list {:form [::&analyser/literal ?text]
+ :type [::&type/object "java.lang.String" []]})]
+ :type [::&type/variant "Text" (list [::&type/object "java.lang.String" []])]}
+
+ [::&parser/fn-call ?fn ?args]
+ (let [members* (quoted->token (cons ?fn ?args))]
+ {:form [::&analyser/variant "Form" (list members*)]
+ :type [::&type/variant "Form" (list (:type members*))]})
+
+ ([] :seq)
+ {:form [::&analyser/variant "Nil" '()]
+ :type [::&type/variant "Nil" '()]}
+
+ ([head & tail] :seq)
+ (let [head* (quoted->token head)
+ tail* (quoted->token tail)]
+ {:form [::&analyser/variant "Cons" (list head* tail*)]
+ :type [::&type/variant "Nil" (list (:type head*) (:type tail*))]})))
+
+(defcompiler compile-quote
+ [::&analyser/quote ?quoted]
+ (compile-form (assoc *state* :form (quoted->token ?quoted))))
+
(let [+compilers+ [compile-literal
compile-variant
compile-tuple
@@ -882,7 +881,8 @@
compile-defclass
compile-definterface
compile-import
- compile-require]]
+ compile-require
+ compile-quote]]
(defn ^:private compile-form [state]
;; (prn 'compile-form/state state)
(or (some #(% state) +compilers+)
@@ -894,18 +894,39 @@
(let [=class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS)
(.visit Opcodes/V1_5 (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER)
(->class class-name) nil "java/lang/Object" nil))
- state {:class-name class-name
- :writer =class
- :form nil
- :parent nil}]
- (doseq [input inputs]
- (when (not (compile-form (assoc state :form input)))
- (assert false input)))
+ compiler-state {:class-name class-name
+ :writer =class
+ :form nil
+ :parent nil}]
+ (match ((repeat-m
+ (&analyser/with-scope class-name
+ (exec [ann-input &analyser/analyse-form
+ :let [_ (when (not (compile-form (assoc compiler-state :form ann-input)))
+ (assert false ann-input))]]
+ (return ann-input))))
+ {:name class-name
+ :forms inputs
+ :deps {}
+ :imports {}
+ :defs {}
+ :defs-env {}
+ :lambda-scope [[] 0]
+ :env (list (&analyser/fresh-env 0))
+ :types &type/+init+})
+ [::&util/ok [?state ?forms]]
+ (if (empty? (:forms ?state))
+ ?forms
+ (assert false (str "Unconsumed input: " (pr-str (:forms ?state)))))
+
+ [::&util/failure ?message]
+ (assert false ?message))
+ ;;;
(.visitEnd =class)
- (let [=array (.toByteArray =class)]
- ;; (prn 'compile class-name =array)
- =array))
-
+ (let [bytecode (.toByteArray =class)]
+ (write-file (str class-name ".class") bytecode)
+ (load-class! (string/replace class-name #"/" ".") (str class-name ".class"))
+ bytecode)
+ )
;; (comment
;; (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2"))
;; (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader. (.loadClass "test2.Function"))
diff --git a/src/lang/lexer.clj b/src/lang/lexer.clj
index 870209503..9fa533dc5 100644
--- a/src/lang/lexer.clj
+++ b/src/lang/lexer.clj
@@ -52,7 +52,7 @@
;; [Lexers]
(def ^:private lex-white-space (lex-regex #"^(\s+)"))
-(def +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':]*)")
+(def +ident-re+ #"^([a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~][0-9a-zA-Z\-\+\_\=!@$%^&*<>\.,/\\\|':\~]*)")
(do-template [<name> <tag> <regex>]
(def <name>
diff --git a/src/lang/parser.clj b/src/lang/parser.clj
index 48f624ba4..34f3e70b4 100644
--- a/src/lang/parser.clj
+++ b/src/lang/parser.clj
@@ -71,6 +71,12 @@
=body (apply-m parse-form (list ?body))]
(return [::def =name =body])))
+(defparser ^:private parse-defmacro
+ [::&lexer/list ([[::&lexer/ident "defmacro"] ?name ?body] :seq)]
+ (exec [=name (apply-m parse-form (list ?name))
+ =body (apply-m parse-form (list ?body))]
+ (return [::defmacro =name =body])))
+
(defparser ^:private parse-defdata
[::&lexer/list ([[::&lexer/ident "defdata"] ?type & ?cases] :seq)]
(exec [=type (apply-m parse-form (list ?type))
@@ -195,6 +201,7 @@
parse-record
parse-lambda
parse-def
+ parse-defmacro
parse-defdata
parse-if
parse-do
diff --git a/src/lang/util.clj b/src/lang/util.clj
index e2edfb550..7eb431033 100644
--- a/src/lang/util.clj
+++ b/src/lang/util.clj
@@ -132,3 +132,28 @@
[::ok [(assoc state slot ?state) ?value]]
_
=return))))
+
+(defn ^:private normalize-char [char]
+ (case char
+ \* "_ASTER_"
+ \+ "_PLUS_"
+ \- "_DASH_"
+ \/ "_SLASH_"
+ \_ "_UNDERS_"
+ \% "_PERCENT_"
+ \$ "_DOLLAR_"
+ \! "_BANG_"
+ \' "_QUOTE_"
+ \` "_BQUOTE_"
+ \@ "_AT_"
+ \^ "_CARET_"
+ \& "_AMPERS_"
+ \= "_EQ_"
+ ;; default
+ char))
+
+(defn normalize-ident [ident]
+ (reduce str "" (map normalize-char ident)))
+
+(defonce loader (doto (-> (java.io.File. "./") .toURL vector into-array java.net.URLClassLoader.)
+ (->> (prn 'loader))))
--
cgit v1.2.3