diff options
Diffstat (limited to 'src/lisp')
| -rw-r--r-- | src/lisp/clojure.lisp | 251 | ||||
| -rw-r--r-- | src/lisp/test.lisp | 9 |
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 |