interim checkin

1 files changed, 189 insertions, 21 deletions

diff --git a/src/lisp/clojure.lisp b/src/lisp/clojure.lisp
index 3cf041ad..7ec3250c 100644
--- a/src/lisp/clojure.lisp
+++ b/src/lisp/clojure.lisp
@@ -27,11 +27,11 @@
 (defvar *accessors*)
 (defvar *defvars*)
 (defvar *defns*)
-(defvar *needs-tls*)
-(defvar *local-bindings*)
 (defvar *quoted-aggregates*)
 (defvar *nested-fns*)
 (defvar *var-env*)
+(defvar *frame* nil)
+(defvar *next-id*)
 
 ;dynamic functions
 (defvar *reference-var*)
@@ -268,7 +268,8 @@
       (format target "~A~%" (package-close-string)))))
 
 (defun convert (form)
-  (let ((tree (analyze :top (macroexpand form))))
+  (let ((tree (analyze :top (macroexpand form)))
+        (*next-id* 0))
     ;(print tree)
     (format t "/* Generated by Clojure from the following Lisp:~%") 
     (pprint form)
@@ -277,6 +278,9 @@
     ;tree
     ))
 
+(defun get-next-id ()
+  (incf *next-id*))
+
 (defvar *texpr* (newobj :type :t))
 
 (defun analyze (context form)
@@ -321,21 +325,44 @@
     (setf (@ :nested-fns ret) *nested-fns*)
     ret))
 
-(defun analyze-function (context args body)
-  (let* ((*needs-tls* nil)
-         (closes nil)
-         (*local-bindings* nil)
-         (var-env (funcall *get-var-env*))
-         (enclosing-reference-var *reference-var*)
-         (*reference-var*
-          (lambda (sym env)
-            (let ((b (first (member sym env :key #'binding-symbol))))
-              (when (and b (not (member b local-bindings))) ;closed over
-                (setf (@ :closed? b) t)
-                (pushnew b closes)
-                (when enclosing-reference-var
-                  (funcall enclosing-reference-var sym env)))
-              b))))))
+(defun reference-var (sym)
+  (let ((b (first (member sym *var-env* :key (lambda (b)
+                                               (@ :symbol b))))))
+    (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-function (context 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)))
+               (add-to-var-env b)
+               (register-local-binding b)
+               b)))
+      (dolist (p params)
+        (case p
+          (& (setf state :rest))
+          (t (case state
+               (:reqs
+                (push (create-param-binding p) (@ :reqs *frame*)))
+               (:rest
+                (setf (@ :rest *frame*) (create-param-binding p)))))))
+
+      (setf (@ :reqs *frame*) (nreverse (@ :reqs *frame*)))
+      (setf (@ :body *frame*) (analyze :return `(|block| nil ,@body)))
+
+      *frame*)))
 
 (defun analyze-defvar (context form)
   (assert (eql context :top))
@@ -345,14 +372,154 @@
      :init-fn (when init-provided
                 (analyze :top `(|fn| () ,init))))))
 
