X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=3dc2f1ca2ff155b96342f6a5e74154747e70e5e4;hb=68cd2db6542fa3442d46b0331ecf8be8f86c09c2;hp=29c491b3d82def134cbe998a7f71f470c2916471;hpb=b4f81895de2164b4f362c3050b74a45c1f5069e2;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 29c491b..3dc2f1c 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -87,62 +87,6 @@ ;;; function call. (defvar *multiple-value-p* nil) -;; A very simple defstruct built on lists. It supports just slot with -;; an optional default initform, and it will create a constructor, -;; predicate and accessors for you. -(defmacro def!struct (name &rest slots) - (unless (symbolp name) - (error "It is not a full defstruct implementation.")) - (let* ((name-string (symbol-name name)) - (slot-descriptions - (mapcar (lambda (sd) - (cond - ((symbolp sd) - (list sd)) - ((and (listp sd) (car sd) (cddr sd)) - sd) - (t - (error "Bad slot description `~S'." sd)))) - slots)) - (predicate (intern (concat name-string "-P")))) - `(progn - ;; Constructor - (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions) - (list ',name ,@(mapcar #'car slot-descriptions))) - ;; Predicate - (defun ,predicate (x) - (and (consp x) (eq (car x) ',name))) - ;; Copier - (defun ,(intern (concat "COPY-" name-string)) (x) - (copy-list x)) - ;; Slot accessors - ,@(with-collect - (let ((index 1)) - (dolist (slot slot-descriptions) - (let* ((name (car slot)) - (accessor-name (intern (concat name-string "-" (string name))))) - (collect - `(defun ,accessor-name (x) - (unless (,predicate x) - (error "The object `~S' is not of type `~S'" x ,name-string)) - (nth ,index x))) - ;; TODO: Implement this with a higher level - ;; abstraction like defsetf or (defun (setf ..)) - (collect - `(define-setf-expander ,accessor-name (x) - (let ((object (gensym)) - (new-value (gensym))) - (values (list object) - (list x) - (list new-value) - `(progn - (rplaca (nthcdr ,',index ,object) ,new-value) - ,new-value) - `(,',accessor-name ,object))))) - (incf index))))) - ',name))) - - ;;; Environment (def!struct binding @@ -433,7 +377,7 @@ " && ") ")" *newline* (indent - "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*)) + "throw 'Unknown keyword argument ' + xstring(arguments[i].name);" *newline*)) "}" *newline*))))) (defun parse-lambda-list (ll) @@ -537,7 +481,8 @@ (code "(" result ")"))) -;;; Literals +;;; Compilation of literals an object dumping + (defun escape-string (string) (let ((output "") (index 0) @@ -553,10 +498,19 @@ (incf index)) output)) - (defvar *literal-table* nil) (defvar *literal-counter* 0) +;;; BOOTSTRAP MAGIC: During bootstrap, we record the macro definitions +;;; as lists. Once everything is compiled, we want to dump the whole +;;; global environment to the output file to reproduce it in the +;;; run-time. However, the environment must contain expander functions +;;; rather than lists. We do not know how to dump function objects +;;; itself, so we mark the definitions with this object and the +;;; compiler will be called when this object has to be dumped. +;;; Backquote/unquote does a similar magic, but this use is exclusive. +(defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE")) + (defun genlit () (code "l" (incf *literal-counter*))) @@ -564,13 +518,13 @@ #+common-lisp (let ((package (symbol-package symbol))) (if (eq package (find-package "KEYWORD")) - (code "{name: " (dump-string (symbol-name symbol)) - ", 'package': " (dump-string (package-name package)) "}") - (code "{name: " (dump-string (symbol-name symbol)) "}"))) + (code "(new Symbol(" (dump-string (symbol-name symbol)) ", " + (dump-string (package-name package)) "))") + (code "(new Symbol(" (dump-string (symbol-name symbol)) "))"))) #+jscl (let ((package (symbol-package symbol))) (if (null package) - (code "{name: " (dump-symbol (symbol-name symbol)) "}") + (code "(new Symbol(" (dump-string (symbol-name symbol)) "))") (ls-compile `(intern ,(symbol-name symbol) ,(package-name package)))))) (defun dump-cons (cons) @@ -599,8 +553,11 @@ (or (cdr (assoc sexp *literal-table* :test #'equal)) (let ((dumped (typecase sexp (symbol (dump-symbol sexp)) - (cons (dump-cons sexp)) (string (dump-string sexp)) + (cons + (if (eq (car sexp) *magic-unquote-marker*) + (ls-compile (cdr sexp)) + (dump-cons sexp))) (array (dump-array sexp))))) (if (and recursive (not (symbolp sexp))) dumped @@ -609,6 +566,7 @@ (toplevel-compilation (code "var " jsvar " = " dumped)) jsvar))))))) + (define-compilation quote (sexp) (literal sexp)) @@ -981,24 +939,6 @@ "return args;" *newline*)) -;;; Javascript FFI - -(define-compilation %js-vref (var) var) - -(define-compilation %js-vset (var val) - (code "(" var " = " (ls-compile val) ")")) - -(define-setf-expander %js-vref (var) - (let ((new-value (gensym))) - (unless (stringp var) - (error "`~S' is not a string." var)) - (values nil - (list var) - (list new-value) - `(%js-vset ,var ,new-value) - `(%js-vref ,var)))) - - ;;; Backquote implementation. ;;; ;;; Author: Guy L. Steele Jr. Date: 27 December 1985 @@ -1419,13 +1359,10 @@ (code "(x.cdr = " new ", x)"))) (define-builtin symbolp (x) - (js!bool - (js!selfcall - "var tmp = " x ";" *newline* - "return (typeof tmp == 'object' && 'name' in tmp);" *newline*))) + (js!bool (code "(" x " instanceof Symbol)"))) (define-builtin make-symbol (name) - (code "({name: " name "})")) + (code "(new Symbol(" name "))")) (define-builtin symbol-name (x) (code "(" x ").name")) @@ -1443,14 +1380,14 @@ (js!selfcall "var symbol = " x ";" *newline* "var value = symbol.value;" *newline* - "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline* + "if (value === undefined) throw \"Variable `\" + xstring(symbol.name) + \"' is unbound.\";" *newline* "return value;" *newline*)) (define-builtin symbol-function (x) (js!selfcall "var symbol = " x ";" *newline* "var func = symbol.fvalue;" *newline* - "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline* + "if (func === undefined) throw \"Function `\" + xstring(symbol.name) + \"' is undefined.\";" *newline* "return func;" *newline*)) (define-builtin symbol-plist (x) @@ -1482,6 +1419,12 @@ "r.type = 'character';" "return r")) +(define-builtin char-upcase (x) + (code x ".toUpperCase()")) + +(define-builtin char-downcase (x) + (code x ".toLowerCase()")) + (define-builtin stringp (x) (js!bool (js!selfcall @@ -1546,7 +1489,7 @@ (js!selfcall "var v = globalEval(xstring(" string "));" *newline* "return values.apply(this, forcemv(v));" *newline*) - (code "globalEval(xstring(" string ")"))) + (code "globalEval(xstring(" string "))"))) (define-builtin %throw (string) (js!selfcall "throw " string ";" *newline*)) @@ -1565,13 +1508,13 @@ (code "((" object ")[xstring(" key ")] = " value ")")) (define-builtin in (key object) - (js!bool (code "(xstring(" key ") in (" object ")"))) + (js!bool (code "(xstring(" key ") in (" object "))"))) (define-builtin functionp (x) (js!bool (code "(typeof " x " == 'function')"))) (define-builtin write-string (x) - (code "lisp.write(xstring(" x "))")) + (code "lisp.write(" x ")")) (define-builtin make-array (n) (js!selfcall @@ -1612,51 +1555,66 @@ (code "values(" (join (mapcar #'ls-compile args) ", ") ")") (code "pv(" (join (mapcar #'ls-compile args) ", ") ")"))) -;; Receives the JS function as first argument as a literal string. The -;; second argument is compiled and should evaluate to a vector of -;; values to apply to the the function. The result returned. -(define-builtin %js-call (fun args) - (code fun ".apply(this, " args ")")) -(defun macro (x) - (and (symbolp x) - (let ((b (lookup-in-lexenv x *environment* 'function))) - (if (and b (eq (binding-type b) 'macro)) - b - nil)))) +;;; Javascript FFI + +(define-compilation %js-vref (var) + (code "js_to_lisp(" var ")")) + +(define-compilation %js-vset (var val) + (code "(" var " = lisp_to_js(" (ls-compile val) "))")) + +(define-setf-expander %js-vref (var) + (let ((new-value (gensym))) + (unless (stringp var) + (error "`~S' is not a string." var)) + (values nil + (list var) + (list new-value) + `(%js-vset ,var ,new-value) + `(%js-vref ,var)))) + #+common-lisp (defvar *macroexpander-cache* (make-hash-table :test #'eq)) -(defun ls-macroexpand-1 (form) +(defun !macro-function (symbol) + (unless (symbolp symbol) + (error "`~S' is not a symbol." symbol)) + (let ((b (lookup-in-lexenv symbol *environment* 'function))) + (if (and b (eq (binding-type b) 'macro)) + (let ((expander (binding-value b))) + (cond + #+common-lisp + ((gethash b *macroexpander-cache*) + (setq expander (gethash b *macroexpander-cache*))) + ((listp expander) + (let ((compiled (eval expander))) + ;; The list representation are useful while + ;; bootstrapping, as we can dump the definition of the + ;; macros easily, but they are slow because we have to + ;; evaluate them and compile them now and again. So, let + ;; us replace the list representation version of the + ;; function with the compiled one. + ;; + #+jscl (setf (binding-value b) compiled) + #+common-lisp (setf (gethash b *macroexpander-cache*) compiled) + (setq expander compiled)))) + expander) + nil))) + +(defun !macroexpand-1 (form) (cond ((symbolp form) (let ((b (lookup-in-lexenv form *environment* 'variable))) (if (and b (eq (binding-type b) 'macro)) (values (binding-value b) t) (values form nil)))) - ((consp form) - (let ((macro-binding (macro (car form)))) - (if macro-binding - (let ((expander (binding-value macro-binding))) - (cond - #+common-lisp - ((gethash macro-binding *macroexpander-cache*) - (setq expander (gethash macro-binding *macroexpander-cache*))) - ((listp expander) - (let ((compiled (eval expander))) - ;; The list representation are useful while - ;; bootstrapping, as we can dump the definition of the - ;; macros easily, but they are slow because we have to - ;; evaluate them and compile them now and again. So, let - ;; us replace the list representation version of the - ;; function with the compiled one. - ;; - #+jscl (setf (binding-value macro-binding) compiled) - #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled) - (setq expander compiled)))) - (values (apply expander (cdr form)) t)) + ((and (consp form) (symbolp (car form))) + (let ((macrofun (!macro-function (car form)))) + (if macrofun + (values (apply macrofun (cdr form)) t) (values form nil)))) (t (values form nil)))) @@ -1689,7 +1647,7 @@ (concat ";" *newline*)))) (defun ls-compile (sexp &optional multiple-value-p) - (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp) + (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp) (when expandedp (return-from ls-compile (ls-compile sexp multiple-value-p))) ;; The expression has been macroexpanded. Now compile it!