X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=3fe2823e8f67d853cc885b1cc6324c72a25b620c;hb=74568bb8cdadfcb6bf5429976b92f3afb748b0c2;hp=3dc2f1ca2ff155b96342f6a5e74154747e70e5e4;hpb=a5dfb70307cb6fd93263e155309038a2229ff6a1;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 3dc2f1c..3fe2823 100644 --- a/src/compiler.lisp +++ b/src/compiler.lisp @@ -1,4 +1,4 @@ -;;; compiler.lisp --- +;;; compiler.lisp --- ;; copyright (C) 2012, 2013 David Vazquez ;; Copyright (C) 2012 Raimon Grau @@ -68,7 +68,7 @@ (incf index)) output))) -#+common-lisp +#-jscl (defun indent (&rest string) (with-output-to-string (*standard-output*) (with-input-from-string (input (apply #'code string)) @@ -498,28 +498,36 @@ (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 +;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during +;;; the bootstrap. 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 +;;; itself, so we mark the list 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. +;;; +;;; Indeed, perhaps to compile the object other macros need to be +;;; evaluated. For this reason we define a valid macro-function for +;;; this symbol. (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE")) +#-jscl +(setf (macro-function *magic-unquote-marker*) + (lambda (form &optional environment) + (declare (ignore environment)) + (second form))) + +(defvar *literal-table* nil) +(defvar *literal-counter* 0) (defun genlit () (code "l" (incf *literal-counter*))) (defun dump-symbol (symbol) - #+common-lisp + #-jscl (let ((package (symbol-package symbol))) (if (eq package (find-package "KEYWORD")) - (code "(new Symbol(" (dump-string (symbol-name symbol)) ", " - (dump-string (package-name package)) "))") + (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))) @@ -550,13 +558,17 @@ ((floatp sexp) (float-to-string sexp)) ((characterp sexp) (code "\"" (escape-string (string sexp)) "\"")) (t - (or (cdr (assoc sexp *literal-table* :test #'equal)) + (or (cdr (assoc sexp *literal-table* :test #'eql)) (let ((dumped (typecase sexp (symbol (dump-symbol sexp)) (string (dump-string sexp)) (cons + ;; BOOTSTRAP MAGIC: See the root file + ;; jscl.lisp and the function + ;; `dump-global-environment' for futher + ;; information. (if (eq (car sexp) *magic-unquote-marker*) - (ls-compile (cdr sexp)) + (ls-compile (second sexp)) (dump-cons sexp))) (array (dump-array sexp))))) (if (and recursive (not (symbolp sexp))) @@ -564,6 +576,8 @@ (let ((jsvar (genlit))) (push (cons sexp jsvar) *literal-table*) (toplevel-compilation (code "var " jsvar " = " dumped)) + (when (keywordp sexp) + (toplevel-compilation (code jsvar ".value = " jsvar))) jsvar))))))) @@ -1376,6 +1390,9 @@ (define-builtin boundp (x) (js!bool (code "(" x ".value !== undefined)"))) +(define-builtin fboundp (x) + (js!bool (code "(" x ".fvalue !== undefined)"))) + (define-builtin symbol-value (x) (js!selfcall "var symbol = " x ";" *newline* @@ -1523,6 +1540,14 @@ (indent "r.push(" (ls-compile nil) ");" *newline*) "return r;" *newline*)) +;;; FIXME: should take optional min-extension. +;;; FIXME: should use fill-pointer instead of the absolute end of array +(define-builtin vector-push-extend (new vector) + (js!selfcall + "var v = " vector ";" *newline* + "v.push(" new ");" *newline* + "return v;")) + (define-builtin arrayp (x) (js!bool (js!selfcall @@ -1542,6 +1567,18 @@ "if (i < 0 || i >= x.length) throw 'Out of range';" *newline* "return x[i] = " value ";" *newline*)) +(define-builtin afind (value array) + (js!selfcall + "var v = " value ";" *newline* + "var x = " array ";" *newline* + "return x.indexOf(v);" *newline*)) + +(define-builtin aresize (array new-size) + (js!selfcall + "var x = " array ";" *newline* + "var n = " new-size ";" *newline* + "return x.length = n;" *newline*)) + (define-builtin get-internal-real-time () "(new Date()).getTime()") @@ -1575,7 +1612,7 @@ `(%js-vref ,var)))) -#+common-lisp +#-jscl (defvar *macroexpander-cache* (make-hash-table :test #'eq)) @@ -1586,7 +1623,7 @@ (if (and b (eq (binding-type b) 'macro)) (let ((expander (binding-value b))) (cond - #+common-lisp + #-jscl ((gethash b *macroexpander-cache*) (setq expander (gethash b *macroexpander-cache*))) ((listp expander) @@ -1599,7 +1636,7 @@ ;; function with the compiled one. ;; #+jscl (setf (binding-value b) compiled) - #+common-lisp (setf (gethash b *macroexpander-cache*) compiled) + #-jscl (setf (gethash b *macroexpander-cache*) compiled) (setq expander compiled)))) expander) nil))) @@ -1614,7 +1651,7 @@ ((and (consp form) (symbolp (car form))) (let ((macrofun (!macro-function (car form)))) (if macrofun - (values (apply macrofun (cdr form)) t) + (values (funcall macrofun (cdr form)) t) (values form nil)))) (t (values form nil)))) @@ -1633,7 +1670,7 @@ (concat (translate-function function) arglist)) ((and (symbolp function) #+jscl (eq (symbol-package function) (find-package "COMMON-LISP")) - #+common-lisp t) + #-jscl t) (code (ls-compile `',function) ".fvalue" arglist)) (t (code (ls-compile `#',function) arglist)))))