3 ;; copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
6 ;; This program is free software: you can redistribute it and/or
7 ;; modify it under the terms of the GNU General Public License as
8 ;; published by the Free Software Foundation, either version 3 of the
9 ;; License, or (at your option) any later version.
11 ;; This program is distributed in the hope that it will be useful, but
12 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;; General Public License for more details.
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
21 ;;; Translate the Lisp code to Javascript. It will compile the special
22 ;;; forms. Some primitive functions are compiled as special forms
23 ;;; too. The respective real functions are defined in the target (see
24 ;;; the beginning of this file) as well as some primitive functions.
26 (defun code (&rest args)
27 (mapconcat (lambda (arg)
30 ((integerp arg) (integer-to-string arg))
31 ((floatp arg) (float-to-string arg))
33 (t (error "Unknown argument."))))
36 ;;; Wrap X with a Javascript code to convert the result from
37 ;;; Javascript generalized booleans to T or NIL.
39 (code "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
41 ;;; Concatenate the arguments and wrap them with a self-calling
42 ;;; Javascript anonymous function. It is used to make some Javascript
43 ;;; statements valid expressions and provide a private scope as well.
44 ;;; It could be defined as function, but we could do some
45 ;;; preprocessing in the future.
46 (defmacro js!selfcall (&body body)
47 `(code "(function(){" *newline* (indent ,@body) "})()"))
49 ;;; Like CODE, but prefix each line with four spaces. Two versions
50 ;;; of this function are available, because the Ecmalisp version is
51 ;;; very slow and bootstraping was annoying.
54 (defun indent (&rest string)
55 (let ((input (apply #'code string)))
58 (size (length input)))
59 (when (plusp (length input)) (concatf output " "))
62 (if (and (char= (char input index) #\newline)
64 (not (char= (char input (1+ index)) #\newline)))
65 (concat (string #\newline) " ")
66 (string (char input index)))))
72 (defun indent (&rest string)
73 (with-output-to-string (*standard-output*)
74 (with-input-from-string (input (apply #'code string))
76 for line = (read-line input nil)
79 do (write-line line)))))
82 ;;; A Form can return a multiple values object calling VALUES, like
83 ;;; values(arg1, arg2, ...). It will work in any context, as well as
84 ;;; returning an individual object. However, if the special variable
85 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
86 ;;; value will be used, so we can optimize to avoid the VALUES
88 (defvar *multiple-value-p* nil)
90 ;; A very simple defstruct built on lists. It supports just slot with
91 ;; an optional default initform, and it will create a constructor,
92 ;; predicate and accessors for you.
93 (defmacro def!struct (name &rest slots)
94 (unless (symbolp name)
95 (error "It is not a full defstruct implementation."))
96 (let* ((name-string (symbol-name name))
102 ((and (listp sd) (car sd) (cddr sd))
105 (error "Bad slot accessor."))))
107 (predicate (intern (concat name-string "-P"))))
110 (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
111 (list ',name ,@(mapcar #'car slot-descriptions)))
113 (defun ,predicate (x)
114 (and (consp x) (eq (car x) ',name)))
116 (defun ,(intern (concat "COPY-" name-string)) (x)
121 (dolist (slot slot-descriptions)
122 (let* ((name (car slot))
123 (accessor-name (intern (concat name-string "-" (string name)))))
125 `(defun ,accessor-name (x)
126 (unless (,predicate x)
127 (error ,(concat "The object is not a type " name-string)))
129 ;; TODO: Implement this with a higher level
130 ;; abstraction like defsetf or (defun (setf ..))
132 `(define-setf-expander ,accessor-name (x)
133 (let ((object (gensym))
134 (new-value (gensym)))
135 (values (list object)
139 (rplaca (nthcdr ,',index ,object) ,new-value)
141 `(,',accessor-name ,object)))))
160 (defun lookup-in-lexenv (name lexenv namespace)
161 (find name (ecase namespace
162 (variable (lexenv-variable lexenv))
163 (function (lexenv-function lexenv))
164 (block (lexenv-block lexenv))
165 (gotag (lexenv-gotag lexenv)))
166 :key #'binding-name))
168 (defun push-to-lexenv (binding lexenv namespace)
170 (variable (push binding (lexenv-variable lexenv)))
171 (function (push binding (lexenv-function lexenv)))
172 (block (push binding (lexenv-block lexenv)))
173 (gotag (push binding (lexenv-gotag lexenv)))))
175 (defun extend-lexenv (bindings lexenv namespace)
176 (let ((env (copy-lexenv lexenv)))
177 (dolist (binding (reverse bindings) env)
178 (push-to-lexenv binding env namespace))))
181 (defvar *environment* (make-lexenv))
183 (defvar *variable-counter* 0)
185 (defun gvarname (symbol)
186 (code "v" (incf *variable-counter*)))
188 (defun translate-variable (symbol)
189 (awhen (lookup-in-lexenv symbol *environment* 'variable)
192 (defun extend-local-env (args)
193 (let ((new (copy-lexenv *environment*)))
194 (dolist (symbol args new)
195 (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
196 (push-to-lexenv b new 'variable)))))
198 ;;; Toplevel compilations
199 (defvar *toplevel-compilations* nil)
201 (defun toplevel-compilation (string)
202 (push string *toplevel-compilations*))
204 (defun null-or-empty-p (x)
207 (defun get-toplevel-compilations ()
208 (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
210 (defun %compile-defmacro (name lambda)
211 (toplevel-compilation (ls-compile `',name))
212 (let ((binding (make-binding :name name :type 'macro :value lambda)))
213 (push-to-lexenv binding *environment* 'function))
216 (defun global-binding (name type namespace)
217 (or (lookup-in-lexenv name *environment* namespace)
218 (let ((b (make-binding :name name :type type :value nil)))
219 (push-to-lexenv b *environment* namespace)
222 (defun claimp (symbol namespace claim)
223 (let ((b (lookup-in-lexenv symbol *environment* namespace)))
224 (and b (member claim (binding-declarations b)))))
226 (defun !proclaim (decl)
229 (dolist (name (cdr decl))
230 (let ((b (global-binding name 'variable 'variable)))
231 (push 'special (binding-declarations b)))))
233 (dolist (name (cdr decl))
234 (let ((b (global-binding name 'function 'function)))
235 (push 'notinline (binding-declarations b)))))
237 (dolist (name (cdr decl))
238 (let ((b (global-binding name 'variable 'variable)))
239 (push 'constant (binding-declarations b)))))))
242 (fset 'proclaim #'!proclaim)
244 (defun %define-symbol-macro (name expansion)
245 (let ((b (make-binding :name name :type 'macro :value expansion)))
246 (push-to-lexenv b *environment* 'variable)
250 (defmacro define-symbol-macro (name expansion)
251 `(%define-symbol-macro ',name ',expansion))
256 (defvar *compilations* nil)
258 (defmacro define-compilation (name args &body body)
259 ;; Creates a new primitive `name' with parameters args and
260 ;; @body. The body can access to the local environment through the
261 ;; variable *ENVIRONMENT*.
262 `(push (list ',name (lambda ,args (block ,name ,@body)))
265 (define-compilation if (condition true false)
266 (code "(" (ls-compile condition) " !== " (ls-compile nil)
267 " ? " (ls-compile true *multiple-value-p*)
268 " : " (ls-compile false *multiple-value-p*)
271 (defvar *ll-keywords* '(&optional &rest &key))
273 (defun list-until-keyword (list)
274 (if (or (null list) (member (car list) *ll-keywords*))
276 (cons (car list) (list-until-keyword (cdr list)))))
278 (defun ll-section (keyword ll)
279 (list-until-keyword (cdr (member keyword ll))))
281 (defun ll-required-arguments (ll)
282 (list-until-keyword ll))
284 (defun ll-optional-arguments-canonical (ll)
285 (mapcar #'ensure-list (ll-section '&optional ll)))
287 (defun ll-optional-arguments (ll)
288 (mapcar #'car (ll-optional-arguments-canonical ll)))
290 (defun ll-rest-argument (ll)
291 (let ((rest (ll-section '&rest ll)))
293 (error "Bad lambda-list"))
296 (defun ll-keyword-arguments-canonical (ll)
297 (flet ((canonicalize (keyarg)
298 ;; Build a canonical keyword argument descriptor, filling
299 ;; the optional fields. The result is a list of the form
300 ;; ((keyword-name var) init-form).
301 (let ((arg (ensure-list keyarg)))
302 (cons (if (listp (car arg))
304 (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
306 (mapcar #'canonicalize (ll-section '&key ll))))
308 (defun ll-keyword-arguments (ll)
309 (mapcar (lambda (keyarg) (second (first keyarg)))
310 (ll-keyword-arguments-canonical ll)))
312 (defun ll-svars (lambda-list)
315 (ll-keyword-arguments-canonical lambda-list)
316 (ll-optional-arguments-canonical lambda-list))))
317 (remove nil (mapcar #'third args))))
319 (defun lambda-name/docstring-wrapper (name docstring &rest strs)
320 (if (or name docstring)
322 "var func = " (join strs) ";" *newline*
324 (code "func.fname = '" (escape-string name) "';" *newline*))
326 (code "func.docstring = '" (escape-string docstring) "';" *newline*))
327 "return func;" *newline*)
328 (apply #'code strs)))
330 (defun lambda-check-argument-count
331 (n-required-arguments n-optional-arguments rest-p)
332 ;; Note: Remember that we assume that the number of arguments of a
333 ;; call is at least 1 (the values argument).
334 (let ((min (1+ n-required-arguments))
335 (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
337 ;; Special case: a positive exact number of arguments.
338 (when (and (< 1 min) (eql min max))
339 (return (code "checkArgs(arguments, " min ");" *newline*)))
343 (code "checkArgsAtLeast(arguments, " min ");" *newline*))
345 (code "checkArgsAtMost(arguments, " max ");" *newline*))))))
347 (defun compile-lambda-optional (ll)
348 (let* ((optional-arguments (ll-optional-arguments-canonical ll))
349 (n-required-arguments (length (ll-required-arguments ll)))
350 (n-optional-arguments (length optional-arguments)))
351 (when optional-arguments
352 (code (mapconcat (lambda (arg)
353 (code "var " (translate-variable (first arg)) "; " *newline*
355 (code "var " (translate-variable (third arg))
359 "switch(arguments.length-1){" *newline*
363 (while (< idx n-optional-arguments)
364 (let ((arg (nth idx optional-arguments)))
365 (push (code "case " (+ idx n-required-arguments) ":" *newline*
366 (indent (translate-variable (car arg))
368 (ls-compile (cadr arg)) ";" *newline*)
370 (indent (translate-variable (third arg))
376 (push (code "default: break;" *newline*) cases)
377 (join (reverse cases))))
380 (defun compile-lambda-rest (ll)
381 (let ((n-required-arguments (length (ll-required-arguments ll)))
382 (n-optional-arguments (length (ll-optional-arguments ll)))
383 (rest-argument (ll-rest-argument ll)))
385 (let ((js!rest (translate-variable rest-argument)))
386 (code "var " js!rest "= " (ls-compile nil) ";" *newline*
387 "for (var i = arguments.length-1; i>="
388 (+ 1 n-required-arguments n-optional-arguments)
390 (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};"
393 (defun compile-lambda-parse-keywords (ll)
394 (let ((n-required-arguments
395 (length (ll-required-arguments ll)))
396 (n-optional-arguments
397 (length (ll-optional-arguments ll)))
399 (ll-keyword-arguments-canonical ll)))
402 (mapconcat (lambda (arg)
403 (let ((var (second (car arg))))
404 (code "var " (translate-variable var) "; " *newline*
406 (code "var " (translate-variable (third arg))
407 " = " (ls-compile nil)
411 (flet ((parse-keyword (keyarg)
412 ;; ((keyword-name var) init-form)
413 (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
414 "; i<arguments.length; i+=2){" *newline*
416 "if (arguments[i] === " (ls-compile (caar keyarg)) "){" *newline*
417 (indent (translate-variable (cadr (car keyarg)))
420 (let ((svar (third keyarg)))
422 (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
427 "if (i == arguments.length){" *newline*
428 (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
430 (when keyword-arguments
431 (code "var i;" *newline*
432 (mapconcat #'parse-keyword keyword-arguments))))
433 ;; Check for unknown keywords
434 (when keyword-arguments
435 (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
436 "; i<arguments.length; i+=2){" *newline*
438 (join (mapcar (lambda (x)
439 (concat "arguments[i] !== " (ls-compile (caar x))))
444 "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
447 ;;; Compile a lambda function with lambda list LL and body BODY. If
448 ;;; NAME is given, it should be a constant string and it will become
449 ;;; the name of the function. If BLOCK is non-NIL, a named block is
450 ;;; created around the body. NOTE: No block (even anonymous) is
451 ;;; created if BLOCk is NIL.
452 (defun compile-lambda (ll body &key name block)
453 (let ((required-arguments (ll-required-arguments ll))
454 (optional-arguments (ll-optional-arguments ll))
455 (keyword-arguments (ll-keyword-arguments ll))
456 (rest-argument (ll-rest-argument ll))
458 ;; Get the documentation string for the lambda function
459 (when (and (stringp (car body))
460 (not (null (cdr body))))
461 (setq documentation (car body))
462 (setq body (cdr body)))
463 (let ((n-required-arguments (length required-arguments))
464 (n-optional-arguments (length optional-arguments))
465 (*environment* (extend-local-env
466 (append (ensure-list rest-argument)
471 (lambda-name/docstring-wrapper name documentation
474 (mapcar #'translate-variable
475 (append required-arguments optional-arguments)))
479 ;; Check number of arguments
480 (lambda-check-argument-count n-required-arguments
482 (or rest-argument keyword-arguments))
483 (compile-lambda-optional ll)
484 (compile-lambda-rest ll)
485 (compile-lambda-parse-keywords ll)
486 (let ((*multiple-value-p* t))
488 (ls-compile-block `((block ,block ,@body)) t)
489 (ls-compile-block body t))))
493 (defun setq-pair (var val)
494 (let ((b (lookup-in-lexenv var *environment* 'variable)))
497 (eq (binding-type b) 'variable)
498 (not (member 'special (binding-declarations b)))
499 (not (member 'constant (binding-declarations b))))
500 (code (binding-value b) " = " (ls-compile val)))
501 ((and b (eq (binding-type b) 'macro))
502 (ls-compile `(setf ,var ,val)))
504 (ls-compile `(set ',var ,val))))))
507 (define-compilation setq (&rest pairs)
511 ((null pairs) (return))
513 (error "Odd paris in SETQ"))
516 (concat (setq-pair (car pairs) (cadr pairs))
517 (if (null (cddr pairs)) "" ", ")))
518 (setq pairs (cddr pairs)))))
519 (code "(" result ")")))
523 (defun escape-string (string)
526 (size (length string)))
527 (while (< index size)
528 (let ((ch (char string index)))
529 (when (or (char= ch #\") (char= ch #\\))
530 (setq output (concat output "\\")))
531 (when (or (char= ch #\newline))
532 (setq output (concat output "\\"))
534 (setq output (concat output (string ch))))
539 (defvar *literal-table* nil)
540 (defvar *literal-counter* 0)
543 (code "l" (incf *literal-counter*)))
545 (defun dump-symbol (symbol)
547 (let ((package (symbol-package symbol)))
548 (if (eq package (find-package "KEYWORD"))
549 (code "{name: \"" (escape-string (symbol-name symbol))
550 "\", 'package': '" (package-name package) "'}")
551 (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")))
553 (let ((package (symbol-package symbol)))
555 (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")
556 (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
558 (defun dump-cons (cons)
559 (let ((head (butlast cons))
562 (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
563 (literal (car tail) t)
565 (literal (cdr tail) t)
568 (defun dump-array (array)
569 (let ((elements (vector-to-list array)))
570 (concat "[" (join (mapcar #'literal elements) ", ") "]")))
572 (defun literal (sexp &optional recursive)
574 ((integerp sexp) (integer-to-string sexp))
575 ((floatp sexp) (float-to-string sexp))
576 ((stringp sexp) (code "\"" (escape-string sexp) "\""))
578 (or (cdr (assoc sexp *literal-table*))
579 (let ((dumped (typecase sexp
580 (symbol (dump-symbol sexp))
581 (cons (dump-cons sexp))
582 (array (dump-array sexp)))))
583 (if (and recursive (not (symbolp sexp)))
585 (let ((jsvar (genlit)))
586 (push (cons sexp jsvar) *literal-table*)
587 (toplevel-compilation (code "var " jsvar " = " dumped))
590 (define-compilation quote (sexp)
593 (define-compilation %while (pred &rest body)
595 "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
596 (indent (ls-compile-block body))
598 "return " (ls-compile nil) ";" *newline*))
600 (define-compilation function (x)
602 ((and (listp x) (eq (car x) 'lambda))
603 (compile-lambda (cadr x) (cddr x)))
604 ((and (listp x) (eq (car x) 'named-lambda))
605 ;; TODO: destructuring-bind now! Do error checking manually is
607 (let ((name (cadr x))
610 (compile-lambda ll body
611 :name (symbol-name name)
614 (let ((b (lookup-in-lexenv x *environment* 'function)))
617 (ls-compile `(symbol-function ',x)))))))
620 (defun make-function-binding (fname)
621 (make-binding :name fname :type 'function :value (gvarname fname)))
623 (defun compile-function-definition (list)
624 (compile-lambda (car list) (cdr list)))
626 (defun translate-function (name)
627 (let ((b (lookup-in-lexenv name *environment* 'function)))
628 (and b (binding-value b))))
630 (define-compilation flet (definitions &rest body)
631 (let* ((fnames (mapcar #'car definitions))
632 (fbody (mapcar #'cdr definitions))
633 (cfuncs (mapcar #'compile-function-definition fbody))
635 (extend-lexenv (mapcar #'make-function-binding fnames)
639 (join (mapcar #'translate-function fnames) ",")
641 (let ((body (ls-compile-block body t)))
643 "})(" (join cfuncs ",") ")")))
645 (define-compilation labels (definitions &rest body)
646 (let* ((fnames (mapcar #'car definitions))
648 (extend-lexenv (mapcar #'make-function-binding fnames)
652 (mapconcat (lambda (func)
653 (code "var " (translate-function (car func))
654 " = " (compile-lambda (cadr func) (cddr func))
657 (ls-compile-block body t))))
660 (defvar *compiling-file* nil)
661 (define-compilation eval-when-compile (&rest body)
664 (eval (cons 'progn body))
666 (ls-compile `(progn ,@body))))
668 (defmacro define-transformation (name args form)
669 `(define-compilation ,name ,args
672 (define-compilation progn (&rest body)
673 (if (null (cdr body))
674 (ls-compile (car body) *multiple-value-p*)
675 (js!selfcall (ls-compile-block body t))))
677 (defun special-variable-p (x)
678 (and (claimp x 'variable 'special) t))
680 ;;; Wrap CODE to restore the symbol values of the dynamic
681 ;;; bindings. BINDINGS is a list of pairs of the form
682 ;;; (SYMBOL . PLACE), where PLACE is a Javascript variable
683 ;;; name to initialize the symbol value and where to stored
685 (defun let-binding-wrapper (bindings body)
686 (when (null bindings)
687 (return-from let-binding-wrapper body))
690 (indent "var tmp;" *newline*
693 (let ((s (ls-compile `(quote ,(car b)))))
694 (code "tmp = " s ".value;" *newline*
695 s ".value = " (cdr b) ";" *newline*
696 (cdr b) " = tmp;" *newline*)))
700 "finally {" *newline*
702 (mapconcat (lambda (b)
703 (let ((s (ls-compile `(quote ,(car b)))))
704 (code s ".value" " = " (cdr b) ";" *newline*)))
708 (define-compilation let (bindings &rest body)
709 (let* ((bindings (mapcar #'ensure-list bindings))
710 (variables (mapcar #'first bindings))
711 (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
712 (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
715 (join (mapcar (lambda (x)
716 (if (special-variable-p x)
717 (let ((v (gvarname x)))
718 (push (cons x v) dynamic-bindings)
720 (translate-variable x)))
724 (let ((body (ls-compile-block body t)))
725 (indent (let-binding-wrapper dynamic-bindings body)))
726 "})(" (join cvalues ",") ")")))
729 ;;; Return the code to initialize BINDING, and push it extending the
730 ;;; current lexical environment if the variable is not special.
731 (defun let*-initialize-value (binding)
732 (let ((var (first binding))
733 (value (second binding)))
734 (if (special-variable-p var)
735 (code (ls-compile `(setq ,var ,value)) ";" *newline*)
736 (let* ((v (gvarname var))
737 (b (make-binding :name var :type 'variable :value v)))
738 (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
739 (push-to-lexenv b *environment* 'variable))))))
741 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
742 ;;; DOES NOT generate code to initialize the value of the symbols,
743 ;;; unlike let-binding-wrapper.
744 (defun let*-binding-wrapper (symbols body)
746 (return-from let*-binding-wrapper body))
747 (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
748 (remove-if-not #'special-variable-p symbols))))
752 (mapconcat (lambda (b)
753 (let ((s (ls-compile `(quote ,(car b)))))
754 (code "var " (cdr b) " = " s ".value;" *newline*)))
758 "finally {" *newline*
760 (mapconcat (lambda (b)
761 (let ((s (ls-compile `(quote ,(car b)))))
762 (code s ".value" " = " (cdr b) ";" *newline*)))
766 (define-compilation let* (bindings &rest body)
767 (let ((bindings (mapcar #'ensure-list bindings))
768 (*environment* (copy-lexenv *environment*)))
770 (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
771 (body (concat (mapconcat #'let*-initialize-value bindings)
772 (ls-compile-block body t))))
773 (let*-binding-wrapper specials body)))))
776 (defvar *block-counter* 0)
778 (define-compilation block (name &rest body)
779 (let* ((tr (incf *block-counter*))
780 (b (make-binding :name name :type 'block :value tr)))
781 (when *multiple-value-p*
782 (push 'multiple-value (binding-declarations b)))
783 (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
784 (cbody (ls-compile-block body t)))
785 (if (member 'used (binding-declarations b))
790 "catch (cf){" *newline*
791 " if (cf.type == 'block' && cf.id == " tr ")" *newline*
792 (if *multiple-value-p*
793 " return values.apply(this, forcemv(cf.values));"
794 " return cf.values;")
797 " throw cf;" *newline*
799 (js!selfcall cbody)))))
801 (define-compilation return-from (name &optional value)
802 (let* ((b (lookup-in-lexenv name *environment* 'block))
803 (multiple-value-p (member 'multiple-value (binding-declarations b))))
805 (error (concat "Unknown block `" (symbol-name name) "'.")))
806 (push 'used (binding-declarations b))
808 (when multiple-value-p (code "var values = mv;" *newline*))
811 "id: " (binding-value b) ", "
812 "values: " (ls-compile value multiple-value-p) ", "
813 "message: 'Return from unknown block " (symbol-name name) ".'"
816 (define-compilation catch (id &rest body)
818 "var id = " (ls-compile id) ";" *newline*
820 (indent (ls-compile-block body t)) *newline*
822 "catch (cf){" *newline*
823 " if (cf.type == 'catch' && cf.id == id)" *newline*
824 (if *multiple-value-p*
825 " return values.apply(this, forcemv(cf.values));"
826 " return pv.apply(this, forcemv(cf.values));")
829 " throw cf;" *newline*
832 (define-compilation throw (id value)
834 "var values = mv;" *newline*
837 "id: " (ls-compile id) ", "
838 "values: " (ls-compile value t) ", "
839 "message: 'Throw uncatched.'"
843 (defvar *tagbody-counter* 0)
844 (defvar *go-tag-counter* 0)
847 (or (integerp x) (symbolp x)))
849 (defun declare-tagbody-tags (tbidx body)
851 (mapcar (lambda (label)
852 (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
853 (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
854 (remove-if-not #'go-tag-p body))))
855 (extend-lexenv bindings *environment* 'gotag)))
857 (define-compilation tagbody (&rest body)
858 ;; Ignore the tagbody if it does not contain any go-tag. We do this
859 ;; because 1) it is easy and 2) many built-in forms expand to a
860 ;; implicit tagbody, so we save some space.
861 (unless (some #'go-tag-p body)
862 (return-from tagbody (ls-compile `(progn ,@body nil))))
863 ;; The translation assumes the first form in BODY is a label
864 (unless (go-tag-p (car body))
865 (push (gensym "START") body))
866 ;; Tagbody compilation
867 (let ((tbidx *tagbody-counter*))
868 (let ((*environment* (declare-tagbody-tags tbidx body))
870 (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
871 (setq initag (second (binding-value b))))
873 "var tagbody_" tbidx " = " initag ";" *newline*
875 "while (true) {" *newline*
876 (indent "try {" *newline*
877 (indent (let ((content ""))
878 (code "switch(tagbody_" tbidx "){" *newline*
879 "case " initag ":" *newline*
880 (dolist (form (cdr body) content)
882 (if (not (go-tag-p form))
883 (indent (ls-compile form) ";" *newline*)
884 (let ((b (lookup-in-lexenv form *environment* 'gotag)))
885 (code "case " (second (binding-value b)) ":" *newline*)))))
887 " break tbloop;" *newline*
890 "catch (jump) {" *newline*
891 " if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
892 " tagbody_" tbidx " = jump.label;" *newline*
894 " throw(jump);" *newline*
897 "return " (ls-compile nil) ";" *newline*))))
899 (define-compilation go (label)
900 (let ((b (lookup-in-lexenv label *environment* 'gotag))
902 ((symbolp label) (symbol-name label))
903 ((integerp label) (integer-to-string label)))))
905 (error (concat "Unknown tag `" n "'.")))
909 "id: " (first (binding-value b)) ", "
910 "label: " (second (binding-value b)) ", "
911 "message: 'Attempt to GO to non-existing tag " n "'"
914 (define-compilation unwind-protect (form &rest clean-up)
916 "var ret = " (ls-compile nil) ";" *newline*
918 (indent "ret = " (ls-compile form) ";" *newline*)
919 "} finally {" *newline*
920 (indent (ls-compile-block clean-up))
922 "return ret;" *newline*))
924 (define-compilation multiple-value-call (func-form &rest forms)
926 "var func = " (ls-compile func-form) ";" *newline*
927 "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
930 "var values = mv;" *newline*
932 (mapconcat (lambda (form)
933 (code "vs = " (ls-compile form t) ";" *newline*
934 "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
935 (indent "args = args.concat(vs);" *newline*)
937 (indent "args.push(vs);" *newline*)))
939 "return func.apply(window, args);" *newline*) ";" *newline*))
941 (define-compilation multiple-value-prog1 (first-form &rest forms)
943 "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
944 (ls-compile-block forms)
945 "return args;" *newline*))
950 (define-compilation %js-vref (var) var)
952 (define-compilation %js-vset (var val)
953 (code "(" var " = " (ls-compile val) ")"))
955 (define-setf-expander %js-vref (var)
956 (let ((new-value (gensym)))
957 (unless (stringp var)
958 (error "a string was expected"))
962 `(%js-vset ,var ,new-value)
966 ;;; Backquote implementation.
968 ;;; Author: Guy L. Steele Jr. Date: 27 December 1985
969 ;;; Tested under Symbolics Common Lisp and Lucid Common Lisp.
970 ;;; This software is in the public domain.
972 ;;; The following are unique tokens used during processing.
973 ;;; They need not be symbols; they need not even be atoms.
974 (defvar *comma* 'unquote)
975 (defvar *comma-atsign* 'unquote-splicing)
977 (defvar *bq-list* (make-symbol "BQ-LIST"))
978 (defvar *bq-append* (make-symbol "BQ-APPEND"))
979 (defvar *bq-list** (make-symbol "BQ-LIST*"))
980 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
981 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
982 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
983 (defvar *bq-quote-nil* (list *bq-quote* nil))
985 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
986 ;;; the expression foo, looking for occurrences of #:COMMA,
987 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code in strict
988 ;;; accordance with the rules on pages 349-350 of the first edition
989 ;;; (pages 528-529 of this second edition). It then optionally
990 ;;; applies a code simplifier.
992 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
993 ;;; processing applies the code simplifier. If the value is NIL,
994 ;;; then the code resulting from BACKQUOTE is exactly that
995 ;;; specified by the official rules.
996 (defparameter *bq-simplify* t)
998 (defmacro backquote (x)
999 (bq-completely-process x))
1001 ;;; Backquote processing proceeds in three stages:
1003 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
1004 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
1005 ;;; this level of BACKQUOTE. (It also causes embedded calls to
1006 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
1007 ;;; Code is produced that is expressed in terms of functions
1008 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done
1009 ;;; so that the simplifier will simplify only list construction
1010 ;;; functions actually generated by BACKQUOTE and will not involve
1011 ;;; any user code in the simplification. #:BQ-LIST means LIST,
1012 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
1013 ;;; but indicates places where "%." was used and where NCONC may
1014 ;;; therefore be introduced by the simplifier for efficiency.
1016 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
1017 ;;; BQ-PROCESS to produce equivalent but faster code. The
1018 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
1019 ;;; introduced into the code.
1021 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
1022 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
1023 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
1024 ;;; replaced by its argument). #:BQ-LIST* is replaced by either
1025 ;;; LIST* or CONS (the latter is used in the two-argument case,
1026 ;;; purely to make the resulting code a tad more readable).
1028 (defun bq-completely-process (x)
1029 (let ((raw-result (bq-process x)))
1030 (bq-remove-tokens (if *bq-simplify*
1031 (bq-simplify raw-result)
1034 (defun bq-process (x)
1036 (list *bq-quote* x))
1037 ((eq (car x) 'backquote)
1038 (bq-process (bq-completely-process (cadr x))))
1039 ((eq (car x) *comma*) (cadr x))
1040 ((eq (car x) *comma-atsign*)
1041 ;; (error ",@~S after `" (cadr x))
1042 (error "ill-formed"))
1043 ;; ((eq (car x) *comma-dot*)
1044 ;; ;; (error ",.~S after `" (cadr x))
1045 ;; (error "ill-formed"))
1046 (t (do ((p x (cdr p))
1047 (q '() (cons (bracket (car p)) q)))
1050 (nreconc q (list (list *bq-quote* p)))))
1051 (when (eq (car p) *comma*)
1052 (unless (null (cddr p))
1053 ;; (error "Malformed ,~S" p)
1054 (error "Malformed"))
1055 (return (cons *bq-append*
1056 (nreconc q (list (cadr p))))))
1057 (when (eq (car p) *comma-atsign*)
1058 ;; (error "Dotted ,@~S" p)
1060 ;; (when (eq (car p) *comma-dot*)
1061 ;; ;; (error "Dotted ,.~S" p)
1062 ;; (error "Dotted"))
1065 ;;; This implements the bracket operator of the formal rules.
1068 (list *bq-list* (bq-process x)))
1069 ((eq (car x) *comma*)
1070 (list *bq-list* (cadr x)))
1071 ((eq (car x) *comma-atsign*)
1073 ;; ((eq (car x) *comma-dot*)
1074 ;; (list *bq-clobberable* (cadr x)))
1075 (t (list *bq-list* (bq-process x)))))
1077 ;;; This auxiliary function is like MAPCAR but has two extra
1078 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
1079 ;;; the result share with the argument x as much as possible.
1080 (defun maptree (fn x)
1083 (let ((a (funcall fn (car x)))
1084 (d (maptree fn (cdr x))))
1085 (if (and (eql a (car x)) (eql d (cdr x)))
1089 ;;; This predicate is true of a form that when read looked
1090 ;;; like %@foo or %.foo.
1091 (defun bq-splicing-frob (x)
1093 (or (eq (car x) *comma-atsign*)
1094 ;; (eq (car x) *comma-dot*)
1097 ;;; This predicate is true of a form that when read
1098 ;;; looked like %@foo or %.foo or just plain %foo.
1101 (or (eq (car x) *comma*)
1102 (eq (car x) *comma-atsign*)
1103 ;; (eq (car x) *comma-dot*)
1106 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
1107 ;;; tries to simplify them. The arguments to #:BQ-APPEND are
1108 ;;; processed from right to left, building up a replacement form.
1109 ;;; At each step a number of special cases are handled that,
1110 ;;; loosely speaking, look like this:
1112 ;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo)
1113 ;;; provided a, b, c are not splicing frobs
1114 ;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
1115 ;;; provided a, b, c are not splicing frobs
1116 ;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
1117 ;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
1118 (defun bq-simplify (x)
1121 (let ((x (if (eq (car x) *bq-quote*)
1123 (maptree #'bq-simplify x))))
1124 (if (not (eq (car x) *bq-append*))
1126 (bq-simplify-args x)))))
1128 (defun bq-simplify-args (x)
1129 (do ((args (reverse (cdr x)) (cdr args))
1132 (cond ((atom (car args))
1133 (bq-attach-append *bq-append* (car args) result))
1134 ((and (eq (caar args) *bq-list*)
1135 (notany #'bq-splicing-frob (cdar args)))
1136 (bq-attach-conses (cdar args) result))
1137 ((and (eq (caar args) *bq-list**)
1138 (notany #'bq-splicing-frob (cdar args)))
1140 (reverse (cdr (reverse (cdar args))))
1141 (bq-attach-append *bq-append*
1142 (car (last (car args)))
1144 ((and (eq (caar args) *bq-quote*)
1145 (consp (cadar args))
1146 (not (bq-frob (cadar args)))
1147 (null (cddar args)))
1148 (bq-attach-conses (list (list *bq-quote*
1151 ((eq (caar args) *bq-clobberable*)
1152 (bq-attach-append *bq-nconc* (cadar args) result))
1153 (t (bq-attach-append *bq-append*
1156 ((null args) result)))
1158 (defun null-or-quoted (x)
1159 (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
1161 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
1162 ;;; or #:BQ-NCONC. This produces a form (op item result) but
1163 ;;; some simplifications are done on the fly:
1165 ;;; (op '(a b c) '(d e f g)) => '(a b c d e f g)
1166 ;;; (op item 'nil) => item, provided item is not a splicable frob
1167 ;;; (op item 'nil) => (op item), if item is a splicable frob
1168 ;;; (op item (op a b c)) => (op item a b c)
1169 (defun bq-attach-append (op item result)
1170 (cond ((and (null-or-quoted item) (null-or-quoted result))
1171 (list *bq-quote* (append (cadr item) (cadr result))))
1172 ((or (null result) (equal result *bq-quote-nil*))
1173 (if (bq-splicing-frob item) (list op item) item))
1174 ((and (consp result) (eq (car result) op))
1175 (list* (car result) item (cdr result)))
1176 (t (list op item result))))
1178 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
1179 ;;; `(LIST* ,@items ,result) but some simplifications are done
1182 ;;; (LIST* 'a 'b 'c 'd) => '(a b c . d)
1183 ;;; (LIST* a b c 'nil) => (LIST a b c)
1184 ;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
1185 ;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
1186 (defun bq-attach-conses (items result)
1187 (cond ((and (every #'null-or-quoted items)
1188 (null-or-quoted result))
1190 (append (mapcar #'cadr items) (cadr result))))
1191 ((or (null result) (equal result *bq-quote-nil*))
1192 (cons *bq-list* items))
1193 ((and (consp result)
1194 (or (eq (car result) *bq-list*)
1195 (eq (car result) *bq-list**)))
1196 (cons (car result) (append items (cdr result))))
1197 (t (cons *bq-list** (append items (list result))))))
1199 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
1200 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
1201 (defun bq-remove-tokens (x)
1202 (cond ((eq x *bq-list*) 'list)
1203 ((eq x *bq-append*) 'append)
1204 ((eq x *bq-nconc*) 'nconc)
1205 ((eq x *bq-list**) 'list*)
1206 ((eq x *bq-quote*) 'quote)
1208 ((eq (car x) *bq-clobberable*)
1209 (bq-remove-tokens (cadr x)))
1210 ((and (eq (car x) *bq-list**)
1213 (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
1214 (t (maptree #'bq-remove-tokens x))))
1216 (define-transformation backquote (form)
1217 (bq-completely-process form))
1222 (defvar *builtins* nil)
1224 (defmacro define-raw-builtin (name args &body body)
1225 ;; Creates a new primitive function `name' with parameters args and
1226 ;; @body. The body can access to the local environment through the
1227 ;; variable *ENVIRONMENT*.
1228 `(push (list ',name (lambda ,args (block ,name ,@body)))
1231 (defmacro define-builtin (name args &body body)
1232 `(define-raw-builtin ,name ,args
1233 (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1236 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1237 (defmacro type-check (decls &body body)
1239 ,@(mapcar (lambda (decl)
1240 `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1242 ,@(mapcar (lambda (decl)
1243 `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1244 (indent "throw 'The value ' + "
1246 " + ' is not a type "
1251 (code "return " (progn ,@body) ";" *newline*)))
1253 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1254 ;;; a variable which holds a list of forms. It will compile them and
1255 ;;; store the result in some Javascript variables. BODY is evaluated
1256 ;;; with ARGS bound to the list of these variables to generate the
1257 ;;; code which performs the transformation on these variables.
1259 (defun variable-arity-call (args function)
1260 (unless (consp args)
1261 (error "ARGS must be a non-empty list"))
1267 ((floatp x) (push (float-to-string x) fargs))
1268 ((numberp x) (push (integer-to-string x) fargs))
1269 (t (let ((v (code "x" (incf counter))))
1272 (code "var " v " = " (ls-compile x) ";" *newline*
1273 "if (typeof " v " !== 'number') throw 'Not a number!';"
1275 (js!selfcall prelude (funcall function (reverse fargs)))))
1278 (defmacro variable-arity (args &body body)
1279 (unless (symbolp args)
1280 (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
1281 `(variable-arity-call ,args
1283 (code "return " ,@body ";" *newline*))))
1285 (defun num-op-num (x op y)
1286 (type-check (("x" "number" x) ("y" "number" y))
1289 (define-raw-builtin + (&rest numbers)
1292 (variable-arity numbers
1293 (join numbers "+"))))
1295 (define-raw-builtin - (x &rest others)
1296 (let ((args (cons x others)))
1297 (variable-arity args
1299 (concat "-" (car args))
1302 (define-raw-builtin * (&rest numbers)
1305 (variable-arity numbers
1306 (join numbers "*"))))
1308 (define-raw-builtin / (x &rest others)
1309 (let ((args (cons x others)))
1310 (variable-arity args
1312 (concat "1 /" (car args))
1315 (define-builtin mod (x y) (num-op-num x "%" y))
1318 (defun comparison-conjuntion (vars op)
1323 (concat (car vars) op (cadr vars)))
1325 (concat (car vars) op (cadr vars)
1327 (comparison-conjuntion (cdr vars) op)))))
1329 (defmacro define-builtin-comparison (op sym)
1330 `(define-raw-builtin ,op (x &rest args)
1331 (let ((args (cons x args)))
1332 (variable-arity args
1333 (js!bool (comparison-conjuntion args ,sym))))))
1335 (define-builtin-comparison > ">")
1336 (define-builtin-comparison < "<")
1337 (define-builtin-comparison >= ">=")
1338 (define-builtin-comparison <= "<=")
1339 (define-builtin-comparison = "==")
1341 (define-builtin numberp (x)
1342 (js!bool (code "(typeof (" x ") == \"number\")")))
1344 (define-builtin floor (x)
1345 (type-check (("x" "number" x))
1348 (define-builtin expt (x y)
1349 (type-check (("x" "number" x)
1353 (define-builtin float-to-string (x)
1354 (type-check (("x" "number" x))
1357 (define-builtin cons (x y)
1358 (code "({car: " x ", cdr: " y "})"))
1360 (define-builtin consp (x)
1363 "var tmp = " x ";" *newline*
1364 "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1366 (define-builtin car (x)
1368 "var tmp = " x ";" *newline*
1369 "return tmp === " (ls-compile nil)
1370 "? " (ls-compile nil)
1371 ": tmp.car;" *newline*))
1373 (define-builtin cdr (x)
1375 "var tmp = " x ";" *newline*
1376 "return tmp === " (ls-compile nil) "? "
1378 ": tmp.cdr;" *newline*))
1380 (define-builtin rplaca (x new)
1381 (type-check (("x" "object" x))
1382 (code "(x.car = " new ", x)")))
1384 (define-builtin rplacd (x new)
1385 (type-check (("x" "object" x))
1386 (code "(x.cdr = " new ", x)")))
1388 (define-builtin symbolp (x)
1391 "var tmp = " x ";" *newline*
1392 "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1394 (define-builtin make-symbol (name)
1395 (type-check (("name" "string" name))
1398 (define-builtin symbol-name (x)
1399 (code "(" x ").name"))
1401 (define-builtin set (symbol value)
1402 (code "(" symbol ").value = " value))
1404 (define-builtin fset (symbol value)
1405 (code "(" symbol ").fvalue = " value))
1407 (define-builtin boundp (x)
1408 (js!bool (code "(" x ".value !== undefined)")))
1410 (define-builtin symbol-value (x)
1412 "var symbol = " x ";" *newline*
1413 "var value = symbol.value;" *newline*
1414 "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1415 "return value;" *newline*))
1417 (define-builtin symbol-function (x)
1419 "var symbol = " x ";" *newline*
1420 "var func = symbol.fvalue;" *newline*
1421 "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1422 "return func;" *newline*))
1424 (define-builtin symbol-plist (x)
1425 (code "((" x ").plist || " (ls-compile nil) ")"))
1427 (define-builtin lambda-code (x)
1428 (code "(" x ").toString()"))
1430 (define-builtin eq (x y) (js!bool (code "(" x " === " y ")")))
1432 (define-builtin char-to-string (x)
1433 (type-check (("x" "number" x))
1434 "String.fromCharCode(x)"))
1436 (define-builtin stringp (x)
1437 (js!bool (code "(typeof(" x ") == \"string\")")))
1439 (define-builtin string-upcase (x)
1440 (type-check (("x" "string" x))
1443 (define-builtin string-length (x)
1444 (type-check (("x" "string" x))
1447 (define-raw-builtin slice (string a &optional b)
1449 "var str = " (ls-compile string) ";" *newline*
1450 "var a = " (ls-compile a) ";" *newline*
1452 (when b (code "b = " (ls-compile b) ";" *newline*))
1453 "return str.slice(a,b);" *newline*))
1455 (define-builtin char (string index)
1456 (type-check (("string" "string" string)
1457 ("index" "number" index))
1458 "string.charCodeAt(index)"))
1460 (define-builtin concat-two (string1 string2)
1461 (type-check (("string1" "string" string1)
1462 ("string2" "string" string2))
1463 "string1.concat(string2)"))
1465 (define-raw-builtin funcall (func &rest args)
1467 "var f = " (ls-compile func) ";" *newline*
1468 "return (typeof f === 'function'? f: f.fvalue)("
1469 (join (cons (if *multiple-value-p* "values" "pv")
1470 (mapcar #'ls-compile args))
1474 (define-raw-builtin apply (func &rest args)
1476 (code "(" (ls-compile func) ")()")
1477 (let ((args (butlast args))
1478 (last (car (last args))))
1480 "var f = " (ls-compile func) ";" *newline*
1481 "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
1482 (mapcar #'ls-compile args))
1485 "var tail = (" (ls-compile last) ");" *newline*
1486 "while (tail != " (ls-compile nil) "){" *newline*
1487 " args.push(tail.car);" *newline*
1488 " tail = tail.cdr;" *newline*
1490 "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1492 (define-builtin js-eval (string)
1493 (type-check (("string" "string" string))
1494 (if *multiple-value-p*
1496 "var v = globalEval(string);" *newline*
1497 "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
1498 (indent "v = [v];" *newline*
1499 "v['multiple-value'] = true;" *newline*)
1501 "return values.apply(this, v);" *newline*)
1502 "globalEval(string)")))
1504 (define-builtin error (string)
1505 (js!selfcall "throw " string ";" *newline*))
1507 (define-builtin new () "{}")
1509 (define-builtin objectp (x)
1510 (js!bool (code "(typeof (" x ") === 'object')")))
1512 (define-builtin oget (object key)
1514 "var tmp = " "(" object ")[" key "];" *newline*
1515 "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1517 (define-builtin oset (object key value)
1518 (code "((" object ")[" key "] = " value ")"))
1520 (define-builtin in (key object)
1521 (js!bool (code "((" key ") in (" object "))")))
1523 (define-builtin functionp (x)
1524 (js!bool (code "(typeof " x " == 'function')")))
1526 (define-builtin write-string (x)
1527 (type-check (("x" "string" x))
1530 (define-builtin make-array (n)
1532 "var r = [];" *newline*
1533 "for (var i = 0; i < " n "; i++)" *newline*
1534 (indent "r.push(" (ls-compile nil) ");" *newline*)
1535 "return r;" *newline*))
1537 (define-builtin arrayp (x)
1540 "var x = " x ";" *newline*
1541 "return typeof x === 'object' && 'length' in x;")))
1543 (define-builtin aref (array n)
1545 "var x = " "(" array ")[" n "];" *newline*
1546 "if (x === undefined) throw 'Out of range';" *newline*
1547 "return x;" *newline*))
1549 (define-builtin aset (array n value)
1551 "var x = " array ";" *newline*
1552 "var i = " n ";" *newline*
1553 "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1554 "return x[i] = " value ";" *newline*))
1556 (define-builtin get-internal-real-time ()
1557 "(new Date()).getTime()")
1559 (define-builtin values-array (array)
1560 (if *multiple-value-p*
1561 (code "values.apply(this, " array ")")
1562 (code "pv.apply(this, " array ")")))
1564 (define-raw-builtin values (&rest args)
1565 (if *multiple-value-p*
1566 (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1567 (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1569 ;; Receives the JS function as first argument as a literal string. The
1570 ;; second argument is compiled and should evaluate to a vector of
1571 ;; values to apply to the the function. The result returned.
1572 (define-builtin %js-call (fun args)
1573 (code fun ".apply(this, " args ")"))
1577 (let ((b (lookup-in-lexenv x *environment* 'function)))
1578 (if (and b (eq (binding-type b) 'macro))
1583 (defvar *macroexpander-cache*
1584 (make-hash-table :test #'eq))
1586 (defun ls-macroexpand-1 (form)
1589 (let ((b (lookup-in-lexenv form *environment* 'variable)))
1590 (if (and b (eq (binding-type b) 'macro))
1591 (values (binding-value b) t)
1592 (values form nil))))
1594 (let ((macro-binding (macro (car form))))
1596 (let ((expander (binding-value macro-binding)))
1599 ((gethash macro-binding *macroexpander-cache*)
1600 (setq expander (gethash macro-binding *macroexpander-cache*)))
1602 (let ((compiled (eval expander)))
1603 ;; The list representation are useful while
1604 ;; bootstrapping, as we can dump the definition of the
1605 ;; macros easily, but they are slow because we have to
1606 ;; evaluate them and compile them now and again. So, let
1607 ;; us replace the list representation version of the
1608 ;; function with the compiled one.
1610 #+jscl (setf (binding-value macro-binding) compiled)
1611 #+common-lisp (setf (gethash macro-binding *macroexpander-cache*) compiled)
1612 (setq expander compiled))))
1613 (values (apply expander (cdr form)) t))
1614 (values form nil))))
1616 (values form nil))))
1618 (defun compile-funcall (function args)
1619 (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1620 (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
1621 (unless (or (symbolp function)
1622 (and (consp function)
1623 (eq (car function) 'lambda)))
1624 (error "Bad function"))
1626 ((translate-function function)
1627 (concat (translate-function function) arglist))
1628 ((and (symbolp function)
1629 #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1631 (code (ls-compile `',function) ".fvalue" arglist))
1633 (code (ls-compile `#',function) arglist)))))
1635 (defun ls-compile-block (sexps &optional return-last-p)
1637 (code (ls-compile-block (butlast sexps))
1638 "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1640 (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1641 (concat ";" *newline*))))
1643 (defun ls-compile (sexp &optional multiple-value-p)
1644 (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
1646 (return-from ls-compile (ls-compile sexp multiple-value-p)))
1647 ;; The expression has been macroexpanded. Now compile it!
1648 (let ((*multiple-value-p* multiple-value-p))
1651 (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1653 ((and b (not (member 'special (binding-declarations b))))
1655 ((or (keywordp sexp)
1656 (and b (member 'constant (binding-declarations b))))
1657 (code (ls-compile `',sexp) ".value"))
1659 (ls-compile `(symbol-value ',sexp))))))
1660 ((integerp sexp) (integer-to-string sexp))
1661 ((floatp sexp) (float-to-string sexp))
1662 ((stringp sexp) (code "\"" (escape-string sexp) "\""))
1663 ((arrayp sexp) (literal sexp))
1665 (let ((name (car sexp))
1669 ((assoc name *compilations*)
1670 (let ((comp (second (assoc name *compilations*))))
1672 ;; Built-in functions
1673 ((and (assoc name *builtins*)
1674 (not (claimp name 'function 'notinline)))
1675 (let ((comp (second (assoc name *builtins*))))
1678 (compile-funcall name args)))))
1680 (error (concat "How should I compile " (prin1-to-string sexp) "?")))))))
1683 (defvar *compile-print-toplevels* nil)
1685 (defun truncate-string (string &optional (width 60))
1686 (let ((n (or (position #\newline string)
1687 (min width (length string)))))
1688 (subseq string 0 n)))
1690 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1691 (let ((*toplevel-compilations* nil))
1693 ((and (consp sexp) (eq (car sexp) 'progn))
1694 (let ((subs (mapcar (lambda (s)
1695 (ls-compile-toplevel s t))
1697 (join (remove-if #'null-or-empty-p subs))))
1699 (when *compile-print-toplevels*
1700 (let ((form-string (prin1-to-string sexp)))
1701 (write-string "Compiling ")
1702 (write-string (truncate-string form-string))
1703 (write-line "...")))
1705 (let ((code (ls-compile sexp multiple-value-p)))
1706 (code (join-trailing (get-toplevel-compilations)
1707 (code ";" *newline*))
1709 (code code ";" *newline*))))))))