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