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