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