b5909625cea74145f7072bc360073baf943131a5
[jscl.git] / src / compiler.lisp
1 ;;; compiler.lisp ---
2
3 ;; copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
6 ;; JSCL 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.
10 ;;
11 ;; JSCL 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.
15 ;;
16 ;; You should have received a copy of the GNU General Public License
17 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
18
19 ;;;; Compiler
20
21 (/debug "loading compiler.lisp!")
22
23 ;;; Translate the Lisp code to Javascript. It will compile the special
24 ;;; forms. Some primitive functions are compiled as special forms
25 ;;; too. The respective real functions are defined in the target (see
26 ;;; the beginning of this file) as well as some primitive functions.
27
28 (defun interleave (list element &optional after-last-p)
29   (unless (null list)
30     (with-collect
31       (collect (car list))
32       (dolist (x (cdr list))
33         (collect element)
34         (collect x))
35       (when after-last-p
36         (collect element)))))
37
38 (defun code (&rest args)
39   (mapconcat (lambda (arg)
40                (cond
41                  ((null arg) "")
42                  ((integerp arg) (integer-to-string arg))
43                  ((floatp arg) (float-to-string arg))
44                  ((stringp arg) arg)
45                  (t
46                   (with-output-to-string (*standard-output*)
47                     (js-expr arg)))))
48              args))
49
50 ;;; Wrap X with a Javascript code to convert the result from
51 ;;; Javascript generalized booleans to T or NIL.
52 (defun js!bool (x)
53   `(if ,x ,(ls-compile t) ,(ls-compile nil)))
54
55 ;;; Concatenate the arguments and wrap them with a self-calling
56 ;;; Javascript anonymous function. It is used to make some Javascript
57 ;;; statements valid expressions and provide a private scope as well.
58 ;;; It could be defined as function, but we could do some
59 ;;; preprocessing in the future.
60 (defmacro js!selfcall (&body body)
61   ``(call (function nil (code ,,@body))))
62
63 (defmacro js!selfcall* (&body body)
64   ``(call (function nil ,,@body)))
65
66
67 ;;; Like CODE, but prefix each line with four spaces. Two versions
68 ;;; of this function are available, because the Ecmalisp version is
69 ;;; very slow and bootstraping was annoying.
70
71 ;;; A Form can return a multiple values object calling VALUES, like
72 ;;; values(arg1, arg2, ...). It will work in any context, as well as
73 ;;; returning an individual object. However, if the special variable
74 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
75 ;;; value will be used, so we can optimize to avoid the VALUES
76 ;;; function call.
77 (defvar *multiple-value-p* nil)
78
79 ;;; Environment
80
81 (def!struct binding
82   name
83   type
84   value
85   declarations)
86
87 (def!struct lexenv
88   variable
89   function
90   block
91   gotag)
92
93 (defun lookup-in-lexenv (name lexenv namespace)
94   (find name (ecase namespace
95                 (variable (lexenv-variable lexenv))
96                 (function (lexenv-function lexenv))
97                 (block    (lexenv-block    lexenv))
98                 (gotag    (lexenv-gotag    lexenv)))
99         :key #'binding-name))
100
101 (defun push-to-lexenv (binding lexenv namespace)
102   (ecase namespace
103     (variable (push binding (lexenv-variable lexenv)))
104     (function (push binding (lexenv-function lexenv)))
105     (block    (push binding (lexenv-block    lexenv)))
106     (gotag    (push binding (lexenv-gotag    lexenv)))))
107
108 (defun extend-lexenv (bindings lexenv namespace)
109   (let ((env (copy-lexenv lexenv)))
110     (dolist (binding (reverse bindings) env)
111       (push-to-lexenv binding env namespace))))
112
113
114 (defvar *environment* (make-lexenv))
115
116 (defvar *variable-counter* 0)
117
118 (defun gvarname (symbol)
119   (declare (ignore symbol))
120   (incf *variable-counter*)
121   (concat "v" (integer-to-string *variable-counter*)))
122
123 (defun translate-variable (symbol)
124   (awhen (lookup-in-lexenv symbol *environment* 'variable)
125     (binding-value it)))
126
127 (defun extend-local-env (args)
128   (let ((new (copy-lexenv *environment*)))
129     (dolist (symbol args new)
130       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
131         (push-to-lexenv b new 'variable)))))
132
133 ;;; Toplevel compilations
134 (defvar *toplevel-compilations* nil)
135
136 (defun toplevel-compilation (string)
137   (push string *toplevel-compilations*))
138
139 (defun get-toplevel-compilations ()
140   (reverse *toplevel-compilations*))
141
142 (defun %compile-defmacro (name lambda)
143   (toplevel-compilation (ls-compile `',name))
144   (let ((binding (make-binding :name name :type 'macro :value lambda)))
145     (push-to-lexenv binding  *environment* 'function))
146   name)
147
148 (defun global-binding (name type namespace)
149   (or (lookup-in-lexenv name *environment* namespace)
150       (let ((b (make-binding :name name :type type :value nil)))
151         (push-to-lexenv b *environment* namespace)
152         b)))
153
154 (defun claimp (symbol namespace claim)
155   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
156     (and b (member claim (binding-declarations b)))))
157
158 (defun !proclaim (decl)
159   (case (car decl)
160     (special
161      (dolist (name (cdr decl))
162        (let ((b (global-binding name 'variable 'variable)))
163          (push 'special (binding-declarations b)))))
164     (notinline
165      (dolist (name (cdr decl))
166        (let ((b (global-binding name 'function 'function)))
167          (push 'notinline (binding-declarations b)))))
168     (constant
169      (dolist (name (cdr decl))
170        (let ((b (global-binding name 'variable 'variable)))
171          (push 'constant (binding-declarations b)))))))
172
173 #+jscl
174 (fset 'proclaim #'!proclaim)
175
176 (defun %define-symbol-macro (name expansion)
177   (let ((b (make-binding :name name :type 'macro :value expansion)))
178     (push-to-lexenv b *environment* 'variable)
179     name))
180
181 #+jscl
182 (defmacro define-symbol-macro (name expansion)
183   `(%define-symbol-macro ',name ',expansion))
184
185
186 ;;; Special forms
187
188 (defvar *compilations* nil)
189
190 (defmacro define-compilation (name args &body body)
191   ;; Creates a new primitive `name' with parameters args and
192   ;; @body. The body can access to the local environment through the
193   ;; variable *ENVIRONMENT*.
194   `(push (list ',name (lambda ,args (block ,name ,@body)))
195          *compilations*))
196
197 (define-compilation if (condition true &optional false)
198   `(if (!== ,(ls-compile condition) ,(ls-compile nil))
199        ,(ls-compile true *multiple-value-p*)
200        ,(ls-compile false *multiple-value-p*)))
201
202 (defvar *ll-keywords* '(&optional &rest &key))
203
204 (defun list-until-keyword (list)
205   (if (or (null list) (member (car list) *ll-keywords*))
206       nil
207       (cons (car list) (list-until-keyword (cdr list)))))
208
209 (defun ll-section (keyword ll)
210   (list-until-keyword (cdr (member keyword ll))))
211
212 (defun ll-required-arguments (ll)
213   (list-until-keyword ll))
214
215 (defun ll-optional-arguments-canonical (ll)
216   (mapcar #'ensure-list (ll-section '&optional ll)))
217
218 (defun ll-optional-arguments (ll)
219   (mapcar #'car (ll-optional-arguments-canonical ll)))
220
221 (defun ll-rest-argument (ll)
222   (let ((rest (ll-section '&rest ll)))
223     (when (cdr rest)
224       (error "Bad lambda-list `~S'." ll))
225     (car rest)))
226
227 (defun ll-keyword-arguments-canonical (ll)
228   (flet ((canonicalize (keyarg)
229            ;; Build a canonical keyword argument descriptor, filling
230            ;; the optional fields. The result is a list of the form
231            ;; ((keyword-name var) init-form).
232            (let ((arg (ensure-list keyarg)))
233              (cons (if (listp (car arg))
234                        (car arg)
235                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
236                    (cdr arg)))))
237     (mapcar #'canonicalize (ll-section '&key ll))))
238
239 (defun ll-keyword-arguments (ll)
240   (mapcar (lambda (keyarg) (second (first keyarg)))
241           (ll-keyword-arguments-canonical ll)))
242
243 (defun ll-svars (lambda-list)
244   (let ((args
245          (append
246           (ll-keyword-arguments-canonical lambda-list)
247           (ll-optional-arguments-canonical lambda-list))))
248     (remove nil (mapcar #'third args))))
249
250 (defun lambda-name/docstring-wrapper (name docstring code)
251   (if (or name docstring)
252       (js!selfcall*
253         `(var (func ,code))
254         (when name      `(= (get func "fname") ,name))
255         (when docstring `(= (get func "docstring") ,docstring))
256         `(return func))
257       code))
258
259 (defun lambda-check-argument-count
260     (n-required-arguments n-optional-arguments rest-p)
261   ;; Note: Remember that we assume that the number of arguments of a
262   ;; call is at least 1 (the values argument).
263   (let ((min n-required-arguments)
264         (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments))))
265     (block nil
266       ;; Special case: a positive exact number of arguments.
267       (when (and (< 0 min) (eql min max))
268         (return `(code "checkArgs(nargs, " ,min ");")))
269       ;; General case:
270       `(code
271         ,(when (< 0 min)
272            `(code "checkArgsAtLeast(nargs, " ,min ");"))
273         ,(when (numberp max)
274            `(code "checkArgsAtMost(nargs, " ,max ");"))))))
275
276 (defun compile-lambda-optional (ll)
277   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
278          (n-required-arguments (length (ll-required-arguments ll)))
279          (n-optional-arguments (length optional-arguments)))
280     (when optional-arguments
281       `(code "switch(nargs){"
282              ,(let ((cases nil)
283                     (idx 0))
284                    (progn
285                      (while (< idx n-optional-arguments)
286                        (let ((arg (nth idx optional-arguments)))
287                          (push `(code "case " ,(+ idx n-required-arguments) ":"
288                                       (code ,(translate-variable (car arg))
289                                             "="
290                                             ,(ls-compile (cadr arg)) ";")
291                                       ,(when (third arg)
292                                          `(code ,(translate-variable (third arg))
293                                                 "="
294                                                 ,(ls-compile nil)
295                                                 ";")))
296                                cases)
297                          (incf idx)))
298                      (push `(code "default: break;") cases)
299                      `(code ,@(reverse cases))))
300              "}"))))
301
302 (defun compile-lambda-rest (ll)
303   (let ((n-required-arguments (length (ll-required-arguments ll)))
304         (n-optional-arguments (length (ll-optional-arguments ll)))
305         (rest-argument (ll-rest-argument ll)))
306     (when rest-argument
307       (let ((js!rest (translate-variable rest-argument)))
308         `(code "var " ,js!rest "= " ,(ls-compile nil) ";"
309                "for (var i = nargs-1; i>=" ,(+ n-required-arguments n-optional-arguments)
310                "; i--)"
311                (code ,js!rest " = {car: arguments[i+2], cdr: " ,js!rest "};"))))))
312
313 (defun compile-lambda-parse-keywords (ll)
314   (let ((n-required-arguments
315          (length (ll-required-arguments ll)))
316         (n-optional-arguments
317          (length (ll-optional-arguments ll)))
318         (keyword-arguments
319          (ll-keyword-arguments-canonical ll)))
320     `(code
321       ;; Declare variables
322       ,@(mapcar (lambda (arg)
323                   (let ((var (second (car arg))))
324                     `(code "var " ,(translate-variable var) "; "
325                            ,(when (third arg)
326                               `(code "var " ,(translate-variable (third arg))
327                                      " = " ,(ls-compile nil)
328                                      ";" )))))
329                 keyword-arguments)
330       ;; Parse keywords
331       ,(flet ((parse-keyword (keyarg)
332                ;; ((keyword-name var) init-form)
333                `(code "for (i=" ,(+ n-required-arguments n-optional-arguments)
334                       "; i<nargs; i+=2){"
335                       "if (arguments[i+2] === " ,(ls-compile (caar keyarg)) "){"
336                       ,(translate-variable (cadr (car keyarg)))
337                       " = arguments[i+3];"
338                       ,(let ((svar (third keyarg)))
339                             (when svar
340                               `(code ,(translate-variable svar) " = " ,(ls-compile t) ";" )))
341                       "break;"
342                       "}"
343                       "}"
344                       ;; Default value
345                       "if (i == nargs){"
346                       ,(translate-variable (cadr (car keyarg)))
347                       " = "
348                       ,(ls-compile (cadr keyarg))
349                       ";"
350                       "}")))
351         (when keyword-arguments
352           `(code "var i;"
353                  ,@(mapcar #'parse-keyword keyword-arguments))))
354       ;; Check for unknown keywords
355       ,(when keyword-arguments
356         `(code "var start = " ,(+ n-required-arguments n-optional-arguments) ";"
357                "if ((nargs - start) % 2 == 1){"
358                "throw 'Odd number of keyword arguments';" 
359                "}"
360                "for (i = start; i<nargs; i+=2){"
361                "if ("
362                ,@(interleave (mapcar (lambda (x)
363                                        `(code "arguments[i+2] !== " ,(ls-compile (caar x))))
364                                      keyword-arguments)
365                             " && ")
366                ")"
367                "throw 'Unknown keyword argument ' + xstring(arguments[i+2].name);" 
368                "}" )))))
369
370 (defun parse-lambda-list (ll)
371   (values (ll-required-arguments ll)
372           (ll-optional-arguments ll)
373           (ll-keyword-arguments  ll)
374           (ll-rest-argument      ll)))
375
376 ;;; Process BODY for declarations and/or docstrings. Return as
377 ;;; multiple values the BODY without docstrings or declarations, the
378 ;;; list of declaration forms and the docstring.
379 (defun parse-body (body &key declarations docstring)
380   (let ((value-declarations)
381         (value-docstring))
382     ;; Parse declarations
383     (when declarations
384       (do* ((rest body (cdr rest))
385             (form (car rest) (car rest)))
386            ((or (atom form) (not (eq (car form) 'declare)))
387             (setf body rest))
388         (push form value-declarations)))
389     ;; Parse docstring
390     (when (and docstring
391                (stringp (car body))
392                (not (null (cdr body))))
393       (setq value-docstring (car body))
394       (setq body (cdr body)))
395     (values body value-declarations value-docstring)))
396
397 ;;; Compile a lambda function with lambda list LL and body BODY. If
398 ;;; NAME is given, it should be a constant string and it will become
399 ;;; the name of the function. If BLOCK is non-NIL, a named block is
400 ;;; created around the body. NOTE: No block (even anonymous) is
401 ;;; created if BLOCk is NIL.
402 (defun compile-lambda (ll body &key name block)
403   (multiple-value-bind (required-arguments
404                         optional-arguments
405                         keyword-arguments
406                         rest-argument)
407       (parse-lambda-list ll)
408     (multiple-value-bind (body decls documentation)
409         (parse-body body :declarations t :docstring t)
410       (declare (ignore decls))
411       (let ((n-required-arguments (length required-arguments))
412             (n-optional-arguments (length optional-arguments))
413             (*environment* (extend-local-env
414                             (append (ensure-list rest-argument)
415                                     required-arguments
416                                     optional-arguments
417                                     keyword-arguments
418                                     (ll-svars ll)))))
419         (lambda-name/docstring-wrapper name documentation
420          `(code
421            "(function ("
422            ,(join (list* "values"
423                          "nargs"
424                          (mapcar #'translate-variable
425                                  (append required-arguments optional-arguments)))
426                   ",")
427            "){"
428            ;; Check number of arguments
429            ,(lambda-check-argument-count n-required-arguments
430                                          n-optional-arguments
431                                          (or rest-argument keyword-arguments))
432            ,(compile-lambda-optional ll)
433            ,(compile-lambda-rest ll)
434            ,(compile-lambda-parse-keywords ll)
435            ,(let ((*multiple-value-p* t))
436                  (if block
437                      (ls-compile-block `((block ,block ,@body)) t)
438                      (ls-compile-block body t)))
439            "})"))))))
440
441
442 (defun setq-pair (var val)
443   (let ((b (lookup-in-lexenv var *environment* 'variable)))
444     (cond
445       ((and b
446             (eq (binding-type b) 'variable)
447             (not (member 'special (binding-declarations b)))
448             (not (member 'constant (binding-declarations b))))
449        ;; TODO: Unnecesary make-symbol when codegen migration is
450        ;; finished.
451        `(= ,(make-symbol (binding-value b)) ,(ls-compile val)))
452       ((and b (eq (binding-type b) 'macro))
453        (ls-compile `(setf ,var ,val)))
454       (t
455        (ls-compile `(set ',var ,val))))))
456
457
458 (define-compilation setq (&rest pairs)
459   (let ((result nil))
460     (when (null pairs)
461       (return-from setq (ls-compile nil)))
462     (while t
463       (cond
464         ((null pairs)
465          (return))
466         ((null (cdr pairs))
467          (error "Odd pairs in SETQ"))
468         (t
469          (push `,(setq-pair (car pairs) (cadr pairs)) result)
470          (setq pairs (cddr pairs)))))
471     `(progn ,@(reverse result))))
472
473
474 ;;; Compilation of literals an object dumping
475
476 ;;; BOOTSTRAP MAGIC: We record the macro definitions as lists during
477 ;;; the bootstrap. Once everything is compiled, we want to dump the
478 ;;; whole global environment to the output file to reproduce it in the
479 ;;; run-time. However, the environment must contain expander functions
480 ;;; rather than lists. We do not know how to dump function objects
481 ;;; itself, so we mark the list definitions with this object and the
482 ;;; compiler will be called when this object has to be dumped.
483 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
484 ;;;
485 ;;; Indeed, perhaps to compile the object other macros need to be
486 ;;; evaluated. For this reason we define a valid macro-function for
487 ;;; this symbol.
488 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
489 #-jscl
490 (setf (macro-function *magic-unquote-marker*)
491       (lambda (form &optional environment)
492         (declare (ignore environment))
493         (second form)))
494
495 (defvar *literal-table* nil)
496 (defvar *literal-counter* 0)
497
498 (defun genlit ()
499   (incf *literal-counter*)
500   (concat "l" (integer-to-string *literal-counter*)))
501
502 (defun dump-symbol (symbol)
503   #-jscl
504   (let ((package (symbol-package symbol)))
505     (if (eq package (find-package "KEYWORD"))
506         `(new (call |Symbol| ,(dump-string (symbol-name symbol)) ,(dump-string (package-name package))))
507         `(new (call |Symbol| ,(dump-string (symbol-name symbol))))))
508   #+jscl
509   (let ((package (symbol-package symbol)))
510     (if (null package)
511         `(new (call |Symbol| ,(dump-string (symbol-name symbol))))
512         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
513
514 (defun dump-cons (cons)
515   (let ((head (butlast cons))
516         (tail (last cons)))
517     `(call |QIList|
518            ,@(mapcar (lambda (x) `(code ,(literal x t))) head)
519            (code ,(literal (car tail) t))
520            (code ,(literal (cdr tail) t)))))
521
522 (defun dump-array (array)
523   (let ((elements (vector-to-list array)))
524     (list-to-vector (mapcar (lambda (x) `(code ,(literal x)))
525                             elements))))
526
527 (defun dump-string (string)
528   `(call |make_lisp_string| ,string))
529
530 (defun literal (sexp &optional recursive)
531   (cond
532     ((integerp sexp) (integer-to-string sexp))
533     ((floatp sexp) (float-to-string sexp))
534     ((characterp sexp) (js-escape-string (string sexp)))
535     (t
536      (or (cdr (assoc sexp *literal-table* :test #'eql))
537          (let ((dumped (typecase sexp
538                          (symbol (dump-symbol sexp))
539                          (string (dump-string sexp))
540                          (cons
541                           ;; BOOTSTRAP MAGIC: See the root file
542                           ;; jscl.lisp and the function
543                           ;; `dump-global-environment' for futher
544                           ;; information.
545                           (if (eq (car sexp) *magic-unquote-marker*)
546                               (ls-compile (second sexp))
547                               (dump-cons sexp)))
548                          (array (dump-array sexp)))))
549            (if (and recursive (not (symbolp sexp)))
550                dumped
551                (let ((jsvar (genlit)))
552                  (push (cons sexp jsvar) *literal-table*)
553                  (toplevel-compilation `(code "var " ,jsvar " = " ,dumped))
554                  (when (keywordp sexp)
555                    (toplevel-compilation `(code ,jsvar ".value = " ,jsvar)))
556                  jsvar)))))))
557
558
559 (define-compilation quote (sexp)
560   (literal sexp))
561
562 (define-compilation %while (pred &rest body)
563   (js!selfcall*
564     `(while (!== ,(ls-compile pred) ,(ls-compile nil))
565        0                                ; TODO: Force
566                                         ; braces. Unnecesary when code
567                                         ; is gone
568        ,(ls-compile-block body))
569    `(return ,(ls-compile nil))))
570
571 (define-compilation function (x)
572   (cond
573     ((and (listp x) (eq (car x) 'lambda))
574      (compile-lambda (cadr x) (cddr x)))
575     ((and (listp x) (eq (car x) 'named-lambda))
576      (destructuring-bind (name ll &rest body) (cdr x)
577        (compile-lambda ll body
578                        :name (symbol-name name)
579                        :block name)))
580     ((symbolp x)
581      (let ((b (lookup-in-lexenv x *environment* 'function)))
582        (if b
583            (binding-value b)
584            (ls-compile `(symbol-function ',x)))))))
585
586
587 (defun make-function-binding (fname)
588   (make-binding :name fname :type 'function :value (gvarname fname)))
589
590 (defun compile-function-definition (list)
591   (compile-lambda (car list) (cdr list)))
592
593 (defun translate-function (name)
594   (let ((b (lookup-in-lexenv name *environment* 'function)))
595     (and b (binding-value b))))
596
597 (define-compilation flet (definitions &rest body)
598   (let* ((fnames (mapcar #'car definitions))
599          (cfuncs (mapcar (lambda (def)
600                            (compile-lambda (cadr def)
601                                            `((block ,(car def)
602                                                ,@(cddr def)))))
603                          definitions))
604          (*environment*
605           (extend-lexenv (mapcar #'make-function-binding fnames)
606                          *environment*
607                          'function)))
608     `(call (function ,(mapcar #'make-symbol (mapcar #'translate-function fnames))
609                 ,(ls-compile-block body t))
610            ,@cfuncs)))
611
612 (define-compilation labels (definitions &rest body)
613   (let* ((fnames (mapcar #'car definitions))
614          (*environment*
615           (extend-lexenv (mapcar #'make-function-binding fnames)
616                          *environment*
617                          'function)))
618     (js!selfcall
619       `(code ,@(mapcar (lambda (func)
620                          `(code "var " ,(translate-function (car func))
621                                 " = " ,(compile-lambda (cadr func)
622                                                        `((block ,(car func) ,@(cddr func))))
623                                 ";" ))
624                        definitions))
625       (ls-compile-block body t))))
626
627
628 (defvar *compiling-file* nil)
629 (define-compilation eval-when-compile (&rest body)
630   (if *compiling-file*
631       (progn
632         (eval (cons 'progn body))
633         (ls-compile 0))
634       (ls-compile `(progn ,@body))))
635
636 (defmacro define-transformation (name args form)
637   `(define-compilation ,name ,args
638      (ls-compile ,form)))
639
640 (define-compilation progn (&rest body)
641   (if (null (cdr body))
642       (ls-compile (car body) *multiple-value-p*)
643       `(progn
644          ,@(append (mapcar #'ls-compile (butlast body))
645                    (list (ls-compile (car (last body)) t))))))
646
647 (define-compilation macrolet (definitions &rest body)
648   (let ((*environment* (copy-lexenv *environment*)))
649     (dolist (def definitions)
650       (destructuring-bind (name lambda-list &body body) def
651         (let ((binding (make-binding :name name :type 'macro :value
652                                      (let ((g!form (gensym)))
653                                        `(lambda (,g!form)
654                                           (destructuring-bind ,lambda-list ,g!form
655                                             ,@body))))))
656           (push-to-lexenv binding  *environment* 'function))))
657     (ls-compile `(progn ,@body) *multiple-value-p*)))
658
659
660 (defun special-variable-p (x)
661   (and (claimp x 'variable 'special) t))
662
663 ;;; Wrap CODE to restore the symbol values of the dynamic
664 ;;; bindings. BINDINGS is a list of pairs of the form
665 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
666 ;;; name to initialize the symbol value and where to stored
667 ;;; the old value.
668 (defun let-binding-wrapper (bindings body)
669   (when (null bindings)
670     (return-from let-binding-wrapper body))
671   `(code
672     "try {"
673     (code "var tmp;"
674           ,@(mapcar
675              (lambda (b)
676                (let ((s (ls-compile `(quote ,(car b)))))
677                  `(code "tmp = " ,s ".value;"
678                         ,s ".value = " ,(cdr b) ";"
679                         ,(cdr b) " = tmp;" )))
680              bindings)
681           ,body
682           )
683     "}"
684     "finally {"
685     (code
686      ,@(mapcar (lambda (b)
687                  (let ((s (ls-compile `(quote ,(car b)))))
688                    `(code ,s ".value" " = " ,(cdr b) ";" )))
689                bindings))
690     "}" ))
691
692 (define-compilation let (bindings &rest body)
693   (let* ((bindings (mapcar #'ensure-list bindings))
694          (variables (mapcar #'first bindings))
695          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
696          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
697          (dynamic-bindings))
698     `(code "(function("
699            ,@(interleave
700               (mapcar (lambda (x)
701                         (if (special-variable-p x)
702                             (let ((v (gvarname x)))
703                               (push (cons x v) dynamic-bindings)
704                               v)
705                             (translate-variable x)))
706                       variables)
707               ",")
708            "){"
709            ,(let ((body (ls-compile-block body t t)))
710              `(code ,(let-binding-wrapper dynamic-bindings body)))
711            "})(" ,@(interleave cvalues ",") ")")))
712
713
714 ;;; Return the code to initialize BINDING, and push it extending the
715 ;;; current lexical environment if the variable is not special.
716 (defun let*-initialize-value (binding)
717   (let ((var (first binding))
718         (value (second binding)))
719     (if (special-variable-p var)
720         `(code ,(ls-compile `(setq ,var ,value)) ";" )
721         (let* ((v (gvarname var))
722                (b (make-binding :name var :type 'variable :value v)))
723           (prog1 `(code "var " ,v " = " ,(ls-compile value) ";" )
724             (push-to-lexenv b *environment* 'variable))))))
725
726 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
727 ;;; DOES NOT generate code to initialize the value of the symbols,
728 ;;; unlike let-binding-wrapper.
729 (defun let*-binding-wrapper (symbols body)
730   (when (null symbols)
731     (return-from let*-binding-wrapper body))
732   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
733                        (remove-if-not #'special-variable-p symbols))))
734     `(code
735       "try {"
736       (code
737        ,@(mapcar (lambda (b)
738                    (let ((s (ls-compile `(quote ,(car b)))))
739                      `(code "var " ,(cdr b) " = " ,s ".value;" )))
740                  store)
741        ,body)
742       "}"
743       "finally {"
744       (code
745        ,@(mapcar (lambda (b)
746                    (let ((s (ls-compile `(quote ,(car b)))))
747                      `(code ,s ".value" " = " ,(cdr b) ";" )))
748                  store))
749       "}" )))
750
751 (define-compilation let* (bindings &rest body)
752   (let ((bindings (mapcar #'ensure-list bindings))
753         (*environment* (copy-lexenv *environment*)))
754     (js!selfcall
755       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
756             (body `(code ,@(mapcar #'let*-initialize-value bindings)
757                          ,(ls-compile-block body t t))))
758         (let*-binding-wrapper specials body)))))
759
760
761 (define-compilation block (name &rest body)
762   ;; We use Javascript exceptions to implement non local control
763   ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
764   ;; generated object to identify the block. The instance of a empty
765   ;; array is used to distinguish between nested dynamic Javascript
766   ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
767   ;; futher details.
768   (let* ((idvar (gvarname name))
769          (b (make-binding :name name :type 'block :value idvar)))
770     (when *multiple-value-p*
771       (push 'multiple-value (binding-declarations b)))
772     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
773            (cbody (ls-compile-block body t)))
774       (if (member 'used (binding-declarations b))
775           (js!selfcall
776             "try {"
777             "var " idvar " = [];"
778             `(code ,cbody)
779             "}"
780             "catch (cf){"
781             "    if (cf.type == 'block' && cf.id == " idvar ")"
782             (if *multiple-value-p*
783                 "        return values.apply(this, forcemv(cf.values));"
784                 "        return cf.values;")
785
786             "    else"
787             "        throw cf;"
788             "}" )
789           (js!selfcall cbody)))))
790
791 (define-compilation return-from (name &optional value)
792   (let* ((b (lookup-in-lexenv name *environment* 'block))
793          (multiple-value-p (member 'multiple-value (binding-declarations b))))
794     (when (null b)
795       (error "Return from unknown block `~S'." (symbol-name name)))
796     (push 'used (binding-declarations b))
797     ;; The binding value is the name of a variable, whose value is the
798     ;; unique identifier of the block as exception. We can't use the
799     ;; variable name itself, because it could not to be unique, so we
800     ;; capture it in a closure.
801     (js!selfcall
802       (when multiple-value-p `(code "var values = mv;" ))
803       "throw ({"
804       "type: 'block', "
805       "id: " (binding-value b) ", "
806       "values: " (ls-compile value multiple-value-p) ", "
807       "message: 'Return from unknown block " (symbol-name name) ".'"
808       "})")))
809
810 (define-compilation catch (id &rest body)
811   (js!selfcall*
812     `(var (|id| ,(ls-compile id)))
813     `(try
814       ,(ls-compile-block body t))
815     `(catch (|cf|)
816        (if (and (== (get |cf| "type") "catch")
817                 (== (get |cf| "id") |id|))
818            ,(if *multiple-value-p*
819                 `(return (call (get |values| "apply")
820                                this
821                                (call |forcemv| (get |cf| "values"))))
822                 `(return (call (get |pv| "apply")
823                                this
824                                (call |forcemv| (get |cf| "values")))))
825            (throw |cf|)))))
826
827 (define-compilation throw (id value)
828   (js!selfcall*
829     `(var (|values| |mv|))
830     `(throw (object
831              |type| "catch"
832              |id| ,(ls-compile id)
833              |values| ,(ls-compile value t)
834              |message| "Throw uncatched."))))
835
836 (defun go-tag-p (x)
837   (or (integerp x) (symbolp x)))
838
839 (defun declare-tagbody-tags (tbidx body)
840   (let* ((go-tag-counter 0)
841          (bindings
842           (mapcar (lambda (label)
843                     (let ((tagidx (integer-to-string (incf go-tag-counter))))
844                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
845                   (remove-if-not #'go-tag-p body))))
846     (extend-lexenv bindings *environment* 'gotag)))
847
848 (define-compilation tagbody (&rest body)
849   ;; Ignore the tagbody if it does not contain any go-tag. We do this
850   ;; because 1) it is easy and 2) many built-in forms expand to a
851   ;; implicit tagbody, so we save some space.
852   (unless (some #'go-tag-p body)
853     (return-from tagbody (ls-compile `(progn ,@body nil))))
854   ;; The translation assumes the first form in BODY is a label
855   (unless (go-tag-p (car body))
856     (push (gensym "START") body))
857   ;; Tagbody compilation
858   (let ((branch (gvarname 'branch))
859         (tbidx (gvarname 'tbidx)))
860     (let ((*environment* (declare-tagbody-tags tbidx body))
861           initag)
862       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
863         (setq initag (second (binding-value b))))
864       (js!selfcall
865         ;; TAGBODY branch to take
866         "var " branch " = " initag ";"
867         "var " tbidx " = [];"
868         "tbloop:"
869         "while (true) {"
870         `(code "try {"
871                ,(let ((content nil))
872                   `(code "switch(" ,branch "){"
873                         "case " ,initag ":"
874                         ,@(dolist (form (cdr body) (reverse content))
875                           (push (if (not (go-tag-p form))
876                                     `(code ,(ls-compile form) ";" )
877                                     (let ((b (lookup-in-lexenv form *environment* 'gotag)))
878                                       `(code "case " ,(second (binding-value b)) ":" )))
879                                 content))
880                            "default:"
881                            "    break tbloop;"
882                            "}" ))
883                "}"
884                "catch (jump) {"
885                "    if (jump.type == 'tagbody' && jump.id == " ,tbidx ")"
886                "        " ,branch " = jump.label;"
887                "    else"
888                "        throw(jump);"
889                "}" )
890         "}"
891         "return " (ls-compile nil) ";" ))))
892
893 (define-compilation go (label)
894   (let ((b (lookup-in-lexenv label *environment* 'gotag))
895         (n (cond
896              ((symbolp label) (symbol-name label))
897              ((integerp label) (integer-to-string label)))))
898     (when (null b)
899       (error "Unknown tag `~S'" label))
900     (js!selfcall
901       "throw ({"
902       "type: 'tagbody', "
903       "id: " (first (binding-value b)) ", "
904       "label: " (second (binding-value b)) ", "
905       "message: 'Attempt to GO to non-existing tag " n "'"
906       "})" )))
907
908 (define-compilation unwind-protect (form &rest clean-up)
909   (js!selfcall*
910     `(var (|ret| ,(ls-compile nil)))
911     `(try
912        (= |ret| ,(ls-compile form)))
913     `(finally
914       ,(ls-compile-block clean-up))
915     `(return |ret|)))
916
917 (define-compilation multiple-value-call (func-form &rest forms)
918   (js!selfcall
919     "var func = " (ls-compile func-form) ";"
920     "var args = [" (if *multiple-value-p* "values" "pv") ", 0];"
921     "return "
922     (js!selfcall
923       "var values = mv;"
924       "var vs;"
925       `(code
926         ,@(mapcar (lambda (form)
927                     `(code "vs = " ,(ls-compile form t) ";"
928                            "if (typeof vs === 'object' && 'multiple-value' in vs)"
929                            (code " args = args.concat(vs);" )
930                            " else "
931                            (code "args.push(vs);" )))
932                   forms))
933       "args[1] = args.length-2;"
934       "return func.apply(window, args);" ) ";" ))
935
936 (define-compilation multiple-value-prog1 (first-form &rest forms)
937   (js!selfcall
938     "var args = " (ls-compile first-form *multiple-value-p*) ";"
939     (ls-compile-block forms)
940     "return args;" ))
941
942 (define-transformation backquote (form)
943   (bq-completely-process form))
944
945
946 ;;; Primitives
947
948 (defvar *builtins* nil)
949
950 (defmacro define-raw-builtin (name args &body body)
951   ;; Creates a new primitive function `name' with parameters args and
952   ;; @body. The body can access to the local environment through the
953   ;; variable *ENVIRONMENT*.
954   `(push (list ',name (lambda ,args (block ,name ,@body)))
955          *builtins*))
956
957 (defmacro define-builtin (name args &body body)
958   `(define-raw-builtin ,name ,args
959      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
960        ,@body)))
961
962 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
963 (defmacro type-check (decls &body body)
964   `(js!selfcall
965      ,@(mapcar (lambda (decl)
966                  `(let ((name ,(first decl))
967                         (value ,(third decl)))
968                     `(code "var " ,name " = " ,value ";" )))
969                decls)
970      ,@(mapcar (lambda (decl)
971                  `(let ((name ,(first decl))
972                         (type ,(second decl)))
973                     `(code "if (typeof " ,name " != '" ,type "')"
974                            (code "throw 'The value ' + "
975                                  ,name
976                                  " + ' is not a type "
977                                  ,type
978                                  ".';"
979                                  ))))
980                decls)
981      `(code "return " ,,@body ";" )))
982
983 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
984 ;;; a variable which holds a list of forms. It will compile them and
985 ;;; store the result in some Javascript variables. BODY is evaluated
986 ;;; with ARGS bound to the list of these variables to generate the
987 ;;; code which performs the transformation on these variables.
988
989 (defun variable-arity-call (args function)
990   (unless (consp args)
991     (error "ARGS must be a non-empty list"))
992   (let ((counter 0)
993         (fargs '())
994         (prelude '()))
995     (dolist (x args)
996       (cond
997         ((or (floatp x) (numberp x)) (push x fargs))
998         (t (let ((v (make-symbol (code "x" (incf counter)))))
999              (push v fargs)
1000              (push `(code "var " ,v " = " ,(ls-compile x) ";"
1001                           "if (typeof " ,v " !== 'number') throw 'Not a number!';")
1002                    prelude)))))
1003     (js!selfcall
1004       `(code ,@(reverse prelude))
1005       (funcall function (reverse fargs)))))
1006
1007
1008 (defmacro variable-arity (args &body body)
1009   (unless (symbolp args)
1010     (error "`~S' is not a symbol." args))
1011   `(variable-arity-call ,args
1012                         (lambda (,args)
1013                           `(code "return " ,,@body ";" ))))
1014
1015 (defun num-op-num (x op y)
1016   (type-check (("x" "number" x) ("y" "number" y))
1017     `(code "x" ,op "y")))
1018
1019 (define-raw-builtin + (&rest numbers)
1020   (if (null numbers)
1021       0
1022       (variable-arity numbers
1023         `(+ ,@numbers))))
1024
1025 (define-raw-builtin - (x &rest others)
1026   (let ((args (cons x others)))
1027     (variable-arity args `(- ,@args))))
1028
1029 (define-raw-builtin * (&rest numbers)
1030   (if (null numbers)
1031       1
1032       (variable-arity numbers `(* ,@numbers))))
1033
1034 (define-raw-builtin / (x &rest others)
1035   (let ((args (cons x others)))
1036     (variable-arity args
1037       (if (null others)
1038           `(/ 1 ,(car args))
1039           (reduce (lambda (x y) `(/ ,x ,y))
1040                   args)))))
1041
1042 (define-builtin mod (x y) (num-op-num x "%" y))
1043
1044
1045 (defun comparison-conjuntion (vars op)
1046   (cond
1047     ((null (cdr vars))
1048      'true)
1049     ((null (cddr vars))
1050      `(,op ,(car vars) ,(cadr vars)))
1051     (t
1052      `(and (,op ,(car vars) ,(cadr vars))
1053            ,(comparison-conjuntion (cdr vars) op)))))
1054
1055 (defmacro define-builtin-comparison (op sym)
1056   `(define-raw-builtin ,op (x &rest args)
1057      (let ((args (cons x args)))
1058        (variable-arity args
1059          (js!bool (comparison-conjuntion args ',sym))))))
1060
1061 (define-builtin-comparison > >)
1062 (define-builtin-comparison < <)
1063 (define-builtin-comparison >= >=)
1064 (define-builtin-comparison <= <=)
1065 (define-builtin-comparison = ==)
1066 (define-builtin-comparison /= !=)
1067
1068 (define-builtin numberp (x)
1069   (js!bool `(== (typeof ,x) "number")))
1070
1071 (define-builtin floor (x)
1072   (type-check (("x" "number" x))
1073     "Math.floor(x)"))
1074
1075 (define-builtin expt (x y)
1076   (type-check (("x" "number" x)
1077                ("y" "number" y))
1078     "Math.pow(x, y)"))
1079
1080 (define-builtin float-to-string (x)
1081   (type-check (("x" "number" x))
1082     "make_lisp_string(x.toString())"))
1083
1084 (define-builtin cons (x y)
1085   `(object "car" ,x "cdr" ,y))
1086
1087 (define-builtin consp (x)
1088   (js!bool
1089    (js!selfcall
1090      "var tmp = " x ";"
1091      "return (typeof tmp == 'object' && 'car' in tmp);" )))
1092
1093 (define-builtin car (x)
1094   (js!selfcall*
1095     `(var (tmp ,x))
1096     `(return (if (=== tmp ,(ls-compile nil))
1097                  ,(ls-compile nil)
1098                  (get tmp "car")))))
1099
1100 (define-builtin cdr (x)
1101   (js!selfcall*
1102     `(var (tmp ,x))
1103     `(return (if (=== tmp ,(ls-compile nil))
1104                  ,(ls-compile nil)
1105                  (get tmp "cdr")))))
1106
1107 (define-builtin rplaca (x new)
1108   (type-check (("x" "object" x))
1109     `(code "(x.car = " ,new ", x)")))
1110
1111 (define-builtin rplacd (x new)
1112   (type-check (("x" "object" x))
1113     `(code "(x.cdr = " ,new ", x)")))
1114
1115 (define-builtin symbolp (x)
1116   (js!bool `(instanceof ,x |Symbol|)))
1117
1118 (define-builtin make-symbol (name)
1119   `(new (call |Symbol| ,name)))
1120
1121 (define-builtin symbol-name (x)
1122   `(get ,x "name"))
1123
1124 (define-builtin set (symbol value)
1125   `(= (get ,symbol "value") ,value))
1126
1127 (define-builtin fset (symbol value)
1128   `(= (get ,symbol "fvalue") ,value))
1129
1130 (define-builtin boundp (x)
1131   (js!bool `(!== (get ,x "value") undefined)))
1132
1133 (define-builtin fboundp (x)
1134   (js!bool `(!== (get ,x "fvalue") undefined)))
1135
1136 (define-builtin symbol-value (x)
1137   (js!selfcall*
1138     `(var (symbol ,x)
1139           (value (get symbol "value")))
1140     `(if (=== value undefined)
1141          (throw (+ "Variable `" (call |xstring| (get symbol "name")) "' is unbound.")))
1142     `(return value)))
1143
1144 (define-builtin symbol-function (x)
1145   (js!selfcall*
1146     `(var (symbol ,x)
1147           (func (get symbol "fvalue")))
1148     `(if (=== func undefined)
1149          (throw (+ "Function `" (call |xstring| (get symbol "name")) "' is undefined.")))
1150     `(return func)))
1151
1152 (define-builtin symbol-plist (x)
1153   `(or (get ,x "plist") ,(ls-compile nil)))
1154
1155 (define-builtin lambda-code (x)
1156   `(call |make_lisp_string| (call (get ,x "toString"))))
1157
1158 (define-builtin eq (x y)
1159   (js!bool `(=== ,x ,y)))
1160
1161 (define-builtin char-code (x)
1162   (type-check (("x" "string" x))
1163     "char_to_codepoint(x)"))
1164
1165 (define-builtin code-char (x)
1166   (type-check (("x" "number" x))
1167     "char_from_codepoint(x)"))
1168
1169 (define-builtin characterp (x)
1170   (js!bool
1171    (js!selfcall*
1172      `(var (x ,x))
1173      `(return (and (== (typeof x) "string")
1174                    (or (== (get x "length") 1)
1175                        (== (get x "length") 2)))))))
1176
1177 (define-builtin char-upcase (x)
1178   `(call |safe_char_upcase| ,x))
1179
1180 (define-builtin char-downcase (x)
1181   `(call |safe_char_downcase| ,x))
1182
1183 (define-builtin stringp (x)
1184   (js!bool
1185    (js!selfcall*
1186      `(var (x ,x))
1187      `(return (and (and (===(typeof x) "object")
1188                         (in "length" x))
1189                    (== (get x "stringp") 1))))))
1190
1191 (define-raw-builtin funcall (func &rest args)
1192   (js!selfcall*
1193     `(var (f ,(ls-compile func)))
1194     `(return (call (if (=== (typeof f) "function")
1195                        f
1196                        (get f "fvalue"))
1197                    ,@(list* (if *multiple-value-p* '|values| '|pv|)
1198                             (length args)
1199                             (mapcar #'ls-compile args))))))
1200
1201 (define-raw-builtin apply (func &rest args)
1202   (if (null args)
1203       `(code "(" ,(ls-compile func) ")()")
1204       (let ((args (butlast args))
1205             (last (car (last args))))
1206         (js!selfcall
1207           "var f = " (ls-compile func) ";"
1208           "var args = [" `(code
1209                            ,@(interleave (list* (if *multiple-value-p* "values" "pv")
1210                                                 (integer-to-string (length args))
1211                                                 (mapcar #'ls-compile args))
1212                                          ", "))
1213           "];"
1214           "var tail = (" (ls-compile last) ");"
1215           "while (tail != " (ls-compile nil) "){"
1216           "    args.push(tail.car);"
1217           "    args[1] += 1;"
1218           "    tail = tail.cdr;"
1219           "}"
1220           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" ))))
1221
1222 (define-builtin js-eval (string)
1223   (if *multiple-value-p*
1224       (js!selfcall*
1225         `(var (v (call |globalEval| (call |xstring| ,string))))
1226         `(return (call (get |values| "apply") this (call |forcemv| v))))
1227       `(call |globalEval| (call |xstring| ,string))))
1228
1229 (define-builtin %throw (string)
1230   (js!selfcall* `(throw ,string)))
1231
1232 (define-builtin functionp (x)
1233   (js!bool `(=== (typeof ,x) "function")))
1234
1235 (define-builtin %write-string (x)
1236   `(call (get |lisp| "write") ,x))
1237
1238 (define-builtin /debug (x)
1239   `(call (get |console| "log") (call |xstring| ,x)))
1240
1241
1242 ;;; Storage vectors. They are used to implement arrays and (in the
1243 ;;; future) structures.
1244
1245 (define-builtin storage-vector-p (x)
1246   (js!bool
1247    (js!selfcall*
1248      `(var (x ,x))
1249      `(return (and (=== (typeof x) "object") (in "length" x))))))
1250
1251 (define-builtin make-storage-vector (n)
1252   (js!selfcall*
1253     `(var (r #()))
1254     `(= (get r "length") ,n)
1255     `(return r)))
1256
1257 (define-builtin storage-vector-size (x)
1258   `(get ,x "length"))
1259
1260 (define-builtin resize-storage-vector (vector new-size)
1261   `(= (get ,vector "length") ,new-size))
1262
1263 (define-builtin storage-vector-ref (vector n)
1264   (js!selfcall*
1265     `(var (x (property ,vector ,n)))
1266     `(if (=== x undefined) (throw "Out of range."))
1267     `(return x)))
1268
1269 (define-builtin storage-vector-set (vector n value)
1270   (js!selfcall*
1271     `(var (x ,vector))
1272     `(var (i ,n))
1273     `(if (or (< i 0) (>= i (get x "length")))
1274          (throw "Out of range."))
1275     `(return (= (property x i) ,value))))
1276
1277 (define-builtin concatenate-storage-vector (sv1 sv2)
1278   (js!selfcall*
1279     `(var (sv1 ,sv1))
1280     `(var (r (call (get sv1 "concat") ,sv2)))
1281     `(= (get r "type") (get sv1 "type"))
1282     `(= (get r "stringp") (get sv1 "stringp"))
1283     `(return r)))
1284
1285 (define-builtin get-internal-real-time ()
1286   `(call (get (new (call |Date|)) "getTime")))
1287
1288 (define-builtin values-array (array)
1289   (if *multiple-value-p*
1290       `(call (get |values| "apply") this ,array)
1291       `(call (get |pv| "apply") this ,array)))
1292
1293 (define-raw-builtin values (&rest args)
1294   (if *multiple-value-p*
1295       `(call |values| ,@(mapcar #'ls-compile args))
1296       `(call |pv| ,@(mapcar #'ls-compile args))))
1297
1298 ;;; Javascript FFI
1299
1300 (define-builtin new ()
1301   '(object))
1302
1303 (define-raw-builtin oget* (object key &rest keys)
1304   (js!selfcall*
1305     `(progn
1306        (var (tmp (property ,(ls-compile object) (call |xstring| ,(ls-compile key)))))
1307        ,@(mapcar (lambda (key)
1308                    `(progn
1309                       (if (=== tmp undefined) (return ,(ls-compile nil)))
1310                       (= tmp (property tmp (call |xstring| ,(ls-compile key))))))
1311                  keys))
1312     `(return (if (=== tmp undefined) ,(ls-compile nil) tmp))))
1313
1314 (define-raw-builtin oset* (value object key &rest keys)
1315   (let ((keys (cons key keys)))
1316     (js!selfcall*
1317       `(progn
1318          (var (obj ,(ls-compile object)))
1319          ,@(mapcar (lambda (key)
1320                      `(progn
1321                         (= obj (property obj (call |xstring| ,(ls-compile key))))
1322                         (if (=== object undefined)
1323                             (throw "Impossible to set object property."))))
1324                    (butlast keys))
1325          (var (tmp
1326                (= (property obj (call |xstring| ,(ls-compile (car (last keys)))))
1327                   ,(ls-compile value))))
1328          (return (if (=== tmp undefined)
1329                      ,(ls-compile nil)
1330                      tmp))))))
1331
1332 (define-raw-builtin oget (object key &rest keys)
1333   `(call |js_to_lisp| ,(ls-compile `(oget* ,object ,key ,@keys))))
1334
1335 (define-raw-builtin oset (value object key &rest keys)
1336   (ls-compile `(oset* (lisp-to-js ,value) ,object ,key ,@keys)))
1337
1338 (define-builtin objectp (x)
1339   (js!bool `(=== (typeof ,x) "object")))
1340
1341 (define-builtin lisp-to-js (x) `(call |lisp_to_js| ,x))
1342 (define-builtin js-to-lisp (x) `(call |js_to_lisp| ,x))
1343
1344
1345 (define-builtin in (key object)
1346   (js!bool `(in (call |xstring| ,key) ,object)))
1347
1348 (define-builtin map-for-in (function object)
1349   (js!selfcall*
1350     `(var (f ,function)
1351           (g (if (=== (typeof f) "function") f (get f "fvalue")))
1352           (o ,object))
1353     `(for-in (key o)
1354        (call g ,(if *multiple-value-p* '|values| '|pv|) 1 (get o "key")))
1355     `(return ,(ls-compile nil))))
1356
1357 (define-compilation %js-vref (var)
1358   `(call |js_to_lisp| ,(make-symbol var)))
1359
1360 (define-compilation %js-vset (var val)
1361   `(= ,(make-symbol var) (call |lisp_to_js| ,(ls-compile val))))
1362
1363 (define-setf-expander %js-vref (var)
1364   (let ((new-value (gensym)))
1365     (unless (stringp var)
1366       (error "`~S' is not a string." var))
1367     (values nil
1368             (list var)
1369             (list new-value)
1370             `(%js-vset ,var ,new-value)
1371             `(%js-vref ,var))))
1372
1373
1374 #-jscl
1375 (defvar *macroexpander-cache*
1376   (make-hash-table :test #'eq))
1377
1378 (defun !macro-function (symbol)
1379   (unless (symbolp symbol)
1380     (error "`~S' is not a symbol." symbol))
1381   (let ((b (lookup-in-lexenv symbol *environment* 'function)))
1382     (if (and b (eq (binding-type b) 'macro))
1383         (let ((expander (binding-value b)))
1384           (cond
1385             #-jscl
1386             ((gethash b *macroexpander-cache*)
1387              (setq expander (gethash b *macroexpander-cache*)))
1388             ((listp expander)
1389              (let ((compiled (eval expander)))
1390                ;; The list representation are useful while
1391                ;; bootstrapping, as we can dump the definition of the
1392                ;; macros easily, but they are slow because we have to
1393                ;; evaluate them and compile them now and again. So, let
1394                ;; us replace the list representation version of the
1395                ;; function with the compiled one.
1396                ;;
1397                #+jscl (setf (binding-value b) compiled)
1398                #-jscl (setf (gethash b *macroexpander-cache*) compiled)
1399                (setq expander compiled))))
1400           expander)
1401         nil)))
1402
1403 (defun !macroexpand-1 (form)
1404   (cond
1405     ((symbolp form)
1406      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1407        (if (and b (eq (binding-type b) 'macro))
1408            (values (binding-value b) t)
1409            (values form nil))))
1410     ((and (consp form) (symbolp (car form)))
1411      (let ((macrofun (!macro-function (car form))))
1412        (if macrofun
1413            (values (funcall macrofun (cdr form)) t)
1414            (values form nil))))
1415     (t
1416      (values form nil))))
1417
1418 (defun compile-funcall (function args)
1419   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1420          (arglist `(code "(" ,@(interleave (list* values-funcs
1421                                                   (integer-to-string (length args))
1422                                                   (mapcar #'ls-compile args))
1423                                            ", ")
1424                          ")")))
1425     (unless (or (symbolp function)
1426                 (and (consp function)
1427                      (member (car function) '(lambda oget))))
1428       (error "Bad function designator `~S'" function))
1429     (cond
1430       ((translate-function function)
1431        `(code ,(translate-function function) ,arglist))
1432       ((and (symbolp function)
1433             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1434             #-jscl t)
1435        `(code ,(ls-compile `',function) ".fvalue" ,arglist))
1436       #+jscl((symbolp function)
1437        `(code ,(ls-compile `#',function) ,arglist))
1438       ((and (consp function) (eq (car function) 'lambda))
1439        `(code ,(ls-compile `#',function) ,arglist))
1440       ((and (consp function) (eq (car function) 'oget))
1441        `(code ,(ls-compile function) ,arglist))
1442       (t
1443        (error "Bad function descriptor")))))
1444
1445 (defun ls-compile-block (sexps &optional return-last-p decls-allowed-p)
1446   (multiple-value-bind (sexps decls)
1447       (parse-body sexps :declarations decls-allowed-p)
1448     (declare (ignore decls))
1449     (if return-last-p
1450         `(code ,(ls-compile-block (butlast sexps) nil decls-allowed-p)
1451                "return " ,(ls-compile (car (last sexps)) *multiple-value-p*) ";")
1452         `(code
1453           ,@(interleave (mapcar #'ls-compile sexps) ";
1454 " *newline*)
1455           ";" ,*newline*))))
1456
1457 (defun ls-compile* (sexp &optional multiple-value-p)
1458   (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
1459     (when expandedp
1460       (return-from ls-compile* (ls-compile sexp multiple-value-p)))
1461     ;; The expression has been macroexpanded. Now compile it!
1462     (let ((*multiple-value-p* multiple-value-p))
1463       (cond
1464         ((symbolp sexp)
1465          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1466            (cond
1467              ((and b (not (member 'special (binding-declarations b))))
1468               (binding-value b))
1469              ((or (keywordp sexp)
1470                   (and b (member 'constant (binding-declarations b))))
1471               `(code ,(ls-compile `',sexp) ".value"))
1472              (t
1473               (ls-compile `(symbol-value ',sexp))))))
1474         ((or (integerp sexp) (floatp sexp) (characterp sexp) (stringp sexp) (arrayp sexp))
1475          (literal sexp))
1476         ((listp sexp)
1477          (let ((name (car sexp))
1478                (args (cdr sexp)))
1479            (cond
1480              ;; Special forms
1481              ((assoc name *compilations*)
1482               (let ((comp (second (assoc name *compilations*))))
1483                 (apply comp args)))
1484              ;; Built-in functions
1485              ((and (assoc name *builtins*)
1486                    (not (claimp name 'function 'notinline)))
1487               (let ((comp (second (assoc name *builtins*))))
1488                 (apply comp args)))
1489              (t
1490               (compile-funcall name args)))))
1491         (t
1492          (error "How should I compile `~S'?" sexp))))))
1493
1494 (defun ls-compile (sexp &optional multiple-value-p)
1495   `(code "(" ,(ls-compile* sexp multiple-value-p) ")"))
1496
1497
1498 (defvar *compile-print-toplevels* nil)
1499
1500 (defun truncate-string (string &optional (width 60))
1501   (let ((n (or (position #\newline string)
1502                (min width (length string)))))
1503     (subseq string 0 n)))
1504
1505 (defun convert-toplevel (sexp &optional multiple-value-p)
1506   (let ((*toplevel-compilations* nil))
1507     (cond
1508       ;; Non-empty toplevel progn
1509       ((and (consp sexp)
1510             (eq (car sexp) 'progn)
1511             (cdr sexp))
1512        `(progn
1513           ,@(mapcar (lambda (s) (convert-toplevel s t))
1514                     (cdr sexp))))
1515       (t
1516        (when *compile-print-toplevels*
1517          (let ((form-string (prin1-to-string sexp)))
1518            (format t "Compiling ~a..." (truncate-string form-string))))
1519        (let ((code (ls-compile sexp multiple-value-p)))
1520          `(code
1521            ,@(interleave (get-toplevel-compilations) ";
1522 " t)
1523            ,(when code
1524                   `(code ,code ";"))))))))
1525
1526 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1527   (with-output-to-string (*standard-output*)
1528     (js (convert-toplevel sexp multiple-value-p))))