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