summaryrefslogtreecommitdiff
path: root/src/lisp/clojure.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'src/lisp/clojure.lisp')
-rw-r--r--src/lisp/clojure.lisp1597
1 files changed, 0 insertions, 1597 deletions
diff --git a/src/lisp/clojure.lisp b/src/lisp/clojure.lisp
deleted file mode 100644
index 1d9952de..00000000
--- a/src/lisp/clojure.lisp
+++ /dev/null
@@ -1,1597 +0,0 @@
-;/**
-; * Copyright (c) Rich Hickey. All rights reserved.
-; * The use and distribution terms for this software are covered by the
-; * Common Public License 1.0 (http://opensource.org/licenses/cpl.php)
-; * which can be found in the file CPL.TXT at the root of this distribution.
-; * By using this software in any fashion, you are agreeing to be bound by
-; * the terms of this license.
-; * You must not remove this notice, or any other, from this software.
-; **/
-
-(defpackage "clojure"
- (:export :load-types :*namespace-separator*
- :newobj :@ :compile-to :*clojure-source-path* :*clojure-target-path*
- "in-module"
- "defn*" "def" "defn" "fn"
- "if" "and" "or" "not" "when" "unless"
- "block" "let" "let*" "letfn"
- "set" "pset" "set*" "do"
- "try" "ex"
- "char" "boolean" "byte" "short" "int" "long" "float" "double"
- "import"))
-
-(in-package "clojure")
-
-(defvar *namespace-separator* nil
- "set to #\/ for JVM, #\. for CLI")
-
-
-(defconstant +MAX-POSITIONAL-ARITY+ 5)
-
-(defvar *host* nil) ; :jvm or :cli
-(defvar *clojure-source-path*)
-(defvar *clojure-target-path*)
-(defvar *symbols*)
-(defvar *keywords*)
-(defvar *vars*)
-(defvar *accessors*)
-(defvar *defvars*)
-(defvar *defns*)
-(defvar *quoted-aggregates* nil)
-(defvar *nested-fn-bindings*)
-(defvar *var-env* nil)
-(defvar *frame* nil)
-(defvar *next-id*)
-
-(defvar *imports*)
-
-;dynamic functions
-(defvar *reference-var*)
-
-#|
-;build the library
-(let ((*clojure-source-path* #p"/dev/clojure/src/lisp/")
- (*clojure-target-path* #p"/dev/clojure/classes/"))
- (compile-to :jvm "clojure.lib" "Clojure"
- "lib.lisp"))
-(let ((*clojure-source-path* #p"/dev/clojure/src/lisp/")
- (*clojure-target-path* #p"/dev/clojure/classes/test/"))
- (compile-to :cli "clojure.lib" "Clojure"
- "lib.lisp"))
-
-|#
-
-
-; a simple attribute object lib
-(defun newobj (&rest attrs)
- (let ((obj (make-hash-table)))
- (do* ((attrs attrs (nthcdr 2 attrs)))
- ((null attrs))
- (let ((attr (first attrs))
- (val (second attrs)))
- (setf (gethash attr obj) val)))
- obj))
-
-(defmacro @ (attr obj)
- `(gethash ',attr ,obj))
-
-
-(defun file-type ()
- (ecase *host*
- (:jvm "java")
- (:cli "cs")))
-
-;from c.l.l.
-(defun lex-string (string &key (whitespace
- '(#\space #\newline)))
- "Separates a string at whitespace and returns a list of strings"
- (flet ((whitespace? (char
-
- ) (member char whitespace :test #'char=)))
- (let ((tokens nil))
- (do* ((token-start
- (position-if-not #'whitespace? string)
- (when token-end
- (position-if-not #'whitespace? string :start (1+ token-end))))
- (token-end
- (when token-start
- (position-if #'whitespace? string :start token-start))
- (when token-start
- (position-if #'whitespace?
- string :start token-start))))
- ((null token-start) (nreverse tokens))
- (push (subseq string token-start token-end) tokens)))))
-
-(defun file-path (package-name)
- (ecase *host*
- (:jvm (lex-string package-name :whitespace '(#\.)))
- (:cli (list ""))))
-
-(defun package-open-format-string ()
- (ecase *host*
- (:jvm "package ~A;~2%")
- (:cli "namespace ~A {~2%")))
-
-(defun package-close-string ()
- (ecase *host*
- (:jvm "")
- (:cli "}")))
-
-(defun package-import-format-string ()
- (ecase *host*
- (: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 (package-name (symbol-package symbol)))
- (munge-name (symbol-name symbol))))
-
-(defun accessor-member-name (symbol)
- (format nil "ACC__~A"
- (subseq (symbol-name symbol) 1)))
-
-(defun symbol-member-name (symbol)
- (format nil "SYM__~A"
- (munge-name (symbol-name symbol))))
-
-(defun keyword-member-name (symbol)
- (format nil "KEY__~A"
- (munge-name (symbol-name symbol))))
-
-(defun munge-name (name)
- (setf name (string name))
- (when (digit-char-p (char name 0))
- (setf name (concatenate 'string "NUM__" name)))
- (labels ((rep (c)
- (second (assoc c
- '((#\- #\_)
- (#\. #\_)
- (#\+ "PLUS__")
- (#\> "GT__")
- (#\< "LT__")
- (#\= "EQ__")
- (#\~ "TILDE__")
- (#\! "BANG__")
- (#\@ "AT__")
- (#\# "SHARP__")
- (#\$ "DOLLAR__")
- (#\% "PCT__")
- (#\^ "CARAT__")
- (#\& "AMP__")
- (#\* "STAR__")
- (#\{ "LBRACE__")
- (#\} "RBRACE__")
- (#\[ "LBRACKET__")
- (#\] "RBRACKET__")
- (#\/ "SLASH__")
- (#\\ "BSLASH__")
- (#\? "QMARK__")))))
- (translate (c)
- (let ((r (rep c)))
- (or r c))))
- (if (find-if #'rep name)
- (format nil "~{~A~}" (map 'list #'translate name))
- name)))
-
-(defun begin-static-block (class-name)
- (ecase *host*
- (:jvm (format nil "static {~%"))
- (:cli (format nil "static ~A(){~%" class-name))))
-
-
-(defun compile-to (host package-name class-name &rest files)
- (let* ((*host* host)
- (orig-package *package*)
- (*features* (list* :clojure host *features*))
- (outpath (make-pathname
- :name class-name
- :type (file-type)
- :defaults (merge-pathnames
- (make-pathname :directory
- (list* :relative (file-path package-name)))
- *clojure-target-path*)))
- (*symbols* (list '|t|))
- (*defns* nil)
- (*defvars* nil)
- (*vars* nil)
- (*keywords* nil)
- (*accessors* nil))
- (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) "clojure.lang")
- (format target "public class ~A{~%" class-name)
- (unwind-protect
- (dolist (file files)
- (with-open-file (source (merge-pathnames file *clojure-source-path*))
- (labels
- ((process-form (form)
- (case (first form)
- (|in-module| (setf *package* (find-package (second form))))
- (|import| (|import| (second form) (second (third form))))
- ((|block|) (mapc #'process-form (rest form)))
- ((|defn*| |def| |defparameter| |defmain|)
- (let* ((target-sym (second form)))
- (princ target-sym)
- (terpri)
- (let ((*standard-output* target))
- (convert form))))
- (t
- (if (macro-function (car form))
- (process-form (macroexpand-1 form))
- (error "Unsupported form ~A" form))))))
- (let ((*readtable* (copy-readtable nil))
- (*imports* (make-hash-table :test #'equal)))
- (setf (readtable-case *readtable*) :preserve)
- (do ((form (read source nil 'eof) (read source nil 'eof)))
- ((eql form 'eof))
- (process-form form))))))
- (setf *package* orig-package))
- (dolist (sym *symbols*)
- (format target "static Symbol ~A = Symbol.intern(~S);~%"
- (symbol-member-name sym)
- (munge-name (symbol-name sym))))
- (dolist (keyword *keywords*)
- (format target "static Keyword ~A = (Keyword)Symbol.intern(~S);~%"
- (keyword-member-name keyword)
- (concatenate 'string ":" (munge-name (symbol-name keyword)))))
- (dolist (var *vars*)
- (format target "static Var ~A = Namespace.intern(~S,~S);~%"
- (var-member-name var)
- (munge-name (package-name (symbol-package var)))
- (munge-name (symbol-name var))))
- (dolist (accessor *accessors*)
- (format target "static Accessor ~A = (Accessor)Symbol.intern(~S);~%"
- (accessor-member-name accessor)
- (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.intern(~S,~S).bind(new ~A());~%"
- (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 (package-name (symbol-package var)))
- (munge-name (symbol-name var))
- (munge-name init))))
- (format target "}catch(Exception e){}~%}~%")
- ;(format target "}~%")
- (format target "public static void __init(){}~%")
- (format target "}~%")
- (format target "~A~%" (package-close-string)))))
-
-(defun convert (form)
- (let ((tree (analyze :top (macroexpand form)))
- (*next-id* 0))
- ;(print tree)
- (format t "/* Generated by Clojure from the following Lisp:~%")
- (pprint form)
- (format t "~%~%*/~2%")
- (emit :top tree)
- ;tree
- ))
-
-(defun get-next-id ()
- (incf *next-id*))
-
-(defun listize (x)
- (if (listp x)
- x
- (list x)))
-
-(defun |import| (package-string class-symbols)
- (dolist (c (listize class-symbols))
- (when (gethash (symbol-name c) *imports*)
- (error "Class ~A already imported from ~A" (symbol-name c) (gethash (symbol-name c) *imports*)))
- (setf (gethash (symbol-name c) *imports*) package-string)))
-
-(defun fully-qualified-class-name (class-name)
- (let ((package-string (gethash class-name *imports*)))
- (if package-string
- (let* ((assembly-point (position #\, package-string))
- (package (subseq package-string 0 assembly-point)))
- (concatenate 'string package "." class-name
- (when assembly-point (subseq package-string assembly-point))))
- (error "Can't find class ~A in imports" class-name))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; macros ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro |defn| (name params &body body)
- `(|defn*| ,name (,params ,@body)))
-
-(defmacro |fn| (params &body body)
- `(|fn*| (,params ,@body)))
-
-(defmacro |when| (test &rest result)
- `(|if| ,test (|block| ,@result)))
-
-(defmacro |unless| (test &rest result)
- `(|if| ,test nil (|block| ,@result)))
-
-(defmacro |cond| (&rest args)
- (if (null args)
- nil
- (let ((clause (first args)))
- (if (rest clause)
- `(|if| ,(first clause)
- (|block| ,@(rest clause))
- (|cond| ,@(rest args)))
- `(|or| ,(first clause)
- (|cond| ,@(rest args)))))))
-
-(defun pairize (lst)
- (if (null lst)
- nil
- (cons (cons (first lst) (second lst))
- (pairize (rest (rest lst))))))
-
-(defmacro |set*| (&rest args)
- (unless (evenp (length args))
- (error "odd number of arguments"))
- (labels ((recurse (sets)
- (when sets
- (cons (list '|set| (first sets) (second sets))
- (recurse (rest (rest sets)))))))
- (when args
- `(|block| ,@(recurse args)))))
-
-(defmacro |pset| (&rest args)
- (unless (evenp (length args))
- (error "odd number of arguments"))
- (let* ((pairs (pairize args))
- (syms (mapcar #'(lambda (x) (declare (ignore x))(gensym))
- pairs)))
- `(|let| ,(mapcar #'list
- syms
- (mapcar #'rest pairs))
- (|set*| ,@(mapcan #'list
- (mapcar #'first pairs)
- syms)))))
-
-(defmacro |do| (binds (test &optional result) &rest body)
- `(|let| ,(mapcar #'list (mapcar #'first binds) (mapcar #'second binds))
- (|loop|
- (|when| ,test
- (|break| ,result))
- ,@body
- (|pset| ,@(mapcan #'list
- (mapcar #'first binds)
- (mapcar #'third binds))))))
-
-
-
-(defmacro |defcomparator| (op prim)
- `(|defn*| ,op
- ((x) t)
- ((x y)
- (,prim x y))
- ((x y & rest)
- (|and| (,prim x y)
- (|apply| ,op y rest)))))
-
-;(defmacro |block| (&body body)
-; `(|let| nil ,@body))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; analyze and emit ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze (context form)
- "context - one of :top :return :statement :expression :fn"
- (cond
- ((consp form) (analyze-op context (first form) form))
- ((or (null form)(eql '|nil| form)) nil)
- ((eql '|t| form) t)
- ((symbolp form) (analyze-symbol context form))
- (t form)))
-
-(defun analyze-op (context op form)
- (case op
- (quote (analyze-quote context form))
- (|defn*| (analyze-defn* context form))
- (|def| (analyze-def context form))
- (|defmain| (analyze-defmain context form))
- (|block| (analyze-block context form))
- (|fn*| (analyze-fn* context form))
- (|if| (analyze-if context form))
- ((|not| |null|) (analyze-not context form))
- (|and| (analyze-and context form))
- (|or| (analyze-or context form))
- (|set| (analyze-set context form))
- (|let| (analyze-let context form))
- (|letfn| (analyze-letfn context form))
- (|let*| (analyze-let* context form))
- (|loop| (analyze-loop context form))
- (|break| (analyze-break context form))
- (|try| (analyze-try context form))
- (|bind| (analyze-bind context form))
- (|instance?| (analyze-instance? context form))
- ((|char| |boolean| |byte| |short| |int| |long| |float| |double|)
- (analyze-cast context form))
- (t (analyze-invoke context op form))))
-
-(defmacro emit-to-string (&body body)
- `(with-output-to-string (s)
- (let ((*standard-output* s))
- ,@body)))
-
-(defun emit (context expr)
- (cond
- ((null expr) (emit-nil context))
- ((typep expr 'hash-table) ;objs
- (ccase (@ :type expr)
- (:defn* (emit-defn* context expr))
- (:main (emit-main context expr))
- (:fn* (emit-fn* context expr))
- (:binding (emit-binding context expr))
- (:accessor (emit-accessor context expr))
- (:keyword (emit-keyword context expr))
- (:global-binding (emit-global-binding context expr))
- (:block (emit-block context expr))
- (:invoke (emit-invoke context expr))
- (:let (emit-let context expr))
- (:if (emit-if context expr))
- (:not (emit-not context expr))
- (:or (emit-or context expr))
- (:and (emit-and context expr))
- (:set (emit-set context expr))
- (:loop (emit-loop context expr))
- (:break (emit-break context expr))
- (:try (emit-try context expr))
- (:bind(emit-bind context expr))
- (:quoted-aggregate (emit-quoted-aggregate context expr))
- (:host-symbol (emit-host-static-member context expr))
- (:cast (emit-cast context expr))
- (:instance? (emit-instance? context expr))))
- (t (emit-other context expr))))
-
-(defun emit-other (context expr)
- (ccase context
- (:statement);no-op
- (:return (emit-return expr))
- (:expression
- (cond
- ((null expr) (emit-nil context))
- ((eql t expr) (format t "RT.T"))
- ((stringp expr) (format t "~S" expr))
- ((characterp expr) (format t "RT.box('~A')" expr))
- ((numberp expr)
- (case expr
- (0 (format t "Num.ZERO"))
- (1 (format t "Num.ONE"))
- (t (format t "Num.from(~A)" expr))))
- ((symbolp expr)
- (cond
- ((keywordp expr)
- (format t "~A" (keyword-member-name expr)))
- ((accessor? expr)
- (format t "~A" (accessor-member-name expr)))
- ((host-symbol? expr)
- (multiple-value-bind (class-name member-name)
- (host-class-and-member-strings expr)
- (format t "Reflector.getStaticField(~S,~S)" member-name class-name)))
- (t (format t "~A" (var-member-name expr)))))
- ((consp expr)
- (format t "RT.arrayToList(new Object[]{~{~A~^, ~}})"
- (mapcar (lambda (e)
- (emit-to-string (emit :expression e)))
- expr)))))))
-
-(defun emit-host-static-member (context expr)
- (ccase context
- (:statement);no-op
- (:return (emit-return expr))
- (:expression
- (multiple-value-bind (class-name member-name)
- (host-class-and-member-strings (@ :symbol expr))
- (format t "Reflector.getStaticField(~S,~S)" member-name class-name)))))
-
-(defun emit-return (expr)
- (format t "return ")
- (emit :expression expr)
- (format t ";~%"))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; quote ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-quote (context form)
- (let ((q (second form)))
- (cond
- ((symbolp q)
- (cond
- ((keywordp q)
- (register-keyword-reference q))
- ((host-symbol? q) (error "Can't quote host symbols"))
- ((accessor? q)
- (register-accessor-reference q))
- (t (register-var-reference q)))
- q)
- ((atom q) q)
- (t
- (let* ((ql (newobj :type :quoted-aggregate :symbol (gensym "QA__") :form q)))
- (register-quoted-aggregate ql)
- ql)))))
-
-(defun emit-quoted-aggregate (context expr)
- (ccase context
- (:return (emit-return expr))
- (:expression
- (format t "~A" (munge-name (@ :symbol expr))))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; cast/instance? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-cast (context form)
- (declare (ignore context))
- (newobj :type :cast
- :to (first form)
- :expr (analyze :expression (macroexpand (second form)))))
-
-(defun emit-cast (context expr)
- (ccase context
- (:return (emit-return expr))
- (:expression
- (format t "RT.box(RT.~ACast(" (symbol-name (@ :to expr)))
- (emit :expression (@ :expr expr))
- (format t "))"))))
-
-(defun analyze-instance? (context form)
- (declare (ignore context))
- (assert (host-type-symbol? (third form)))
- (newobj :type :instance?
- :expr (analyze :expression (macroexpand (second form)))
- :sym (analyze-symbol :statement (third form))))
-
-(defun emit-instance? (context expr)
- (ccase context
- (:return (emit-return expr))
- (:expression
- (format t "(")
- (emit :expression (@ :expr expr))
- (format t" ~A ~A?RT.T:null)"
- (instanceof-string)
- (multiple-value-bind (class-name member-name)
- (host-class-and-member-strings (@ :symbol (@ :sym expr)))
- ;trim off any assembly cruft
- (subseq class-name 0 (position #\, class-name)))))))
-
-(defun instanceof-string ()
- (ccase *host*
- (:jvm "instanceof")
- (:cli "is")))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; set ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-set (context form)
- ;expecting one of
- ;(set local val) => local = val;
- ;(set var val) => var.setValue(val);
- ;(set class.member val) => Reflector.setStaticField("member","java.lang.Class",val);
- ;(set (:key x) val) => key.invoke(x,val);
- ;(set (.accessor x) val) => accessor.invoke(x, val);
- ;(set (global x y z ...) val)) => global.setfn.invoke(val, x, y, z)
- (declare (ignore context))
- (let ((val (analyze :expression (macroexpand (third form)))))
- (if (atom (second form))
- (let ((target (analyze-symbol :statement (second form))))
- (when (eql (@ :type target) :binding)
- (setf (@ :assigned? target) t))
- (newobj :type :set
- :target target
- :val val))
- (let* ((place (second form))
- (name (analyze-symbol :statement (first place)))
- (args (mapcar (lambda (e)
- (analyze :expression (macroexpand e)))
- (rest place))))
- (ccase (@ :type name)
- ((:keyword :accessor :global-binding)
- (newobj :type :set
- :name name
- :args args
- :val val)))))))
-
-(defun emit-set (context expr)
- (if (eql context :return)
- (emit-return expr)
- (progn
- (when (member context '(:expression :fn))
- (format t "("))
- (let ((val (@ :val expr))
- (name (@ :name expr)))
- (if name ;must be a place
- (ccase (@ :type name)
- ((:keyword :accessor)
- (emit :expression name)
- (format t ".invoke(")
- (emit :expression (first (@ :args expr)))
- (format t ", ")
- (emit :expression val)
- (format t ")"))
- (:global-binding
- (format t "~A.setfn.invoke(" (var-member-name (@ :symbol name)))
- (emit :expression val)
- (format t "~{, ~A~}"
- (mapcar (lambda (e)
- (emit-to-string (emit :expression e)))
- (@ :args expr)))
- (format t ")")))
- (let ((target (@ :target expr)))
- (ccase (@ :type target)
- (:binding
- (emit :expression target)
- (format t " = ")
- (emit :expression val))
- (:global-binding
- (format t "~A.setValue(" (var-member-name (@ :symbol target)))
- (emit :expression val)
- (format t ")"))
- (:host-symbol
- (multiple-value-bind (class-name member-name)
- (host-class-and-member-strings (@ :symbol target))
- (format t "Reflector.setStaticField(~S, ~S, " member-name class-name)
- (emit :expression val)
- (format t ")")))))))
- (when (member context '(:expression :fn))
- (format t ")"))
- (when (eql context :statement)
- (format t ";~%")))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; if ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-if (context form)
- (if (eql (second form) '|t|)
- ;optimize macro-generated (if t ...) forms
- (analyze context (macroexpand (third form)))
- (let* ((test (analyze :expression (macroexpand (second form))))
- (negate (and (hash-table-p test)(eql :not (@ :type test)))))
- (newobj :type :if
- :test (if negate (@ :expr test) test)
- :comp (if negate "==" "!=")
- :then (analyze context (macroexpand (third form)))
- :else (when (fourth form)
- (analyze context (macroexpand (fourth form))))
- :else-p (= 4 (length form))))))
-
-(defun emit-if (context expr)
- (let ((test (@ :test expr))
- (then (@ :then expr))
- (else (@ :else expr))
- (else-p (@ :else-p expr))
- (comp (@ :comp expr)))
- (ccase context
- (:expression
- (format t "(")
- (emit :expression test)
- (format t " ~A null?" comp)
- (emit :expression then)
- (format t ":")
- (emit :expression else)
- (format t ")"))
- (:statement
- (format t "if(")
- (emit :expression test)
- (format t " ~A null)~%{~%" comp)
- (emit context then)
- (format t "}~%")
- (when (and else-p else)
- (format t "else~%{~%")
- (emit context else)
- (format t "}~%")))
- (:return
- (format t "if(")
- (emit :expression test)
- (format t " ~A null)~%{~%" comp)
- (emit context then)
- (format t "}~%")
- (format t "else~%{~%")
- (if else-p
- (emit context else)
- (format t "return null;~%"))
- (format t "}~%")))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; not/null ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-not (context form)
- (declare (ignore context))
- (newobj :type :not :expr (analyze :expression (macroexpand (second form)))))
-
-(defun emit-not (context expr)
- (ccase context
- ;just for side effects if statement, no negation
- (:return (emit-return expr))
- (:statement
- (emit context (@ :expr expr)))
- ((:fn :expression)
- (format t "((")
- (emit :expression (@ :expr expr))
- (format t ")==null?RT.T:null)"))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; or ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-or (context form)
- (let ((temp (newobj :type :binding :symbol (gensym))))
- (unless (eql context :statement)
- (register-local-binding temp))
- (newobj :type :or
- :temp temp
- :exprs (mapcar (lambda (e)
- (analyze :expression (macroexpand e)))
- (rest form)))))
-
-(defun emit-or (context expr)
- (let ((temp (@ :temp expr))
- (exprs (@ :exprs expr)))
- (ccase context
- (:return (emit-return expr))
- (:statement
- (format t "if(~{(~A != null)~^||~})~%;~%"
- (mapcar (lambda (e)
- (emit-to-string (emit :expression e)))
- exprs)))
- ((:expression :fn)
- (format t "((~{((~A = ~A) != null)~^||~})?~A:null)"
- (mapcan (lambda (e)
- (list (binding-name temp) (emit-to-string (emit :expression e))))
- exprs)
- (binding-name temp))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; and ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-
-(defun analyze-and (context form)
- (declare (ignore context))
- (newobj :type :and
- :exprs (mapcar (lambda (e)
- (analyze :expression (macroexpand e)))
- (rest form))))
-
-(defun emit-and (context expr)
- (let ((exprs (@ :exprs expr)))
- (ccase context
- (:return (emit-return expr))
- (:statement
- (format t "if(~{(~A != null)~^&&~})~%;~%"
- (mapcar (lambda (e)
- (emit-to-string (emit :expression e)))
- exprs)))
- ((:expression :fn)
- (format t "((~{(~A != null)~^&&~})?~A:null)"
- (mapcar (lambda (e)
- (emit-to-string (emit :expression e)))
- (butlast exprs))
- (emit-to-string (emit :expression (first (last exprs)))))))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; invoke ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-invoke (context op form)
- (declare (ignore context))
- ;if we hit this unspecialized method, it is not a special op, presume function invocation
- (newobj :type :invoke
- :fexpr (if (symbolp op)
- (analyze-symbol :fn op)
- (analyze :fn op))
- :args (mapcar (lambda (e)
- (analyze :expression e))
- (rest form))))
-
-(defun emit-invoke (context expr)
- (ccase context
- (:statement
- (emit :expression expr)
- (format t ";~%"))
- (:return
- (emit-return expr))
- ((:expression :fn)
- (let* ((fexpr (@ :fexpr expr))
- (global-binding? (eql :global-binding (@ :type fexpr)))
- (host-symbol? (eql :host-symbol (@ :type fexpr)))
- (static-method? (will-be-static-method fexpr))
- (args (@ :args expr)))
- (cond
- (host-symbol?
- (multiple-value-bind (class-name member-name)
- (host-class-and-member-strings (@ :symbol fexpr))
- (format t "Reflector.invokeStaticMethod(~S,~S,new Object[]{~{~A~^,~}})"
- member-name
- class-name
- (mapcar (lambda (e)
- (emit-to-string
- (emit :expression e)))
- args))))
- (t
- (when (not (or global-binding? static-method?))
- (format t "((IFn)"))
- (emit :fn fexpr)
- (when (not (or global-binding? static-method?))
- (format t ")"))
- (unless static-method?
- (format t ".invoke"))
- (format t "(")
- (when static-method?
- (let ((closes (@ :closes (first (@ :methods (@ :fn fexpr))))))
- (format t "~{~A~^, ~}"
- (mapcar (lambda (b)
- (binding-name b))
- closes))))
- (format t "~{~A~^, ~}"
- (mapcar (lambda (e)
- (emit-to-string
- (emit :expression e)))
- args))
- (format t ")")))))))
-
-
-
-(defun emit-global-binding (context expr)
- (ccase context
- (:return
- (emit-return expr))
- ((:expression :return)
- (format t "~A.getValue()" (var-member-name (@ :symbol expr))))
- (:fn
- (format t "~A.fn()" (var-member-name (@ :symbol expr))))
- (:statement)))
-
-(defun emit-accessor (context expr)
- (declare (ignore context))
- (format t "~A" (accessor-member-name (@ :symbol expr))))
-
-(defun emit-keyword (context expr)
- (declare (ignore context))
- (format t "~A" (keyword-member-name (@ :symbol expr))))
-
-(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)
- (ccase context
- (:statement) ;var statement is a no-op
- ((:expression :fn)
- (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))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;; let ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun normalize-let-bindings (binding-list)
- (mapcar (lambda (b)
- (if (atom b)
- (list b nil)
- b))
- binding-list))
-
-(defun analyze-let (context form)
- (let ((bindings (normalize-let-bindings (second form)))
- (body (rest (rest form))))
- (cond
- ;special case of (let () expr) ==> expr
- ((not (or bindings (> (length body) 1)))
- (analyze context (macroexpand (third form))))
- ((eql context :expression)
- (analyze :expression `((|fn*| (,(mapcar #' first bindings) ,@body))
- ,@(mapcar #'second bindings))))
- (t (let* ((binding-inits
- ;init exprs are analyzed prior to adding bindings to env
- (mapcar (lambda (b)
- (newobj :binding (newobj :type :binding :symbol (first b))
- :init (analyze :expression (second b))))
- bindings))
- (*var-env* *var-env*))
- (mapc (lambda (binit)
- (register-local-binding (@ :binding binit))
- (add-to-var-env (@ :binding binit)))
- binding-inits)
- (newobj :type :let
- :binding-inits binding-inits
- :body (analyze-body context body)))))))
-
-(defun analyze-let* (context form)
- (let ((bindings (normalize-let-bindings (second form)))
- (body (rest (rest form))))
- (cond
- ;special case of (let () expr) ==> expr
- ((not (or bindings (> (length body) 1)))
- (analyze context (macroexpand (third form))))
- ((eql context :expression)
- (analyze :expression `((|fn*| (() ,form)))))
- (t (let* ((*var-env* *var-env*)
- (binding-inits
- (mapcar (lambda (b)
- ;sequential binding
- (let ((binit
- (newobj :binding (newobj :type :binding :symbol (first b))
- :init (analyze :expression (second b)))))
- (register-local-binding (@ :binding binit))
- (add-to-var-env (@ :binding binit))
- binit))
- bindings)))
- (newobj :type :let
- :binding-inits binding-inits
- :body (analyze-body context body)))))))
-
-(defun analyze-letfn (context form)
- (cond
- ((eql context :expression)
- (analyze :expression `((|fn*| (() ,form)))))
- (t
- (let* ((*var-env* *var-env*)
- (binding-exprs
- ;adding all bindings to env first, mark as assigned to allow for recursion and mutual reference
- (mapcar (lambda (b)
- (destructuring-bind (name params &rest body) b
- (let ((binding (newobj :type :binding :symbol name
- :assigned? t
- )))
- (register-local-binding binding)
- ;(register-nested-fn-binding binding)
- (add-to-var-env binding)
- ;don't analyze lambdas yet
- (list binding `(|fn*| (,params ,@body))))))
- (second form))))
- (newobj :type :let
- :binding-inits (mapcar (lambda (be)
- (let ((binding (first be))
- (fn (analyze :expression (second be))))
- (setf (@ :fn binding) fn)
- (setf (@ :binding fn) binding)
- (newobj :binding binding :init fn)))
- binding-exprs)
- :body (analyze-body context (rest (rest form))))))))
-
-(defun emit-let (context expr)
- (let ((binding-inits (@ :binding-inits expr))
- (body (@ :body expr)))
- (dolist (bi binding-inits)
- (unless (will-be-static-method (@ :binding bi))
- (emit :expression (@ :binding bi))
- (format t " = ")
- (emit :expression (@ :init bi))
- (format t ";~%")))
- (emit-body context body)))
-
-(defun analyze-body (context exprs)
- (when exprs
- (case context
- (:statement
- (mapcar (lambda (expr)
- (analyze :statement (macroexpand expr)))
- exprs))
- (:return
- (append (mapcar (lambda (expr)
- (analyze :statement (macroexpand expr)))
- (butlast exprs))
- (list (analyze :return (macroexpand (first (last exprs))))))))))
-
-(defun emit-body (context body)
- (case context
- (:return
- (dolist (e (butlast body))
- (emit :statement e))
- (if body
- (emit :return (first (last body)))
- (format t "return null;~%")))
- (:statement
- (dolist (e body)
- (emit :statement e)))))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; bind ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun analyze-bind (context form)
- (let ((bindings (normalize-let-bindings (second form)))
- (body (rest (rest form))))
- (ccase context
- ((:expression :fn)
- (analyze :expression `((|fn*| (() ,form)))))
- ((:statement :return)
- (let* ((binding-inits
- (mapcar (lambda (b)
- (register-var-reference (first b))
- (newobj :binding (newobj :type :global-binding :symbol (first b))