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