+(defun needs-box (binding)
+  (and binding (@ :closed? binding) (@ :assigned? binding)))
+
+(defun binding-type-decl (binding)
+  (cond
+   ((needs-box binding) "Box")
+   (t "Object")))
+
+(defun fn-decl-string ()
+  (case *host*
+    (:jvm "static")
+    (:cli "")))
+
+(defun extends-string ()
+  (case *host*
+    (:jvm "extends")
+    (:cli ":")))
+
+(defun fn-name (fn)
+  (if (@ :rest fn)
+      "doInvoke"
+    "invoke"))
+
+(defun exception-declaration-string ()
+  (case *host*
+    (:jvm "throws Exception")
+    (:cli "")))
+
+(defun binding-name (b)
+  (format nil "~A~@[__~A~]"
+            (munge-name (@ :symbol b))
+            (@ :id b)))
+
+(defun can-be-static-method (fn)
+  (not (@ :rest fn)))
+
+(defun will-be-static-method (b)
+  (and (eql (@ :type b) :binding)
+       (@ :fn b)
+       (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))
+         (closes-decls (mapcan (lambda (b)
+                                 (list (binding-type-decl b) (@ :name b)))
+                               (@ :closes (first fns)))))
+    (unless as-static-method?
+          ;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
+      (when closes-decls
+        (format t "~{~A ~A;~%~}" closes-decls)
+        (format t "public ~A (~{~A ~A~^, ~}){~%" name closes-decls)
+        (format t "~{this.~A = ~A;~%~}"
+                (mapcan
+                 (lambda (b)
+                   (let ((s (binding-name b)))
+                     (list s s)))
+                 (@ :closes (first fns))))
+        (format t "}~%")))
+
+    (when as-static-method?
+            ;function gets the supplied name, prefix params with closed vars
+      (format t "static public Object ~A(~{~A ~A~^, ~}"
+              name
+              closes-decls))
+
+    (dolist (fn fns)
+      (unless as-static-method?
+        (format t "public Object ~A(" (fn-name fn)))
+
+        ;params
+      (let ((rest (@ :rest fn)))
+        (format t "ThreadLocalData __tld~{, ~A ~A~@[~A~]~}"
+                (mapcan (lambda (b)
+                          (list 
+                           (binding-type-decl b)
+                           (binding-name b)
+                           (when (needs-box b)
+                             "__arg")))
+                        (@ :reqs fn)))
+        (when rest
+          (format t ", Cons ~A~@[~A~]"
+                  (binding-name rest)
+                  (when (needs-box rest) "__arg"))))
+
+      (format t ") ~A ~%{~%" (exception-declaration-string))
+
+        ;tls
+      (when (@ :needs-tls fn)
+        (format t "if(__tld == null) __tld = ThreadLocalData.get();~%"))
+
+        ;parameter binding declarations,if needed
+          ;reqs
+      (dolist (b (@ :reqs fn))
+        (when (needs-box b)
+          (emit-binding-declaration b (munge-closed-over-assigned-arg b))))
+        
+      ;rest
+      (let ((rest (@ :rest fn)))
+        (when (needs-box rest)
+          (emit-binding-declaration rest (munge-closed-over-assigned-arg rest))))
+
+          ;non-param local bindings
+      (dolist (b (@ :local-bindings fn))
+            ; fixup the names, numbering all locals
+        (unless (@ :param? b)
+          (setf (@ :id b) (get-next-id))
+          (unless (or (@ :anonymous-lambda? b)
+                      (will-be-static-method b))
+            (emit-binding-declaration b))))
+
+          ;body
+      (emit :return (@ :body fn))
+          
+          ;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
+        ;todo - change, this is fragile
+        (when (and (symbolp name) (not (symbol-package name)))
+          (format t "static public IFn fn = new ~A();~%" name)))
+       ;end of class
+      (format t "}~%"))))
+
 (defun register-var-reference (sym)
   (pushnew sym *vars*))
 
 (defun register-needs-tls ()
-  (setf *needs-tls* t))
+  (setf (@ :needs-tls *frame*) t))
 
 (defun register-local-binding (b)
-  (push b *local-bindings*))
+  (push b (@ :local-bindings *frame*)))
 
 (defun host-symbol? (sym)
   (find #\. (string sym) :start 1))
@@ -378,6 +545,8 @@
 ;current thinking is that bootstrap compiler will only generate
 ;reflective host calls, so this will not be needed
 
+#|
+
 (defun ensure-package (name)
     "find the package or create it if it doesn't exist"
     (or (find-package name)
@@ -400,7 +569,6 @@
 
 (defun java-array-name? (tn)
   (eql (schar tn 0) #\[))
-#|
 (defun load-types (type-file)
 "generates symbols for types/classes and members in supplied typedump file
  see typedump in the Java/C# side