clojure.lisp 早期的clojure clisp 实

不是sbcl ! 在wsl中安装clisp 运行就ok. (是80 wx)
运行: linux
apt install clisp
clisp (load "clojure.lisp") (in-package "clojure")
然后把clojure.lisp中的一段代码粘贴运行. (需要先设置好下面用到的文件夹和文件. )
defun compile-to (host package-name class-name &rest files)

clojure 项目中 git checkout 8bdcea4f
然后在wsl中(ubuntu)
mkdir /dev/clojure/src/lisp/     (需要在 这个文件夹中加入test.lisp)
mkdir /dev/clojure/classes/

(let ((*clojure-source-path* #p"/dev/clojure/src/lisp/")
      (*clojure-target-path* #p"/dev/clojure/classes/"))
  (compile-to :jvm "clojure.lib" "Clojure" "test.lisp"))

(let ((*clojure-source-path* #p"/dev/clojure/src/lisp/")
      (*clojure-target-path* #p"/dev/clojure/classes/"))
  (compile-to :jvm "clojure.lib" "Clojure"   "lib.lisp"))
输出的时候会提示安全问题 <OUTPUT BUFFERED FILE-STREAM CHARACTER
直接输入 continue 则会生成Clojure.java

;/**
; *   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))
                                 :init (analyze :expression (second b))))
                       bindings)))
         ;(register-needs-tls)
         (newobj :type :bind
                 :binding-inits binding-inits
                 :body (analyze-body context (macroexpand body))))))))

(defun emit-bind (context expr)
  (ccase context
    ((:statement :return)
       (let ((binding-inits (@ :binding-inits expr))
             (body (@ :body expr)))
         (format t "try {~%")
         (dolist (bi binding-inits)
           (format t "~A.pushDynamicBinding(" (var-member-name (@ :symbol (@ :binding bi))))
           (emit :expression (@ :init bi))
           (format t ");~%"))
         (emit-body context body)
         (format t "}~%finally {~%")
         (dolist (bi binding-inits)
           (format t "~A.popDynamicBinding();~%" (var-member-name (@ :symbol (@ :binding bi)))))
         (format t "}~%")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; block ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun emit-block (context expr)
  (when (@ :body expr)
    ;(format t "{~%")
    (emit-body context (@ :body expr))
    ;(format t "}~%")
    ))

(defun analyze-block (context form)
  (cond 
   ((null (rest form))
      (analyze context '|nil|))
   ((null (rest (rest form)))
      (analyze context (macroexpand (second form))))
   (t (ccase context
        (:expression (analyze context `((|fn*| (() ,@(rest form))))))
        ((:statement :return) (newobj :type :block
                                      :body (analyze-body context (rest form))))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; loop/break ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar *loop-context*)

(defun analyze-loop (context form)
  (ccase context 
    ((:expression :fn)
     (analyze :expression `((|fn*| (() ,form)))))
    ((:statement :return)
     (newobj :type :loop
             :body (analyze-body context (rest form))))))

(defun emit-loop (context expr)
  (let ((*loop-context* context))
    (format t "for(;;)~%{~%")
    (emit-body :statement (@ :body expr))
    (format t "}~%")))

(defun analyze-break (context form)
  (ccase context
    ((:statement :return)
     (newobj :type :break
             :result (analyze context (macroexpand (second form)))))))

(defun emit-break (context expr)
  (declare (ignore context))
  (ccase *loop-context*
    (:statement
     (emit :statement (@ :result expr))
     (format t "break;~%"))
    (:return
     (emit :return (@ :result expr)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; try ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#|
(try
 (body 1 2 3)
 (some-catch-code-presuming-ex-bound-to-exception ...)
 (do-something-finally))
|#

(defun analyze-try (context form)
  (ccase context
    ((:expression :fn)
     (analyze :expression `((|fn*| (() ,form)))))
    ((:statement :return)
     (let* ((catch-clause (macroexpand (third form)))
            (ex-binding (when catch-clause
                          (newobj :type :binding
                                  :symbol '|ex|
                                  :ex-name? t))))
       (newobj :type :try
               :body (analyze context (macroexpand (second form)))
               :catch (when catch-clause
                        (let ((*var-env* *var-env*))
                          (register-local-binding ex-binding)
                          (add-to-var-env ex-binding)
                          (analyze context catch-clause)))
               :ex ex-binding
               :finally (analyze :statement (macroexpand (fourth form))))))))

(defun emit-try (context expr)
  (ccase context
    ((:statement :return)
     (let ((body (@ :body expr))
           (catch-clause (@ :catch expr))
           (ex (@ :ex expr))
           (finally-clause (@ :finally expr)))
       (format t "try{~%")
       (emit context body)
       (format t "}~%")
       (when catch-clause
         (format t "catch (Exception ~A){~%" (binding-name ex))
         (emit context catch-clause)
         (format t "}~%"))
       (format t "finally{~%")
       (emit :statement finally-clause)
       (format t "}~%")))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defmain ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun analyze-defmain (context form)
  (ccase context
    (:top 
     (register-var-reference (second form))
     (newobj :type :main
                  :fname (second form)))))

(defun emit-main (context expr)
  (ccase context
    (:top
     (format t "static public void ~A(String[] args){~%try{~%~A.fn().invoke(args);~%}~%catch(Exception ex){}~%}~%"
             (main-string) (var-member-name (@ :fname expr))))))

(defun main-string ()
  (ccase *host*
    (:jvm "main")
    (:cli "Main")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; defn ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun analyze-defn* (context form)
  (assert (eql context :top))
  (let* ((*quoted-aggregates* nil)
         (*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)
  (ccase 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))))))
    (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 register-nested-fn-binding (b)
  (push b *nested-fn-bindings*))

(defun analyze-fn* (context form)
  (let ((fn (newobj :type :fn*
                    :methods (mapcar (lambda (m)
                                       (analyze-method (first m) (rest m)))
                                     (rest form)))))
    (if (member context '(:return :expression :fn))
      ;presume anonymous fn
        (let ((b (newobj :type :binding
                         :fn fn
                         :symbol (gensym "FN__")
                         :anonymous-fn? t
                         :value-taken? (not (eql context :fn)))))
          (setf (@ :binding fn) b)
          (register-nested-fn-binding b)
          b)
      fn)))

(defun emit-fn* (context expr)
  (emit-binding context (@ :binding expr)))

(defun analyze-method (params body)
  (let* ((*frame* (newobj :parent *frame*))
         (*var-env* *var-env*)
         (state :reqs))
    (flet ((create-param-binding (p)
             (let ((b (newobj :type :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)))))))

      (when (> (length (@ :reqs *frame*)) +MAX-POSITIONAL-ARITY+)
        (error "sorry, can't have more than ~S required args" +MAX-POSITIONAL-ARITY+))
      (setf (@ :reqs *frame*) (nreverse (@ :reqs *frame*)))
      (setf (@ :body *frame*) (analyze :return `(|block| ,@body)))

      *frame*)))

(defun analyze-def (context form)
  (assert (eql context :top))
  (destructuring-bind (name init init-provided) (rest form)
    (newobj :type :def
     :name name
     :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 overrides-string ()
  (case *host*
    (:jvm "")
    (:cli "override ")))

(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)
  (and (= (length (@ :methods fn)) 1)
       (not (@ :rest (first (@ :methods 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-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) (binding-name b)))
                               ;expecting only one method if closure
                               (@ :closes (first methods)))))
    (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 methods))))
        (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 (m methods)
      ;if static, we are expecting this to run once
      (unless as-static-method?
        (format t "~Apublic Object ~A(" (overrides-string) (fn-name m)))

        ;params
      (let ((rest (@ :rest m)))
        (format t "~{~A ~A~@[~A~]~^, ~}"
                (mapcan (lambda (b)
                          (list 
                           (binding-type-decl b)
                           (binding-name b)
                           (when (needs-box b)
                             "__arg")))
                        (@ :reqs m)))
        (when rest
          (when (@ :reqs m)
            (format t ", "))
          (format t "ISeq ~A~@[~A~]"
                  (binding-name rest)
                  (when (needs-box rest) "__arg"))))

      (format t ") ~A ~%{~%" (exception-declaration-string))

        ;tls
      ;(when (@ :needs-tls m)
      ;  (format t "if(__tld == null) __tld = ThreadLocalData.get();~%"))

        ;parameter binding declarations,if needed
          ;reqs
      (dolist (b (@ :reqs m))
        (when (needs-box b)
          (emit-binding-declaration b (munge-closed-over-assigned-arg b))))
        
      ;rest
      (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 m))
            ; fixup the names, numbering all locals
        (unless (@ :param? b)
          (setf (@ :id b) (get-next-id))
          (unless (or (@ :anonymous-lambda? b)
                      (@ :ex-name? b)
                      (will-be-static-method b))
            (emit-binding-declaration b))))

          ;body
      (emit :return (@ :body m))
          
          ;end of invoke function
      (format t "}~%"))
        

    (unless as-static-method?
      ;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)))
       ;end of class
      (format t "}~%"))))

(defun register-var-reference (sym)
  (pushnew sym *vars*))

(defun register-quoted-aggregate (qa)
  (pushnew qa *quoted-aggregates*))

(defun register-accessor-reference (sym)
  (pushnew sym *accessors*))

(defun register-keyword-reference (sym)
  (pushnew sym *keywords*))

;(defun register-needs-tls ()
;  (setf (@ :needs-tls *frame*) t))

(defun register-local-binding (b)
  (push b (@ :local-bindings *frame*)))

(defun host-symbol? (sym)
  (find #\. (string sym) :start 1))

(defun host-type-symbol? (sym)
  (and (host-symbol? sym)
       (= 1 (length (subseq (string sym) (position  #\. (string sym) :from-end t))))))

(defun host-class-and-member-strings (host-symbol)
  (let* ((host-name (symbol-name host-symbol))
         (dot-pos (position #\. host-name :from-end t ))
         (class-name (subseq host-name 0 dot-pos))
         (member-name (subseq host-name (1+ dot-pos))))
    (values (fully-qualified-class-name class-name) member-name)))

(defun accessor? (sym)
  (eql (char (string sym) 0) #\.))

(defun analyze-symbol (context sym)
  (cond
   ((keywordp sym)
    (register-keyword-reference sym)
    (newobj :type :keyword :symbol sym))
   ((host-symbol? sym) (newobj :type :host-symbol :symbol sym))
   ((accessor? sym)
    (register-accessor-reference sym)
    (newobj :type :accessor :symbol sym))
   (t (or (reference-var sym)
          ;not a local var
          (progn
            (register-var-reference sym)
            ;(unless (eql context :fn)
            ;  (register-needs-tls))
            (newobj :type :global-binding :symbol sym)
            )))))


;load-types is for typed host references
;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)
        (make-package name :use '())))


(defun primitive-name (tn)
  (or (cdr (assoc tn
                   '(("Z" . "boolean")
                     ("B" . "byte")
                     ("C" . "char")
                     ("S" . "short")
                     ("I" . "int")
                     ("J" . "long")
                     ("F" . "float")
                     ("D" . "double")
                     ("V" . "void"))
                   :test #'string-equal))
      tn))

(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
 uses *namespace-separator*
 note that this interns symbols and pushes plist entries on them, 
 is destructive and not idempotent, so delete-package any packages prior to re-running"
  (unless *namespace-separator*
    (error "*namespace-separator* must be set"))
  (labels
      ((type-name (td)
         (second (assoc :name td)))
       (arity (entry)
         (second (assoc :arity (rest entry))))
       (name (entry)
         (second (assoc :name (rest entry))))
       (static? (entry)
         (second (assoc :static (rest entry))))
       (simple-name (tn)
         (when tn
           (let ((base-name (if (find *namespace-separator* tn)
                                (subseq tn
                                        (1+ (position *namespace-separator* tn :from-end t))
                                        (position #\; tn :from-end t))
                              (primitive-name (subseq tn (if (java-array-name? tn)
                                                             (1+ (position #\[ tn :from-end t))
                                                           0))))))
             (if (java-array-name? tn)
                 (with-output-to-string (s)
                   (write-string base-name s)
                   (dotimes (x (1+ (position #\[ tn :from-end t)))
                     (write-string "[]" s)))
               base-name))))
         (sig (entry)
              (format nil "<~{~A~^*~}>"
                      (mapcar #'simple-name (rest (assoc :args (rest entry)))))))
    (let ((type-descriptors (with-open-file (f type-file)
                              (read f))))
      (dolist (td type-descriptors)
        (let* ((split (position *namespace-separator* (type-name td) :from-end t))
               (package-name (subseq (type-name td) 0 split))
               (class-name (string-append (subseq (type-name td) (1+ split)) "."))
               (package (ensure-package package-name))
               (class-sym (intern class-name package)))
          (export class-sym package)
          (dolist (entry td)
            (case (first entry)
              (:field
               (let ((field-sym (intern (concatenate 'string
                                                     (unless (static? entry)
                                                       ".")
                                                     class-name
                                                     (name entry))
                                        package)))
                 (export field-sym package)
                 (setf (get field-sym 'type-info) entry)))
              (:ctor
               (let* ((ar (arity entry))
                      (overloaded (member-if (lambda (e)
                                               (and (not (equal e entry))
                                                    (eql (first e) :ctor)
                                                    (eql (arity e) ar)))
                                             td))
                      (ctor-sym (intern (concatenate 'string 
                                                     class-name
                                                     "new"
                                                     (when overloaded
                                                       (sig entry)))
                                        package)))
                 (export ctor-sym package)
                 (push entry (get ctor-sym 'type-info))))
              (:method
               (let* ((ar (arity entry))
                      (nm (name entry))
                      (overloaded (member-if (lambda (e)
                                               (and (not (equal e entry))
                                                    (eql (first e) :method)
                                                    (string= (name e) nm)
                                                    (eql (arity e) ar)
                                                    (eql (static? e) (static? entry`))))
                                             td))
                      (method-sym (intern (concatenate 'string 
                                                       (unless (static? entry)
                                                       ".")
                                                       class-name
                                                       nm
                                                       (when overloaded
                                                         (sig entry)))
                                          package)))
                 (export method-sym package)
                 (push entry (get method-sym 'type-info)))))))))
    t))
|#