can generate empty fns, added test.lisp

2 files changed, 196 insertions, 64 deletions

diff --git a/src/lisp/clojure.lisp b/src/lisp/clojure.lisp
index 7ec3250c..7d48f1f6 100644
--- a/src/lisp/clojure.lisp
+++ b/src/lisp/clojure.lisp
@@ -10,7 +10,11 @@
 
 (defpackage "clojure"
   (:export :load-types :*namespace-separator*
-   :newobj :@ :compile-to :*clojure-source-path* :*clojure-target-path*))
+   :newobj :@ :compile-to :*clojure-source-path* :*clojure-target-path*
+   "in-module"
+   "defn*" "def"
+   "if" "and" "or" "not"
+   "block" "let" "let*"))
 
 (in-package "clojure")
 
@@ -28,8 +32,8 @@
 (defvar *defvars*)
 (defvar *defns*)
 (defvar *quoted-aggregates*)
-(defvar *nested-fns*)
-(defvar *var-env*)
+(defvar *nested-fn-bindings*)
+(defvar *var-env* nil)
 (defvar *frame* nil)
 (defvar *next-id*)
 
@@ -37,6 +41,14 @@
 (defvar *reference-var*)
 
 #|
+(let ((*clojure-source-path* #p"/dev/clojure/src/lisp/")
+      (*clojure-target-path* #p"/dev/clojure/classes/"))
+  (compile-to :jvm "org.clojure" "Clojure"
+              "test.lisp"))
+(let ((*clojure-source-path* #p"/dev/clojure/src/lisp/")
+      (*clojure-target-path* #p"/dev/clojure/classes/test/"))
+  (compile-to :cli "org.clojure" "Clojure"
+              "test.lisp"))
 ;build the library
 (let ((*clojure-source-path* #p"/dev/clojure/")
       (*clojure-target-path* #p"/dev/gen/clojure/"))
@@ -124,6 +136,11 @@
     (:jvm "import ~A.*;~2%")
     (:cli "using ~A;~2%")))
 
+(defun system-import-string ()
+  (ecase *host*
+    (:jvm "")
+    (:cli "using System;~2%")))
+
 (defun var-member-name (symbol)
   (format nil "~A__~A"
           (munge-name (symbol-package symbol))
@@ -203,6 +220,7 @@
     (with-open-file (target outpath :direction :output :if-exists :supersede)
       (format target "/* Generated by Clojure */~2%")
       (format target (package-open-format-string) package-name)
+      (format target (system-import-string))
       (format target (package-import-format-string) "org.clojure.runtime")
       (format target "public class ~A{~%" class-name)
       (unwind-protect
@@ -213,7 +231,7 @@
                      (case (first form)
                        (|in-module| (setf *package* (find-package (second form))))
                        ((|block|) (mapc #'process-form (rest form)))
-                       ((|def| |defvar| |defparameter| |defmain|)
+                       ((|defn*| |def| |defparameter| |defmain|)
                         (let* ((target-sym (second form)))
                           (princ target-sym)
                           (terpri)
@@ -245,20 +263,20 @@
       (dolist (accessor *accessors*)
         (format target "static Accessor ~A = Namespace.internAccessor(~S,~S);~%"
                 (accessor-member-name accessor)
-                (munge-name (symbol-package accessor))
+                (munge-name (package-name (symbol-package accessor)))
                 (munge-name (symbol-name accessor))))
       (format target "~Atry{~%" (begin-static-block class-name))
         ;(format target "~%static public void __load() ~A{~%" (exception-declaration-string lang))
       (dolist (var *defns*)
         (format target "Namespace.internVar(~S,~S).bind(new ~A());~%"
-                (munge-name (symbol-package var))
+                (munge-name (package-name (symbol-package var)))
                 (munge-name (symbol-name var))
                 (munge-name var)))
       (dolist (var-and-init *defvars*)
         (let ((var (@ :var var-and-init))
               (init (@ :init var-and-init)))
           (format target "Namespace.internVar(~S,~S).bind((new ~A()).invoke());~%"
-                (munge-name (symbol-package var))
+                (munge-name (package-name (symbol-package var)))
                 (munge-name (symbol-name var))
                 (munge-name init))))
       (format target "}catch(Exception e){}~%}~%")
@@ -287,17 +305,24 @@
   "context - one of :top :return :statement :expression :fn"
   (cond
    ((consp form) (analyze-op context (first form) form))
-   ((null form) nil)
+   ((or (null form)(eql '|nil| form)) nil)
    ((eql '|t| form) *texpr*)
    ((symbolp form) (analyze-symbol context form))
    (t (newobj :type :literal :val form))))
 
+(defmacro |defn| (name params &body body)
+  `(|defn*| , name (,params ,@body)))
+
+;(defmacro |block| (&body body)
+;  `(|let| nil ,@body))
+
 (defun analyze-op (context op form)
   (case op
     (|quote| (analyze-quote context form))
-    (|defn| (analyze-defn context form))
-    (|defvar| (analyze-defvar context form))
-    (|fn| (analyze-fn context form))
+    (|defn*| (analyze-defn* context form))
+    (|def| (analyze-def context form))
+    (|block| (analyze-block context form))
+    (|fn*| (analyze-fn* context form))
     (|if| (analyze-if context form))
     (|not| (analyze-not context form))
     (|and| (analyze-and context form))
@@ -305,48 +330,119 @@
     (|set| (analyze-set context form))
     (|let| (analyze-let context form))
     (|let*| (analyze-let* context form))
-    (|block| (analyze-block context form))
     (|loop| (analyze-loop context form))
     (|try| (analyze-try context form))
     (t (analyze-invoke context form))))
 
 (defun emit (context expr)
+  (cond
+   ((null expr) (emit-nil context))
+   (t (ecase (@ :type expr)
+        (:defn* (emit-defn* context expr))
+        (:binding (emit-binding context expr))))))
+
+(defun emit-return (expr)
+  (format t "return ")
+  (emit :expression expr)
+  (format t ";~%"))
+
+(defun emit-new-closure-instance (name-binding-fn)
+  (format t "(new ~A(~{~A~^, ~}))"
+          (binding-name name-binding-fn)
+          (mapcar (lambda (b)
+                    (binding-name b))
+                  (@ :closes (first (@ :methods (@ :fn name-binding-fn)))))))
+
+(defun emit-binding (context expr)
+  (ecase context
+    (:expression
+     (if (and (@ :anonymous-fn? expr) (not (will-be-static-method expr)))
+         (emit-new-closure-instance expr)
+       (format t "~A~:[~;.val~]" (binding-name expr) (needs-box expr))))
+    (:return (emit-return expr))))
+
+(defun analyze-let (context form)
   )
 
-(defun analyze-defn (context form)
+(defun analyze-body (context exprs)
+  (when exprs
+    (case context
+      (:statement
+       (mapcar (lambda (expr)
+                 (analyze :statement expr))
+               exprs))
+      (:return
+       (append (mapcar (lambda (expr)
+                         (analyze :statement expr))
+                       (butlast exprs))
+               (list (analyze :return (first (last exprs)))))))))
+
+(defun analyze-block (context form)
+  (cond 
+   ((null (rest form))
+      (analyze context '|nil|))
+   ((null (rest (rest form)))
+      (analyze context (second form)))
+   (t (ecase context
+        (:expression (analyze context `(|fn*| (() ,@(rest form)))))
+        ((:statement :return) (newobj :type :block
+                                      :body (analyze-body context (rest form))))))))
+
+(defun analyze-defn* (context form)
   (assert (eql context :top))
   (let* ((*quoted-aggregates* nil)
-         (*nested-fns* nil)
-         (ret (newobj :type :defn :name (second form) 
-                      :fns (mapcar (lambda (fn)
-                                     (analyze-function :top (first fn) (rest fn)))
-                                   (rest (rest form))))))
-    (setf (@ :quoted-aggregates ret) *quoted-aggregates*)
-    (setf (@ :nested-fns ret) *nested-fns*)
-    ret))
+         (*nested-fn-bindings* nil)
+         (fn (analyze :top `(|fn*| ,@(rest (rest form))))))
+    (setf (@ :quoted-aggregates fn) *quoted-aggregates*)
+    (setf (@ :nested-fn-bindings fn) *nested-fn-bindings*)
+    (newobj :type :defn*
+            :name (second form) 
+            :fn fn)))
+
+(defun register-defn (name)
+  (push name *defns*))
+
+(defun emit-defn* (context expr)
+  (declare (ignore context))
+  (let ((name (@ :name expr)))
+    (register-defn name)
+    (emit-fn-declaration :top (munge-name name) (@ :fn expr) nil)))
+
+(defun emit-nil (context)
+  (ecase context
+    (:expression (format t "null"))
+    (:statement)
+    (:return (emit-return nil))))
 
 (defun reference-var (sym)
   (let ((b (first (member sym *var-env* :key (lambda (b)
                                                (@ :symbol b))))))
-    (check-closed b *frame*)
+    (labels
+        ((check-closed (b frame)
+           (when (and b frame
+                      (not (member b (@ :local-bindings frame)))) ;closed over
+             (setf (@ :closed? b) t)
+             (pushnew b (@ :closes frame))
+             (check-closed b (@ :parent frame)))))
+      (check-closed b *frame*))
     b))
 
 (defun add-to-var-env (b)
   (push b *var-env*))
 
-(defun check-closed (b frame)
-  (when (and b frame
-             (not (member b (@ :local-bindings frame)))) ;closed over
-    (setf (@ :closed? b) t)
-    (pushnew b (@ :closes frame))
-    (check-closed b (@ :parent frame))))
+(defun analyze-fn* (context form)
+  (declare (ignore context))
+  (newobj :type :fn*
+          :methods (mapcar (lambda (m)
+                             (analyze-method (first m) (rest m)))
+                           (rest form))))
 
-(defun analyze-function (context params body)
+(defun analyze-method (params body)
   (let* ((*frame* (newobj :parent *frame*))
          (*var-env* *var-env*)
          (state :reqs))
     (flet ((create-param-binding (p)
-             (let ((b (make-binding :symbol p :param? t)))
+             (let ((b (newobj :type :binding :symbol p :param? t)))
                (add-to-var-env b)
                (register-local-binding b)
                b)))
@@ -360,17 +456,17 @@
                 (setf (@ :rest *frame*) (create-param-binding p)))))))
 
       (setf (@ :reqs *frame*) (nreverse (@ :reqs *frame*)))
-      (setf (@ :body *frame*) (analyze :return `(|block| nil ,@body)))
+      (setf (@ :body *frame*) (analyze :return `(|block| ,@body)))
 
       *frame*)))
 
-(defun analyze-defvar (context form)
+(defun analyze-def (context form)
   (assert (eql context :top))
   (destructuring-bind (name init init-provided) (rest form)
-    (newobj :type :defvar
+    (newobj :type :def
      :name name
      :init-fn (when init-provided
-                (analyze :top `(|fn| () ,init))))))
+                (analyze :top `(|fn*| (() ,init)))))))
 
 (defun needs-box (binding)
   (and binding (@ :closed? binding) (@ :assigned? binding)))
@@ -406,7 +502,8 @@
             (@ :id b)))
 
 (defun can-be-static-method (fn)
-  (not (@ :rest fn)))
+  (and (= (length (@ :methods fn)) 1)
+       (not (@ :rest (first (@ :methods fn))))))
 
 (defun will-be-static-method (b)
   (and (eql (@ :type b) :binding)
@@ -414,18 +511,40 @@
        (not (or (@ :value-taken? b) (@ :closed? b)))
        (can-be-static-method (@ :fn b))))
 
-(defun emit-fn-declaration (context name fobj as-static-method?)
-  (let* ((fns (@ :fns fobj))
-         (base (fn-base-class fns))
+(defun emit-binding-declaration (b &optional (init nil init-supplied))
+  (format t "~A " (binding-type-decl b))
+  (format t "~A"
+            (binding-name b))
+  (cond
+   ((needs-box b)
+    (format t " = new Box(~A)" (or init "null")))
+   (init-supplied (format t " = ~A" (or init "null"))))
+  (format t ";~%"))
+
+(defun munge-closed-over-assigned-arg (b)
+  (concatenate 'string (munge-name (@ :symbol b)) "__arg"))
+
+(defun fn-base-class (fn)
+  (let ((rest-method (find-if (lambda (m)
+                                (@ :rest m))
+                              (@ :methods fn))))
+    (if rest-method
+        (format nil "RestFn~A" (length (@ :reqs rest-method)))
+      "AFn")))
+
+(defun emit-fn-declaration (context name fn as-static-method?)
+  (let* ((methods (@ :methods fn))
+         (base (fn-base-class fn))
          (closes-decls (mapcan (lambda (b)
                                  (list (binding-type-decl b) (@ :name b)))
-                               (@ :closes (first fns)))))
+                               ;expecting only one method if closjure
+                               (@ :closes (first methods)))))
     (unless as-static-method?
-          ;emit a class declaration
+      ;emit a class declaration
       (format t "~@[~A ~]public class ~A ~A ~A{~%"
               (fn-decl-string)
               name (extends-string) base)
-          ;and members and a ctor if closure
+      ;and members and a ctor if closure
       (when closes-decls
         (format t "~{~A ~A;~%~}" closes-decls)
         (format t "public ~A (~{~A ~A~^, ~}){~%" name closes-decls)
@@ -434,7 +553,7 @@
                  (lambda (b)
                    (let ((s (binding-name b)))
                      (list s s)))
-                 (@ :closes (first fns))))
+                 (@ :closes (first methods))))
         (format t "}~%")))
 
     (when as-static-method?
@@ -443,12 +562,13 @@
               name
               closes-decls))
 
-    (dolist (fn fns)
+    (dolist (m methods)
+      ;if static, we are expecting this to run once
       (unless as-static-method?
-        (format t "public Object ~A(" (fn-name fn)))
+        (format t "public Object ~A(" (fn-name m)))
 
         ;params
-      (let ((rest (@ :rest fn)))
+      (let ((rest (@ :rest m)))
         (format t "ThreadLocalData __tld~{, ~A ~A~@[~A~]~}"
                 (mapcan (lambda (b)
                           (list 
@@ -456,7 +576,7 @@
                            (binding-name b)
                            (when (needs-box b)
                              "__arg")))
-                        (@ :reqs fn)))
+                        (@ :reqs m)))
         (when rest
           (format t ", Cons ~A~@[~A~]"
                   (binding-name rest)
@@ -465,22 +585,22 @@
       (format t ") ~A ~%{~%" (exception-declaration-string))
 
         ;tls
-      (when (@ :needs-tls fn)
+      (when (@ :needs-tls m)
         (format t "if(__tld == null) __tld = ThreadLocalData.get();~%"))
 
         ;parameter binding declarations,if needed
           ;reqs
-      (dolist (b (@ :reqs fn))
+      (dolist (b (@ :reqs m))
         (when (needs-box b)
           (emit-binding-declaration b (munge-closed-over-assigned-arg b))))
         
       ;rest
-      (let ((rest (@ :rest fn)))
+      (let ((rest (@ :rest m)))
         (when (needs-box rest)
           (emit-binding-declaration rest (munge-closed-over-assigned-arg rest))))
 
           ;non-param local bindings
-      (dolist (b (@ :local-bindings fn))
+      (dolist (b (@ :local-bindings m))
             ; fixup the names, numbering all locals
         (unless (@ :param? b)
           (setf (@ :id b) (get-next-id))
@@ -489,23 +609,26 @@
             (emit-binding-declaration b))))
 
           ;body
-      (emit :return (@ :body fn))
+      (emit :return (@ :body m))
           
           ;end of invoke function
       (format t "}~%"))
         
+
     (unless as-static-method?
-      (when (eql context :top)
-        (dolist (lb (@ :lambda-bindings fobj))
-          (emit-lambda-declaration :statement
-                                   (@ :name lb)
-                                   (@ :fn lb) :as-static-method (will-be-static-method lb)))
-        (dolist (qa (@ :quoted-aggregates fobj))
-          (with-slots (symbol form) qa
-            (format t "static public Object ~A = " (munge-name (@ :symbol qa)))
-            (emit :expression (@ :form qa))
-            (format t ";~%")))
-              ;anonymous lambdas are named w/gensyms
+      ;these will only be set on toplevel defn
+      (dolist (fb (@ :nested-fn-bindings fn))
+        (emit-fn-declaration :statement
+                             (binding-name fb)
+                             (@ :fn fb)
+                             (will-be-static-method fb)))
+      (dolist (qa (@ :quoted-aggregates fn))
+        (with-slots (symbol form) qa
+          (format t "static public Object ~A = " (munge-name (@ :symbol qa)))
+          (emit :expression (@ :form qa))
+          (format t ";~%")))
+      (when (eql context :top)       
+        ;anonymous lambdas are named w/gensyms
         ;todo - change, this is fragile
         (when (and (symbolp name) (not (symbol-package name)))
           (format t "static public IFn fn = new ~A();~%" name)))
@@ -525,14 +648,14 @@
   (find #\. (string sym) :start 1))
 
 (defun accessor? (sym)
-  (eql (char sym 0) #\.))
+  (eql (char (string sym) 0) #\.))
 
 (defun analyze-symbol (context sym)
   (cond
    ((keywordp sym) (newobj :type :keyword :symbol sym))
    ((host-symbol? sym) (newobj :type :host-symbol :symbol sym))
    ((accessor? sym) (newobj :type :accessor :symbol sym))
-   (t (or (funcall *reference-var* sym *var-env*)
+   (t (or (reference-var sym)
           ;not a local var
           (progn
             (register-var-reference sym)
diff --git a/src/lisp/test.lisp b/src/lisp/test.lisp
new file mode 100644
index 00000000..35d98a49
--- /dev/null
+++ b/src/lisp/test.lisp
@@ -0,0 +1,9 @@
+(in-module "clojure")
+
+(defn f0 ())
+
+(defn f1 (x) x)
+
+(defn* f01
+       (())
+       ((x) x))
\ No newline at end of file