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