X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler.lisp;h=763aa920c9e6698e5a380f1b3baba3b1bdb89c5b;hb=680ad4ea5b76a90c2f186ce28320601474a96163;hp=49a83893b3d14e887229857abce30381d42ce214;hpb=544b3f8d64d5c0da5f50cd2a15c22dc73c792acf;p=jscl.git diff --git a/src/compiler.lisp b/src/compiler.lisp index 49a8389..763aa92 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)) @@ -511,7 +511,7 @@ ;;; evaluated. For this reason we define a valid macro-function for ;;; this symbol. (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE")) -#+common-lisp +#-jscl (setf (macro-function *magic-unquote-marker*) (lambda (form &optional environment) (declare (ignore environment)) @@ -524,11 +524,10 @@ (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))) @@ -559,7 +558,7 @@ ((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)) @@ -577,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))))))) @@ -718,7 +719,7 @@ variables) ",") "){" *newline* - (let ((body (ls-compile-block body t))) + (let ((body (ls-compile-block body t t))) (indent (let-binding-wrapper dynamic-bindings body))) "})(" (join cvalues ",") ")"))) @@ -766,7 +767,7 @@ (js!selfcall (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings))) (body (concat (mapconcat #'let*-initialize-value bindings) - (ls-compile-block body t)))) + (ls-compile-block body t t)))) (let*-binding-wrapper specials body))))) @@ -1323,6 +1324,7 @@ (define-builtin-comparison >= ">=") (define-builtin-comparison <= "<=") (define-builtin-comparison = "==") +(define-builtin-comparison /= "!=") (define-builtin numberp (x) (js!bool (code "(typeof (" x ") == \"number\")"))) @@ -1389,6 +1391,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 +1528,16 @@ (define-builtin in (key object) (js!bool (code "(xstring(" key ") in (" object "))"))) +(define-builtin map-for-in (function object) + (js!selfcall + "var f = " function ";" *newline* + "var g = (typeof f === 'function' ? f : f.fvalue);" *newline* + "var o = " object ";" *newline* + "for (var key in o){" *newline* + (indent "g(" (if *multiple-value-p* "values" "pv") ", 1, o[key]);" *newline*) + "}" + " return " (ls-compile nil) ";" *newline*)) + (define-builtin functionp (x) (js!bool (code "(typeof " x " == 'function')"))) @@ -1536,6 +1551,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 @@ -1600,7 +1623,7 @@ `(%js-vref ,var)))) -#+common-lisp +#-jscl (defvar *macroexpander-cache* (make-hash-table :test #'eq)) @@ -1611,7 +1634,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) @@ -1624,7 +1647,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))) @@ -1658,18 +1681,21 @@ (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))))) -(defun ls-compile-block (sexps &optional return-last-p) - (if return-last-p - (code (ls-compile-block (butlast sexps)) - "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";") - (join-trailing - (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps)) - (concat ";" *newline*)))) +(defun ls-compile-block (sexps &optional return-last-p decls-allowed-p) + (multiple-value-bind (sexps decls) + (parse-body sexps :declarations decls-allowed-p) + (declare (ignore decls)) + (if return-last-p + (code (ls-compile-block (butlast sexps) nil decls-allowed-p) + "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";") + (join-trailing + (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps)) + (concat ";" *newline*))))) (defun ls-compile (sexp &optional multiple-value-p) (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)