不是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))
|#
网友评论