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