Remove references to non-symbol literals
[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 #+common-lisp
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 ;; A very simple defstruct built on lists. It supports just slot with
91 ;; an optional default initform, and it will create a constructor,
92 ;; predicate and accessors for you.
93 (defmacro def!struct (name &rest slots)
94   (unless (symbolp name)
95     (error "It is not a full defstruct implementation."))
96   (let* ((name-string (symbol-name name))
97          (slot-descriptions
98           (mapcar (lambda (sd)
99                     (cond
100                       ((symbolp sd)
101                        (list sd))
102                       ((and (listp sd) (car sd) (cddr sd))
103                        sd)
104                       (t
105                        (error "Bad slot description `~S'." sd))))
106                   slots))
107          (predicate (intern (concat name-string "-P"))))
108     `(progn
109        ;; Constructor
110        (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
111          (list ',name ,@(mapcar #'car slot-descriptions)))
112        ;; Predicate
113        (defun ,predicate (x)
114          (and (consp x) (eq (car x) ',name)))
115        ;; Copier
116        (defun ,(intern (concat "COPY-" name-string)) (x)
117          (copy-list x))
118        ;; Slot accessors
119        ,@(with-collect
120           (let ((index 1))
121             (dolist (slot slot-descriptions)
122               (let* ((name (car slot))
123                      (accessor-name (intern (concat name-string "-" (string name)))))
124                 (collect
125                     `(defun ,accessor-name (x)
126                        (unless (,predicate x)
127                          (error "The object `~S' is not of type `~S'" x ,name-string))
128                        (nth ,index x)))
129                 ;; TODO: Implement this with a higher level
130                 ;; abstraction like defsetf or (defun (setf ..))
131                 (collect
132                     `(define-setf-expander ,accessor-name (x)
133                        (let ((object (gensym))
134                              (new-value (gensym)))
135                          (values (list object)
136                                  (list x)
137                                  (list new-value)
138                                  `(progn
139                                     (rplaca (nthcdr ,',index ,object) ,new-value) 
140                                     ,new-value)
141                                  `(,',accessor-name ,object)))))
142                 (incf index)))))
143        ',name)))
144
145
146 ;;; Environment
147
148 (def!struct binding
149   name
150   type
151   value
152   declarations)
153
154 (def!struct lexenv
155   variable
156   function
157   block
158   gotag)
159
160 (defun lookup-in-lexenv (name lexenv namespace)
161   (find name (ecase namespace
162                 (variable (lexenv-variable lexenv))
163                 (function (lexenv-function lexenv))
164                 (block    (lexenv-block    lexenv))
165                 (gotag    (lexenv-gotag    lexenv)))
166         :key #'binding-name))
167
168 (defun push-to-lexenv (binding lexenv namespace)
169   (ecase namespace
170     (variable (push binding (lexenv-variable lexenv)))
171     (function (push binding (lexenv-function lexenv)))
172     (block    (push binding (lexenv-block    lexenv)))
173     (gotag    (push binding (lexenv-gotag    lexenv)))))
174
175 (defun extend-lexenv (bindings lexenv namespace)
176   (let ((env (copy-lexenv lexenv)))
177     (dolist (binding (reverse bindings) env)
178       (push-to-lexenv binding env namespace))))
179
180
181 (defvar *environment* (make-lexenv))
182
183 (defvar *variable-counter* 0)
184
185 (defun gvarname (symbol)
186   (declare (ignore symbol))
187   (code "v" (incf *variable-counter*)))
188
189 (defun translate-variable (symbol)
190   (awhen (lookup-in-lexenv symbol *environment* 'variable)
191     (binding-value it)))
192
193 (defun extend-local-env (args)
194   (let ((new (copy-lexenv *environment*)))
195     (dolist (symbol args new)
196       (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
197         (push-to-lexenv b new 'variable)))))
198
199 ;;; Toplevel compilations
200 (defvar *toplevel-compilations* nil)
201
202 (defun toplevel-compilation (string)
203   (push string *toplevel-compilations*))
204
205 (defun null-or-empty-p (x)
206   (zerop (length x)))
207
208 (defun get-toplevel-compilations ()
209   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
210
211 (defun %compile-defmacro (name lambda)
212   (toplevel-compilation (ls-compile `',name))
213   (let ((binding (make-binding :name name :type 'macro :value lambda)))
214     (push-to-lexenv binding  *environment* 'function))
215   name)
216
217 (defun global-binding (name type namespace)
218   (or (lookup-in-lexenv name *environment* namespace)
219       (let ((b (make-binding :name name :type type :value nil)))
220         (push-to-lexenv b *environment* namespace)
221         b)))
222
223 (defun claimp (symbol namespace claim)
224   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
225     (and b (member claim (binding-declarations b)))))
226
227 (defun !proclaim (decl)
228   (case (car decl)
229     (special
230      (dolist (name (cdr decl))
231        (let ((b (global-binding name 'variable 'variable)))
232          (push 'special (binding-declarations b)))))
233     (notinline
234      (dolist (name (cdr decl))
235        (let ((b (global-binding name 'function 'function)))
236          (push 'notinline (binding-declarations b)))))
237     (constant
238      (dolist (name (cdr decl))
239        (let ((b (global-binding name 'variable 'variable)))
240          (push 'constant (binding-declarations b)))))))
241
242 #+jscl
243 (fset 'proclaim #'!proclaim)
244
245 (defun %define-symbol-macro (name expansion)
246   (let ((b (make-binding :name name :type 'macro :value expansion)))
247     (push-to-lexenv b *environment* 'variable)
248     name))
249
250 #+jscl
251 (defmacro define-symbol-macro (name expansion)
252   `(%define-symbol-macro ',name ',expansion))
253
254
255 ;;; Special forms
256
257 (defvar *compilations* nil)
258
259 (defmacro define-compilation (name args &body body)
260   ;; Creates a new primitive `name' with parameters args and
261   ;; @body. The body can access to the local environment through the
262   ;; variable *ENVIRONMENT*.
263   `(push (list ',name (lambda ,args (block ,name ,@body)))
264          *compilations*))
265
266 (define-compilation if (condition true false)
267   (code "(" (ls-compile condition) " !== " (ls-compile nil)
268         " ? " (ls-compile true *multiple-value-p*)
269         " : " (ls-compile false *multiple-value-p*)
270         ")"))
271
272 (defvar *ll-keywords* '(&optional &rest &key))
273
274 (defun list-until-keyword (list)
275   (if (or (null list) (member (car list) *ll-keywords*))
276       nil
277       (cons (car list) (list-until-keyword (cdr list)))))
278
279 (defun ll-section (keyword ll)
280   (list-until-keyword (cdr (member keyword ll))))
281
282 (defun ll-required-arguments (ll)
283   (list-until-keyword ll))
284
285 (defun ll-optional-arguments-canonical (ll)
286   (mapcar #'ensure-list (ll-section '&optional ll)))
287
288 (defun ll-optional-arguments (ll)
289   (mapcar #'car (ll-optional-arguments-canonical ll)))
290
291 (defun ll-rest-argument (ll)
292   (let ((rest (ll-section '&rest ll)))
293     (when (cdr rest)
294       (error "Bad lambda-list `~S'." ll))
295     (car rest)))
296
297 (defun ll-keyword-arguments-canonical (ll)
298   (flet ((canonicalize (keyarg)
299            ;; Build a canonical keyword argument descriptor, filling
300            ;; the optional fields. The result is a list of the form
301            ;; ((keyword-name var) init-form).
302            (let ((arg (ensure-list keyarg)))
303              (cons (if (listp (car arg))
304                        (car arg)
305                        (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
306                    (cdr arg)))))
307     (mapcar #'canonicalize (ll-section '&key ll))))
308
309 (defun ll-keyword-arguments (ll)
310   (mapcar (lambda (keyarg) (second (first keyarg)))
311           (ll-keyword-arguments-canonical ll)))
312
313 (defun ll-svars (lambda-list)
314   (let ((args
315          (append
316           (ll-keyword-arguments-canonical lambda-list)
317           (ll-optional-arguments-canonical lambda-list))))
318     (remove nil (mapcar #'third args))))
319
320 (defun lambda-name/docstring-wrapper (name docstring &rest strs)
321   (if (or name docstring)
322       (js!selfcall
323         "var func = " (join strs) ";" *newline*
324         (when name
325           (code "func.fname = '" (escape-string name) "';" *newline*))
326         (when docstring
327           (code "func.docstring = '" (escape-string docstring) "';" *newline*))
328         "return func;" *newline*)
329       (apply #'code strs)))
330
331 (defun lambda-check-argument-count
332     (n-required-arguments n-optional-arguments rest-p)
333   ;; Note: Remember that we assume that the number of arguments of a
334   ;; call is at least 1 (the values argument).
335   (let ((min n-required-arguments)
336         (max (if rest-p 'n/a (+ n-required-arguments n-optional-arguments))))
337     (block nil
338       ;; Special case: a positive exact number of arguments.
339       (when (and (< 0 min) (eql min max))
340         (return (code "checkArgs(nargs, " min ");" *newline*)))
341       ;; General case:
342       (code
343        (when (< 0 min)
344          (code "checkArgsAtLeast(nargs, " min ");" *newline*))
345        (when (numberp max)
346          (code "checkArgsAtMost(nargs, " max ");" *newline*))))))
347
348 (defun compile-lambda-optional (ll)
349   (let* ((optional-arguments (ll-optional-arguments-canonical ll))
350          (n-required-arguments (length (ll-required-arguments ll)))
351          (n-optional-arguments (length optional-arguments)))
352     (when optional-arguments
353       (code "switch(nargs){" *newline*
354             (let ((cases nil)
355                   (idx 0))
356               (progn
357                 (while (< idx n-optional-arguments)
358                   (let ((arg (nth idx optional-arguments)))
359                     (push (code "case " (+ idx n-required-arguments) ":" *newline*
360                                 (indent (translate-variable (car arg))
361                                         "="
362                                         (ls-compile (cadr arg)) ";" *newline*)
363                                 (when (third arg)
364                                   (indent (translate-variable (third arg))
365                                           "="
366                                           (ls-compile nil)
367                                           ";" *newline*)))
368                           cases)
369                     (incf idx)))
370                 (push (code "default: break;" *newline*) cases)
371                 (join (reverse cases))))
372             "}" *newline*))))
373
374 (defun compile-lambda-rest (ll)
375   (let ((n-required-arguments (length (ll-required-arguments ll)))
376         (n-optional-arguments (length (ll-optional-arguments ll)))
377         (rest-argument (ll-rest-argument ll)))
378     (when rest-argument
379       (let ((js!rest (translate-variable rest-argument)))
380         (code "var " js!rest "= " (ls-compile nil) ";" *newline*
381               "for (var i = nargs-1; i>=" (+ n-required-arguments n-optional-arguments)
382               "; i--)" *newline*
383               (indent js!rest " = {car: arguments[i+2], cdr: " js!rest "};" *newline*))))))
384
385 (defun compile-lambda-parse-keywords (ll)
386   (let ((n-required-arguments
387          (length (ll-required-arguments ll)))
388         (n-optional-arguments
389          (length (ll-optional-arguments ll)))
390         (keyword-arguments
391          (ll-keyword-arguments-canonical ll)))
392     (code
393      ;; Declare variables
394      (mapconcat (lambda (arg)
395                   (let ((var (second (car arg))))
396                     (code "var " (translate-variable var) "; " *newline*
397                           (when (third arg)
398                             (code "var " (translate-variable (third arg))
399                                   " = " (ls-compile nil)
400                                   ";" *newline*)))))
401                 keyword-arguments)
402      ;; Parse keywords
403      (flet ((parse-keyword (keyarg)
404               ;; ((keyword-name var) init-form)
405               (code "for (i=" (+ n-required-arguments n-optional-arguments)
406                     "; i<nargs; i+=2){" *newline*
407                     (indent
408                      "if (arguments[i+2] === " (ls-compile (caar keyarg)) "){" *newline*
409                      (indent (translate-variable (cadr (car keyarg)))
410                              " = arguments[i+3];"
411                              *newline*
412                              (let ((svar (third keyarg)))
413                                (when svar
414                                  (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
415                              "break;" *newline*)
416                      "}" *newline*)
417                     "}" *newline*
418                     ;; Default value
419                     "if (i == nargs){" *newline*
420                     (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
421                     "}" *newline*)))
422        (when keyword-arguments
423          (code "var i;" *newline*
424                (mapconcat #'parse-keyword keyword-arguments))))
425      ;; Check for unknown keywords
426      (when keyword-arguments
427        (code "for (i=" (+ n-required-arguments n-optional-arguments)
428              "; i<nargs; i+=2){" *newline*
429              (indent "if ("
430                      (join (mapcar (lambda (x)
431                                      (concat "arguments[i+2] !== " (ls-compile (caar x))))
432                                    keyword-arguments)
433                            " && ")
434                      ")" *newline*
435                      (indent
436                       "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
437              "}" *newline*)))))
438
439 (defun parse-lambda-list (ll)
440   (values (ll-required-arguments ll)
441           (ll-optional-arguments ll)
442           (ll-keyword-arguments  ll)
443           (ll-rest-argument      ll)))
444
445 ;;; Process BODY for declarations and/or docstrings. Return as
446 ;;; multiple values the BODY without docstrings or declarations, the
447 ;;; list of declaration forms and the docstring.
448 (defun parse-body (body &key declarations docstring)
449   (let ((value-declarations)
450         (value-docstring))
451     ;; Parse declarations
452     (when declarations
453       (do* ((rest body (cdr rest))
454             (form (car rest) (car rest)))
455            ((or (atom form) (not (eq (car form) 'declare)))
456             (setf body rest))
457         (push form value-declarations)))
458     ;; Parse docstring
459     (when (and docstring
460                (stringp (car body))
461                (not (null (cdr body))))
462       (setq value-docstring (car body))
463       (setq body (cdr body)))
464     (values body value-declarations value-docstring)))
465
466 ;;; Compile a lambda function with lambda list LL and body BODY. If
467 ;;; NAME is given, it should be a constant string and it will become
468 ;;; the name of the function. If BLOCK is non-NIL, a named block is
469 ;;; created around the body. NOTE: No block (even anonymous) is
470 ;;; created if BLOCk is NIL.
471 (defun compile-lambda (ll body &key name block)
472   (multiple-value-bind (required-arguments
473                         optional-arguments
474                         keyword-arguments
475                         rest-argument)
476       (parse-lambda-list ll)
477     (multiple-value-bind (body decls documentation)
478         (parse-body body :declarations t :docstring t)
479       (declare (ignore decls))
480       (let ((n-required-arguments (length required-arguments))
481             (n-optional-arguments (length optional-arguments))
482             (*environment* (extend-local-env
483                             (append (ensure-list rest-argument)
484                                     required-arguments
485                                     optional-arguments
486                                     keyword-arguments
487                                     (ll-svars ll)))))
488         (lambda-name/docstring-wrapper name documentation
489          "(function ("
490          (join (list* "values"
491                       "nargs"
492                       (mapcar #'translate-variable
493                               (append required-arguments optional-arguments)))
494                ",")
495          "){" *newline*
496          (indent
497           ;; Check number of arguments
498           (lambda-check-argument-count n-required-arguments
499                                        n-optional-arguments
500                                        (or rest-argument keyword-arguments))
501                                         (compile-lambda-optional ll)
502                                         (compile-lambda-rest ll)
503                                         (compile-lambda-parse-keywords ll)
504                                         (let ((*multiple-value-p* t))
505                                           (if block
506                                               (ls-compile-block `((block ,block ,@body)) t)
507                                               (ls-compile-block body t))))
508          "})")))))
509
510
511 (defun setq-pair (var val)
512   (let ((b (lookup-in-lexenv var *environment* 'variable)))
513     (cond
514       ((and b
515             (eq (binding-type b) 'variable)
516             (not (member 'special (binding-declarations b)))
517             (not (member 'constant (binding-declarations b))))
518        (code (binding-value b) " = " (ls-compile val)))
519       ((and b (eq (binding-type b) 'macro))
520        (ls-compile `(setf ,var ,val)))
521       (t
522        (ls-compile `(set ',var ,val))))))
523
524
525 (define-compilation setq (&rest pairs)
526   (let ((result ""))
527     (while t
528       (cond
529         ((null pairs) (return))
530         ((null (cdr pairs))
531          (error "Odd pairs in SETQ"))
532         (t
533          (concatf result
534            (concat (setq-pair (car pairs) (cadr pairs))
535                    (if (null (cddr pairs)) "" ", ")))
536          (setq pairs (cddr pairs)))))
537     (code "(" result ")")))
538
539
540 ;;; Compilation of literals an object dumping
541
542 (defun escape-string (string)
543   (let ((output "")
544         (index 0)
545         (size (length string)))
546     (while (< index size)
547       (let ((ch (char string index)))
548         (when (or (char= ch #\") (char= ch #\\))
549           (setq output (concat output "\\")))
550         (when (or (char= ch #\newline))
551           (setq output (concat output "\\"))
552           (setq ch #\n))
553         (setq output (concat output (string ch))))
554       (incf index))
555     output))
556
557 (defvar *literal-table* nil)
558 (defvar *literal-counter* 0)
559
560 ;;; BOOTSTRAP MAGIC: During bootstrap, we record the macro definitions
561 ;;; as lists. Once everything is compiled, we want to dump the whole
562 ;;; global environment to the output file to reproduce it in the
563 ;;; run-time. However, the environment must contain expander functions
564 ;;; rather than lists. We do not know how to dump function objects
565 ;;; itself, so we mark the definitions with this object and the
566 ;;; compiler will be called when this object has to be dumped.
567 ;;; Backquote/unquote does a similar magic, but this use is exclusive.
568 (defvar *magic-unquote-marker* (gensym "MAGIC-UNQUOTE"))
569
570 (defun genlit ()
571   (code "l" (incf *literal-counter*)))
572
573 (defun dump-symbol (symbol)
574   #+common-lisp
575   (let ((package (symbol-package symbol)))
576     (if (eq package (find-package "KEYWORD"))
577         (code "{name: \"" (escape-string (symbol-name symbol))
578               "\", 'package': '" (package-name package) "'}")
579         (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")))
580   #+jscl
581   (let ((package (symbol-package symbol)))
582     (if (null package)
583         (code "{name: \"" (escape-string (symbol-name symbol)) "\"}")
584         (ls-compile `(intern ,(symbol-name symbol) ,(package-name package))))))
585
586 (defun dump-cons (cons)
587   (let ((head (butlast cons))
588         (tail (last cons)))
589     (code "QIList("
590           (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
591           (literal (car tail) t)
592           ","
593           (literal (cdr tail) t)
594           ")")))
595
596 (defun dump-array (array)
597   (let ((elements (vector-to-list array)))
598     (concat "[" (join (mapcar #'literal elements) ", ") "]")))
599
600 (defun literal (sexp &optional recursive)
601   (cond
602     ((integerp sexp) (integer-to-string sexp))
603     ((floatp sexp) (float-to-string sexp))
604     ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
605     ((stringp sexp) (code "\"" (escape-string sexp) "\""))
606     (t
607      (or (cdr (assoc sexp *literal-table*))
608          (let ((dumped (typecase sexp
609                          (symbol (dump-symbol sexp))
610                          (cons
611                           (if (eq (car sexp) *magic-unquote-marker*)
612                               (ls-compile (cdr sexp))
613                               (dump-cons sexp)))
614                          (array (dump-array sexp)))))
615            (if (and recursive (not (symbolp sexp)))
616                dumped
617                (let ((jsvar (genlit)))
618                  (push (cons sexp jsvar) *literal-table*)
619                  (toplevel-compilation (code "var " jsvar " = " dumped))
620                  jsvar)))))))
621
622
623 (define-compilation quote (sexp)
624   (literal sexp))
625
626 (define-compilation %while (pred &rest body)
627   (js!selfcall
628     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
629     (indent (ls-compile-block body))
630     "}"
631     "return " (ls-compile nil) ";" *newline*))
632
633 (define-compilation function (x)
634   (cond
635     ((and (listp x) (eq (car x) 'lambda))
636      (compile-lambda (cadr x) (cddr x)))
637     ((and (listp x) (eq (car x) 'named-lambda))
638      ;; TODO: destructuring-bind now! Do error checking manually is
639      ;; very annoying.
640      (let ((name (cadr x))
641            (ll (caddr x))
642            (body (cdddr x)))
643        (compile-lambda ll body
644                        :name (symbol-name name)
645                        :block name)))
646     ((symbolp x)
647      (let ((b (lookup-in-lexenv x *environment* 'function)))
648        (if b
649            (binding-value b)
650            (ls-compile `(symbol-function ',x)))))))
651
652
653 (defun make-function-binding (fname)
654   (make-binding :name fname :type 'function :value (gvarname fname)))
655
656 (defun compile-function-definition (list)
657   (compile-lambda (car list) (cdr list)))
658
659 (defun translate-function (name)
660   (let ((b (lookup-in-lexenv name *environment* 'function)))
661     (and b (binding-value b))))
662
663 (define-compilation flet (definitions &rest body)
664   (let* ((fnames (mapcar #'car definitions))
665          (cfuncs (mapcar (lambda (def)
666                            (compile-lambda (cadr def)
667                                            `((block ,(car def)
668                                                ,@(cddr def)))))
669                          definitions))
670          (*environment*
671           (extend-lexenv (mapcar #'make-function-binding fnames)
672                          *environment*
673                          'function)))
674     (code "(function("
675           (join (mapcar #'translate-function fnames) ",")
676           "){" *newline*
677           (let ((body (ls-compile-block body t)))
678             (indent body))
679           "})(" (join cfuncs ",") ")")))
680
681 (define-compilation labels (definitions &rest body)
682   (let* ((fnames (mapcar #'car definitions))
683          (*environment*
684           (extend-lexenv (mapcar #'make-function-binding fnames)
685                          *environment*
686                          'function)))
687     (js!selfcall
688       (mapconcat (lambda (func)
689                    (code "var " (translate-function (car func))
690                          " = " (compile-lambda (cadr func)
691                                                `((block ,(car func) ,@(cddr func))))
692                          ";" *newline*))
693                  definitions)
694       (ls-compile-block body t))))
695
696
697 (defvar *compiling-file* nil)
698 (define-compilation eval-when-compile (&rest body)
699   (if *compiling-file*
700       (progn
701         (eval (cons 'progn body))
702         nil)
703       (ls-compile `(progn ,@body))))
704
705 (defmacro define-transformation (name args form)
706   `(define-compilation ,name ,args
707      (ls-compile ,form)))
708
709 (define-compilation progn (&rest body)
710   (if (null (cdr body))
711       (ls-compile (car body) *multiple-value-p*)
712       (js!selfcall (ls-compile-block body t))))
713
714 (defun special-variable-p (x)
715   (and (claimp x 'variable 'special) t))
716
717 ;;; Wrap CODE to restore the symbol values of the dynamic
718 ;;; bindings. BINDINGS is a list of pairs of the form
719 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
720 ;;; name to initialize the symbol value and where to stored
721 ;;; the old value.
722 (defun let-binding-wrapper (bindings body)
723   (when (null bindings)
724     (return-from let-binding-wrapper body))
725   (code
726    "try {" *newline*
727    (indent "var tmp;" *newline*
728            (mapconcat
729             (lambda (b)
730               (let ((s (ls-compile `(quote ,(car b)))))
731                 (code "tmp = " s ".value;" *newline*
732                       s ".value = " (cdr b) ";" *newline*
733                       (cdr b) " = tmp;" *newline*)))
734             bindings)
735            body *newline*)
736    "}" *newline*
737    "finally {"  *newline*
738    (indent
739     (mapconcat (lambda (b)
740                  (let ((s (ls-compile `(quote ,(car b)))))
741                    (code s ".value" " = " (cdr b) ";" *newline*)))
742                bindings))
743    "}" *newline*))
744
745 (define-compilation let (bindings &rest body)
746   (let* ((bindings (mapcar #'ensure-list bindings))
747          (variables (mapcar #'first bindings))
748          (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
749          (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
750          (dynamic-bindings))
751     (code "(function("
752           (join (mapcar (lambda (x)
753                           (if (special-variable-p x)
754                               (let ((v (gvarname x)))
755                                 (push (cons x v) dynamic-bindings)
756                                 v)
757                               (translate-variable x)))
758                         variables)
759                 ",")
760           "){" *newline*
761           (let ((body (ls-compile-block body t)))
762             (indent (let-binding-wrapper dynamic-bindings body)))
763           "})(" (join cvalues ",") ")")))
764
765
766 ;;; Return the code to initialize BINDING, and push it extending the
767 ;;; current lexical environment if the variable is not special.
768 (defun let*-initialize-value (binding)
769   (let ((var (first binding))
770         (value (second binding)))
771     (if (special-variable-p var)
772         (code (ls-compile `(setq ,var ,value)) ";" *newline*)
773         (let* ((v (gvarname var))
774                (b (make-binding :name var :type 'variable :value v)))
775           (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
776             (push-to-lexenv b *environment* 'variable))))))
777
778 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
779 ;;; DOES NOT generate code to initialize the value of the symbols,
780 ;;; unlike let-binding-wrapper.
781 (defun let*-binding-wrapper (symbols body)
782   (when (null symbols)
783     (return-from let*-binding-wrapper body))
784   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
785                        (remove-if-not #'special-variable-p symbols))))
786     (code
787      "try {" *newline*
788      (indent
789       (mapconcat (lambda (b)
790                    (let ((s (ls-compile `(quote ,(car b)))))
791                      (code "var " (cdr b) " = " s ".value;" *newline*)))
792                  store)
793       body)
794      "}" *newline*
795      "finally {" *newline*
796      (indent
797       (mapconcat (lambda (b)
798                    (let ((s (ls-compile `(quote ,(car b)))))
799                      (code s ".value" " = " (cdr b) ";" *newline*)))
800                  store))
801      "}" *newline*)))
802
803 (define-compilation let* (bindings &rest body)
804   (let ((bindings (mapcar #'ensure-list bindings))
805         (*environment* (copy-lexenv *environment*)))
806     (js!selfcall
807       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
808             (body (concat (mapconcat #'let*-initialize-value bindings)
809                           (ls-compile-block body t))))
810         (let*-binding-wrapper specials body)))))
811
812
813 (define-compilation block (name &rest body)
814   ;; We use Javascript exceptions to implement non local control
815   ;; transfer. Exceptions has dynamic scoping, so we use a uniquely
816   ;; generated object to identify the block. The instance of a empty
817   ;; array is used to distinguish between nested dynamic Javascript
818   ;; exceptions. See https://github.com/davazp/jscl/issues/64 for
819   ;; futher details.
820   (let* ((idvar (gvarname name))
821          (b (make-binding :name name :type 'block :value idvar)))
822     (when *multiple-value-p*
823       (push 'multiple-value (binding-declarations b)))
824     (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
825            (cbody (ls-compile-block body t)))
826       (if (member 'used (binding-declarations b))
827           (js!selfcall
828             "try {" *newline*
829             "var " idvar " = [];" *newline*
830             (indent cbody)
831             "}" *newline*
832             "catch (cf){" *newline*
833             "    if (cf.type == 'block' && cf.id == " idvar ")" *newline*
834             (if *multiple-value-p*
835                 "        return values.apply(this, forcemv(cf.values));"
836                 "        return cf.values;")
837             *newline*
838             "    else" *newline*
839             "        throw cf;" *newline*
840             "}" *newline*)
841           (js!selfcall cbody)))))
842
843 (define-compilation return-from (name &optional value)
844   (let* ((b (lookup-in-lexenv name *environment* 'block))
845          (multiple-value-p (member 'multiple-value (binding-declarations b))))
846     (when (null b)
847       (error "Return from unknown block `~S'." (symbol-name name)))
848     (push 'used (binding-declarations b))
849     ;; The binding value is the name of a variable, whose value is the
850     ;; unique identifier of the block as exception. We can't use the
851     ;; variable name itself, because it could not to be unique, so we
852     ;; capture it in a closure.
853     (js!selfcall
854       (when multiple-value-p (code "var values = mv;" *newline*))
855       "throw ({"
856       "type: 'block', "
857       "id: " (binding-value b) ", "
858       "values: " (ls-compile value multiple-value-p) ", "
859       "message: 'Return from unknown block " (symbol-name name) ".'"
860       "})")))
861
862 (define-compilation catch (id &rest body)
863   (js!selfcall
864     "var id = " (ls-compile id) ";" *newline*
865     "try {" *newline*
866     (indent (ls-compile-block body t)) *newline*
867     "}" *newline*
868     "catch (cf){" *newline*
869     "    if (cf.type == 'catch' && cf.id == id)" *newline*
870     (if *multiple-value-p*
871         "        return values.apply(this, forcemv(cf.values));"
872         "        return pv.apply(this, forcemv(cf.values));")
873     *newline*
874     "    else" *newline*
875     "        throw cf;" *newline*
876     "}" *newline*))
877
878 (define-compilation throw (id value)
879   (js!selfcall
880     "var values = mv;" *newline*
881     "throw ({"
882     "type: 'catch', "
883     "id: " (ls-compile id) ", "
884     "values: " (ls-compile value t) ", "
885     "message: 'Throw uncatched.'"
886     "})"))
887
888 (defun go-tag-p (x)
889   (or (integerp x) (symbolp x)))
890
891 (defun declare-tagbody-tags (tbidx body)
892   (let* ((go-tag-counter 0)
893          (bindings
894           (mapcar (lambda (label)
895                     (let ((tagidx (integer-to-string (incf go-tag-counter))))
896                       (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
897                   (remove-if-not #'go-tag-p body))))
898     (extend-lexenv bindings *environment* 'gotag)))
899
900 (define-compilation tagbody (&rest body)
901   ;; Ignore the tagbody if it does not contain any go-tag. We do this
902   ;; because 1) it is easy and 2) many built-in forms expand to a
903   ;; implicit tagbody, so we save some space.
904   (unless (some #'go-tag-p body)
905     (return-from tagbody (ls-compile `(progn ,@body nil))))
906   ;; The translation assumes the first form in BODY is a label
907   (unless (go-tag-p (car body))
908     (push (gensym "START") body))
909   ;; Tagbody compilation
910   (let ((branch (gvarname 'branch))
911         (tbidx (gvarname 'tbidx)))
912     (let ((*environment* (declare-tagbody-tags tbidx body))
913           initag)
914       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
915         (setq initag (second (binding-value b))))
916       (js!selfcall
917         ;; TAGBODY branch to take
918         "var " branch " = " initag ";" *newline*
919         "var " tbidx " = [];" *newline*
920         "tbloop:" *newline*
921         "while (true) {" *newline*
922         (indent "try {" *newline*
923                 (indent (let ((content ""))
924                           (code "switch(" branch "){" *newline*
925                                 "case " initag ":" *newline*
926                                 (dolist (form (cdr body) content)
927                                   (concatf content
928                                     (if (not (go-tag-p form))
929                                         (indent (ls-compile form) ";" *newline*)
930                                         (let ((b (lookup-in-lexenv form *environment* 'gotag)))
931                                           (code "case " (second (binding-value b)) ":" *newline*)))))
932                                 "default:" *newline*
933                                 "    break tbloop;" *newline*
934                                 "}" *newline*)))
935                 "}" *newline*
936                 "catch (jump) {" *newline*
937                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
938                 "        " branch " = jump.label;" *newline*
939                 "    else" *newline*
940                 "        throw(jump);" *newline*
941                 "}" *newline*)
942         "}" *newline*
943         "return " (ls-compile nil) ";" *newline*))))
944
945 (define-compilation go (label)
946   (let ((b (lookup-in-lexenv label *environment* 'gotag))
947         (n (cond
948              ((symbolp label) (symbol-name label))
949              ((integerp label) (integer-to-string label)))))
950     (when (null b)
951       (error "Unknown tag `~S'" label))
952     (js!selfcall
953       "throw ({"
954       "type: 'tagbody', "
955       "id: " (first (binding-value b)) ", "
956       "label: " (second (binding-value b)) ", "
957       "message: 'Attempt to GO to non-existing tag " n "'"
958       "})" *newline*)))
959
960 (define-compilation unwind-protect (form &rest clean-up)
961   (js!selfcall
962     "var ret = " (ls-compile nil) ";" *newline*
963     "try {" *newline*
964     (indent "ret = " (ls-compile form) ";" *newline*)
965     "} finally {" *newline*
966     (indent (ls-compile-block clean-up))
967     "}" *newline*
968     "return ret;" *newline*))
969
970 (define-compilation multiple-value-call (func-form &rest forms)
971   (js!selfcall
972     "var func = " (ls-compile func-form) ";" *newline*
973     "var args = [" (if *multiple-value-p* "values" "pv") ", 0];" *newline*
974     "return "
975     (js!selfcall
976       "var values = mv;" *newline*
977       "var vs;" *newline*
978       (mapconcat (lambda (form)
979                    (code "vs = " (ls-compile form t) ";" *newline*
980                          "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
981                          (indent "args = args.concat(vs);" *newline*)
982                          "else" *newline*
983                          (indent "args.push(vs);" *newline*)))
984                  forms)
985       "args[1] = args.length-2;" *newline*
986       "return func.apply(window, args);" *newline*) ";" *newline*))
987
988 (define-compilation multiple-value-prog1 (first-form &rest forms)
989   (js!selfcall
990     "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
991     (ls-compile-block forms)
992     "return args;" *newline*))
993
994
995 ;;; Javascript FFI
996
997 (define-compilation %js-vref (var) var)
998
999 (define-compilation %js-vset (var val)
1000   (code "(" var " = " (ls-compile val) ")"))
1001
1002 (define-setf-expander %js-vref (var)
1003   (let ((new-value (gensym)))
1004     (unless (stringp var)
1005       (error "`~S' is not a string." var))
1006     (values nil
1007             (list var)
1008             (list new-value)
1009             `(%js-vset ,var ,new-value)
1010             `(%js-vref ,var))))
1011
1012
1013 ;;; Backquote implementation.
1014 ;;;
1015 ;;;    Author: Guy L. Steele Jr.     Date: 27 December 1985
1016 ;;;    Tested under Symbolics Common Lisp and Lucid Common Lisp.
1017 ;;;    This software is in the public domain.
1018
1019 ;;;    The following are unique tokens used during processing.
1020 ;;;    They need not be symbols; they need not even be atoms.
1021 (defvar *comma* 'unquote)
1022 (defvar *comma-atsign* 'unquote-splicing)
1023
1024 (defvar *bq-list* (make-symbol "BQ-LIST"))
1025 (defvar *bq-append* (make-symbol "BQ-APPEND"))
1026 (defvar *bq-list** (make-symbol "BQ-LIST*"))
1027 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
1028 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
1029 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
1030 (defvar *bq-quote-nil* (list *bq-quote* nil))
1031
1032 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
1033 ;;; the expression foo, looking for occurrences of #:COMMA,
1034 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT.  It constructs code in strict
1035 ;;; accordance with the rules on pages 349-350 of the first edition
1036 ;;; (pages 528-529 of this second edition).  It then optionally
1037 ;;; applies a code simplifier.
1038
1039 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
1040 ;;; processing applies the code simplifier.  If the value is NIL,
1041 ;;; then the code resulting from BACKQUOTE is exactly that
1042 ;;; specified by the official rules.
1043 (defparameter *bq-simplify* t)
1044
1045 (defmacro backquote (x)
1046   (bq-completely-process x))
1047
1048 ;;; Backquote processing proceeds in three stages:
1049 ;;;
1050 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
1051 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
1052 ;;; this level of BACKQUOTE.  (It also causes embedded calls to
1053 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
1054 ;;; Code is produced that is expressed in terms of functions
1055 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE.  This is done
1056 ;;; so that the simplifier will simplify only list construction
1057 ;;; functions actually generated by BACKQUOTE and will not involve
1058 ;;; any user code in the simplification.  #:BQ-LIST means LIST,
1059 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
1060 ;;; but indicates places where "%." was used and where NCONC may
1061 ;;; therefore be introduced by the simplifier for efficiency.
1062 ;;;
1063 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
1064 ;;; BQ-PROCESS to produce equivalent but faster code.  The
1065 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
1066 ;;; introduced into the code.
1067 ;;;
1068 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
1069 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
1070 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
1071 ;;; replaced by its argument).  #:BQ-LIST* is replaced by either
1072 ;;; LIST* or CONS (the latter is used in the two-argument case,
1073 ;;; purely to make the resulting code a tad more readable).
1074
1075 (defun bq-completely-process (x)
1076   (let ((raw-result (bq-process x)))
1077     (bq-remove-tokens (if *bq-simplify*
1078                           (bq-simplify raw-result)
1079                           raw-result))))
1080
1081 (defun bq-process (x)
1082   (cond ((atom x)
1083          (list *bq-quote* x))
1084         ((eq (car x) 'backquote)
1085          (bq-process (bq-completely-process (cadr x))))
1086         ((eq (car x) *comma*) (cadr x))
1087         ((eq (car x) *comma-atsign*)
1088          (error ",@~S after `" (cadr x)))
1089         ;; ((eq (car x) *comma-dot*)
1090         ;;  ;; (error ",.~S after `" (cadr x))
1091         ;;  (error "ill-formed"))
1092         (t (do ((p x (cdr p))
1093                 (q '() (cons (bracket (car p)) q)))
1094                ((atom p)
1095                 (cons *bq-append*
1096                       (nreconc q (list (list *bq-quote* p)))))
1097              (when (eq (car p) *comma*)
1098                (unless (null (cddr p))
1099                  (error "Malformed ,~S" p))
1100                (return (cons *bq-append*
1101                              (nreconc q (list (cadr p))))))
1102              (when (eq (car p) *comma-atsign*)
1103                (error "Dotted ,@~S" p))
1104              ;; (when (eq (car p) *comma-dot*)
1105              ;;   ;; (error "Dotted ,.~S" p)
1106              ;;   (error "Dotted"))
1107              ))))
1108
1109 ;;; This implements the bracket operator of the formal rules.
1110 (defun bracket (x)
1111   (cond ((atom x)
1112          (list *bq-list* (bq-process x)))
1113         ((eq (car x) *comma*)
1114          (list *bq-list* (cadr x)))
1115         ((eq (car x) *comma-atsign*)
1116          (cadr x))
1117         ;; ((eq (car x) *comma-dot*)
1118         ;;  (list *bq-clobberable* (cadr x)))
1119         (t (list *bq-list* (bq-process x)))))
1120
1121 ;;; This auxiliary function is like MAPCAR but has two extra
1122 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
1123 ;;; the result share with the argument x as much as possible.
1124 (defun maptree (fn x)
1125   (if (atom x)
1126       (funcall fn x)
1127       (let ((a (funcall fn (car x)))
1128             (d (maptree fn (cdr x))))
1129         (if (and (eql a (car x)) (eql d (cdr x)))
1130             x
1131             (cons a d)))))
1132
1133 ;;; This predicate is true of a form that when read looked
1134 ;;; like %@foo or %.foo.
1135 (defun bq-splicing-frob (x)
1136   (and (consp x)
1137        (or (eq (car x) *comma-atsign*)
1138            ;; (eq (car x) *comma-dot*)
1139            )))
1140
1141 ;;; This predicate is true of a form that when read
1142 ;;; looked like %@foo or %.foo or just plain %foo.
1143 (defun bq-frob (x)
1144   (and (consp x)
1145        (or (eq (car x) *comma*)
1146            (eq (car x) *comma-atsign*)
1147            ;; (eq (car x) *comma-dot*)
1148            )))
1149
1150 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
1151 ;;; tries to simplify them.  The arguments to #:BQ-APPEND are
1152 ;;; processed from right to left, building up a replacement form.
1153 ;;; At each step a number of special cases are handled that,
1154 ;;; loosely speaking, look like this:
1155 ;;;
1156 ;;;  (APPEND (LIST a b c) foo) => (LIST* a b c foo)
1157 ;;;       provided a, b, c are not splicing frobs
1158 ;;;  (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
1159 ;;;       provided a, b, c are not splicing frobs
1160 ;;;  (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
1161 ;;;  (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
1162 (defun bq-simplify (x)
1163   (if (atom x)
1164       x
1165       (let ((x (if (eq (car x) *bq-quote*)
1166                    x
1167                    (maptree #'bq-simplify x))))
1168         (if (not (eq (car x) *bq-append*))
1169             x
1170             (bq-simplify-args x)))))
1171
1172 (defun bq-simplify-args (x)
1173   (do ((args (reverse (cdr x)) (cdr args))
1174        (result
1175          nil
1176          (cond ((atom (car args))
1177                 (bq-attach-append *bq-append* (car args) result))
1178                ((and (eq (caar args) *bq-list*)
1179                      (notany #'bq-splicing-frob (cdar args)))
1180                 (bq-attach-conses (cdar args) result))
1181                ((and (eq (caar args) *bq-list**)
1182                      (notany #'bq-splicing-frob (cdar args)))
1183                 (bq-attach-conses
1184                   (reverse (cdr (reverse (cdar args))))
1185                   (bq-attach-append *bq-append*
1186                                     (car (last (car args)))
1187                                     result)))
1188                ((and (eq (caar args) *bq-quote*)
1189                      (consp (cadar args))
1190                      (not (bq-frob (cadar args)))
1191                      (null (cddar args)))
1192                 (bq-attach-conses (list (list *bq-quote*
1193                                               (caadar args)))
1194                                   result))
1195                ((eq (caar args) *bq-clobberable*)
1196                 (bq-attach-append *bq-nconc* (cadar args) result))
1197                (t (bq-attach-append *bq-append*
1198                                     (car args)
1199                                     result)))))
1200       ((null args) result)))
1201
1202 (defun null-or-quoted (x)
1203   (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
1204
1205 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
1206 ;;; or #:BQ-NCONC.  This produces a form (op item result) but
1207 ;;; some simplifications are done on the fly:
1208 ;;;
1209 ;;;  (op '(a b c) '(d e f g)) => '(a b c d e f g)
1210 ;;;  (op item 'nil) => item, provided item is not a splicable frob
1211 ;;;  (op item 'nil) => (op item), if item is a splicable frob
1212 ;;;  (op item (op a b c)) => (op item a b c)
1213 (defun bq-attach-append (op item result)
1214   (cond ((and (null-or-quoted item) (null-or-quoted result))
1215          (list *bq-quote* (append (cadr item) (cadr result))))
1216         ((or (null result) (equal result *bq-quote-nil*))
1217          (if (bq-splicing-frob item) (list op item) item))
1218         ((and (consp result) (eq (car result) op))
1219          (list* (car result) item (cdr result)))
1220         (t (list op item result))))
1221
1222 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
1223 ;;; `(LIST* ,@items ,result) but some simplifications are done
1224 ;;; on the fly.
1225 ;;;
1226 ;;;  (LIST* 'a 'b 'c 'd) => '(a b c . d)
1227 ;;;  (LIST* a b c 'nil) => (LIST a b c)
1228 ;;;  (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
1229 ;;;  (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
1230 (defun bq-attach-conses (items result)
1231   (cond ((and (every #'null-or-quoted items)
1232               (null-or-quoted result))
1233          (list *bq-quote*
1234                (append (mapcar #'cadr items) (cadr result))))
1235         ((or (null result) (equal result *bq-quote-nil*))
1236          (cons *bq-list* items))
1237         ((and (consp result)
1238               (or (eq (car result) *bq-list*)
1239                   (eq (car result) *bq-list**)))
1240          (cons (car result) (append items (cdr result))))
1241         (t (cons *bq-list** (append items (list result))))))
1242
1243 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
1244 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
1245 (defun bq-remove-tokens (x)
1246   (cond ((eq x *bq-list*) 'list)
1247         ((eq x *bq-append*) 'append)
1248         ((eq x *bq-nconc*) 'nconc)
1249         ((eq x *bq-list**) 'list*)
1250         ((eq x *bq-quote*) 'quote)
1251         ((atom x) x)
1252         ((eq (car x) *bq-clobberable*)
1253          (bq-remove-tokens (cadr x)))
1254         ((and (eq (car x) *bq-list**)
1255               (consp (cddr x))
1256               (null (cdddr x)))
1257          (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
1258         (t (maptree #'bq-remove-tokens x))))
1259
1260 (define-transformation backquote (form)
1261   (bq-completely-process form))
1262
1263
1264 ;;; Primitives
1265
1266 (defvar *builtins* nil)
1267
1268 (defmacro define-raw-builtin (name args &body body)
1269   ;; Creates a new primitive function `name' with parameters args and
1270   ;; @body. The body can access to the local environment through the
1271   ;; variable *ENVIRONMENT*.
1272   `(push (list ',name (lambda ,args (block ,name ,@body)))
1273          *builtins*))
1274
1275 (defmacro define-builtin (name args &body body)
1276   `(define-raw-builtin ,name ,args
1277      (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1278        ,@body)))
1279
1280 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1281 (defmacro type-check (decls &body body)
1282   `(js!selfcall
1283      ,@(mapcar (lambda (decl)
1284                  `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1285                decls)
1286      ,@(mapcar (lambda (decl)
1287                  `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1288                         (indent "throw 'The value ' + "
1289                                 ,(first decl)
1290                                 " + ' is not a type "
1291                                 ,(second decl)
1292                                 ".';"
1293                                 *newline*)))
1294                decls)
1295      (code "return " (progn ,@body) ";" *newline*)))
1296
1297 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1298 ;;; a variable which holds a list of forms. It will compile them and
1299 ;;; store the result in some Javascript variables. BODY is evaluated
1300 ;;; with ARGS bound to the list of these variables to generate the
1301 ;;; code which performs the transformation on these variables.
1302
1303 (defun variable-arity-call (args function)
1304   (unless (consp args)
1305     (error "ARGS must be a non-empty list"))
1306   (let ((counter 0)
1307         (fargs '())
1308         (prelude ""))
1309     (dolist (x args)
1310       (cond
1311         ((floatp x) (push (float-to-string x) fargs))
1312         ((numberp x) (push (integer-to-string x) fargs))
1313         (t (let ((v (code "x" (incf counter))))
1314              (push v fargs)
1315              (concatf prelude
1316                (code "var " v " = " (ls-compile x) ";" *newline*
1317                      "if (typeof " v " !== 'number') throw 'Not a number!';"
1318                      *newline*))))))
1319     (js!selfcall prelude (funcall function (reverse fargs)))))
1320
1321
1322 (defmacro variable-arity (args &body body)
1323   (unless (symbolp args)
1324     (error "`~S' is not a symbol." args))
1325   `(variable-arity-call ,args
1326                         (lambda (,args)
1327                           (code "return " ,@body ";" *newline*))))
1328
1329 (defun num-op-num (x op y)
1330   (type-check (("x" "number" x) ("y" "number" y))
1331     (code "x" op "y")))
1332
1333 (define-raw-builtin + (&rest numbers)
1334   (if (null numbers)
1335       "0"
1336       (variable-arity numbers
1337         (join numbers "+"))))
1338
1339 (define-raw-builtin - (x &rest others)
1340   (let ((args (cons x others)))
1341     (variable-arity args
1342       (if (null others)
1343           (concat "-" (car args))
1344           (join args "-")))))
1345
1346 (define-raw-builtin * (&rest numbers)
1347   (if (null numbers)
1348       "1"
1349       (variable-arity numbers
1350         (join numbers "*"))))
1351
1352 (define-raw-builtin / (x &rest others)
1353   (let ((args (cons x others)))
1354     (variable-arity args
1355       (if (null others)
1356           (concat "1 /" (car args))
1357           (join args "/")))))
1358
1359 (define-builtin mod (x y) (num-op-num x "%" y))
1360
1361
1362 (defun comparison-conjuntion (vars op)
1363   (cond
1364     ((null (cdr vars))
1365      "true")
1366     ((null (cddr vars))
1367      (concat (car vars) op (cadr vars)))
1368     (t
1369      (concat (car vars) op (cadr vars)
1370              " && "
1371              (comparison-conjuntion (cdr vars) op)))))
1372
1373 (defmacro define-builtin-comparison (op sym)
1374   `(define-raw-builtin ,op (x &rest args)
1375      (let ((args (cons x args)))
1376        (variable-arity args
1377          (js!bool (comparison-conjuntion args ,sym))))))
1378
1379 (define-builtin-comparison > ">")
1380 (define-builtin-comparison < "<")
1381 (define-builtin-comparison >= ">=")
1382 (define-builtin-comparison <= "<=")
1383 (define-builtin-comparison = "==")
1384
1385 (define-builtin numberp (x)
1386   (js!bool (code "(typeof (" x ") == \"number\")")))
1387
1388 (define-builtin floor (x)
1389   (type-check (("x" "number" x))
1390     "Math.floor(x)"))
1391
1392 (define-builtin expt (x y)
1393   (type-check (("x" "number" x)
1394                ("y" "number" y))
1395     "Math.pow(x, y)"))
1396
1397 (define-builtin float-to-string (x)
1398   (type-check (("x" "number" x))
1399     "x.toString()"))
1400
1401 (define-builtin cons (x y)
1402   (code "({car: " x ", cdr: " y "})"))
1403
1404 (define-builtin consp (x)
1405   (js!bool
1406    (js!selfcall
1407      "var tmp = " x ";" *newline*
1408      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1409
1410 (define-builtin car (x)
1411   (js!selfcall
1412     "var tmp = " x ";" *newline*
1413     "return tmp === " (ls-compile nil)
1414     "? " (ls-compile nil)
1415     ": tmp.car;" *newline*))
1416
1417 (define-builtin cdr (x)
1418   (js!selfcall
1419     "var tmp = " x ";" *newline*
1420     "return tmp === " (ls-compile nil) "? "
1421     (ls-compile nil)
1422     ": tmp.cdr;" *newline*))
1423
1424 (define-builtin rplaca (x new)
1425   (type-check (("x" "object" x))
1426     (code "(x.car = " new ", x)")))
1427
1428 (define-builtin rplacd (x new)
1429   (type-check (("x" "object" x))
1430     (code "(x.cdr = " new ", x)")))
1431
1432 (define-builtin symbolp (x)
1433   (js!bool
1434    (js!selfcall
1435      "var tmp = " x ";" *newline*
1436      "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1437
1438 (define-builtin make-symbol (name)
1439   (type-check (("name" "string" name))
1440     "({name: name})"))
1441
1442 (define-builtin symbol-name (x)
1443   (code "(" x ").name"))
1444
1445 (define-builtin set (symbol value)
1446   (code "(" symbol ").value = " value))
1447
1448 (define-builtin fset (symbol value)
1449   (code "(" symbol ").fvalue = " value))
1450
1451 (define-builtin boundp (x)
1452   (js!bool (code "(" x ".value !== undefined)")))
1453
1454 (define-builtin symbol-value (x)
1455   (js!selfcall
1456     "var symbol = " x ";" *newline*
1457     "var value = symbol.value;" *newline*
1458     "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1459     "return value;" *newline*))
1460
1461 (define-builtin symbol-function (x)
1462   (js!selfcall
1463     "var symbol = " x ";" *newline*
1464     "var func = symbol.fvalue;" *newline*
1465     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1466     "return func;" *newline*))
1467
1468 (define-builtin symbol-plist (x)
1469   (code "((" x ").plist || " (ls-compile nil) ")"))
1470
1471 (define-builtin lambda-code (x)
1472   (code "(" x ").toString()"))
1473
1474 (define-builtin eq (x y)
1475   (js!bool (code "(" x " === " y ")")))
1476
1477 (define-builtin char-code (x)
1478   (type-check (("x" "string" x))
1479     "x.charCodeAt(0)"))
1480
1481 (define-builtin code-char (x)
1482   (type-check (("x" "number" x))
1483     "String.fromCharCode(x)"))
1484
1485 (define-builtin characterp (x)
1486   (js!bool
1487    (js!selfcall
1488      "var x = " x ";" *newline*
1489      "return (typeof(" x ") == \"string\") && x.length == 1;")))
1490
1491 (define-builtin char-to-string (x)
1492   (type-check (("x" "string" x))
1493     "(x)"))
1494
1495 (define-builtin stringp (x)
1496   (js!bool (code "(typeof(" x ") == \"string\")")))
1497
1498 (define-builtin string-upcase (x)
1499   (type-check (("x" "string" x))
1500     "x.toUpperCase()"))
1501
1502 (define-builtin string-length (x)
1503   (type-check (("x" "string" x))
1504     "x.length"))
1505
1506 (define-raw-builtin slice (string a &optional b)
1507   (js!selfcall
1508     "var str = " (ls-compile string) ";" *newline*
1509     "var a = " (ls-compile a) ";" *newline*
1510     "var b;" *newline*
1511     (when b (code "b = " (ls-compile b) ";" *newline*))
1512     "return str.slice(a,b);" *newline*))
1513
1514 (define-builtin char (string index)
1515   (type-check (("string" "string" string)
1516                ("index" "number" index))
1517     "string.charAt(index)"))
1518
1519 (define-builtin concat-two (string1 string2)
1520   (type-check (("string1" "string" string1)
1521                ("string2" "string" string2))
1522     "string1.concat(string2)"))
1523
1524 (define-raw-builtin funcall (func &rest args)
1525   (js!selfcall
1526     "var f = " (ls-compile func) ";" *newline*
1527     "return (typeof f === 'function'? f: f.fvalue)("
1528     (join (list* (if *multiple-value-p* "values" "pv")
1529                  (integer-to-string (length args))
1530                  (mapcar #'ls-compile args))
1531           ", ")
1532     ")"))
1533
1534 (define-raw-builtin apply (func &rest args)
1535   (if (null args)
1536       (code "(" (ls-compile func) ")()")
1537       (let ((args (butlast args))
1538             (last (car (last args))))
1539         (js!selfcall
1540           "var f = " (ls-compile func) ";" *newline*
1541           "var args = [" (join (list* (if *multiple-value-p* "values" "pv")
1542                                       (integer-to-string (length args))
1543                                       (mapcar #'ls-compile args))
1544                                ", ")
1545           "];" *newline*
1546           "var tail = (" (ls-compile last) ");" *newline*
1547           "while (tail != " (ls-compile nil) "){" *newline*
1548           "    args.push(tail.car);" *newline*
1549           "    args[1] += 1;" *newline*
1550           "    tail = tail.cdr;" *newline*
1551           "}" *newline*
1552           "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
1553
1554 (define-builtin js-eval (string)
1555   (type-check (("string" "string" string))
1556     (if *multiple-value-p*
1557         (js!selfcall
1558           "var v = globalEval(string);" *newline*
1559           "return values.apply(this, forcemv(v));" *newline*)
1560         "globalEval(string)")))
1561
1562 (define-builtin %throw (string)
1563   (js!selfcall "throw " string ";" *newline*))
1564
1565 (define-builtin new () "{}")
1566
1567 (define-builtin objectp (x)
1568   (js!bool (code "(typeof (" x ") === 'object')")))
1569
1570 (define-builtin oget (object key)
1571   (js!selfcall
1572     "var tmp = " "(" object ")[" key "];" *newline*
1573     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1574
1575 (define-builtin oset (object key value)
1576   (code "((" object ")[" key "] = " value ")"))
1577
1578 (define-builtin in (key object)
1579   (js!bool (code "((" key ") in (" object "))")))
1580
1581 (define-builtin functionp (x)
1582   (js!bool (code "(typeof " x " == 'function')")))
1583
1584 (define-builtin write-string (x)
1585   (type-check (("x" "string" x))
1586     "lisp.write(x)"))
1587
1588 (define-builtin make-array (n)
1589   (js!selfcall
1590     "var r = [];" *newline*
1591     "for (var i = 0; i < " n "; i++)" *newline*
1592     (indent "r.push(" (ls-compile nil) ");" *newline*)
1593     "return r;" *newline*))
1594
1595 (define-builtin arrayp (x)
1596   (js!bool
1597    (js!selfcall
1598      "var x = " x ";" *newline*
1599      "return typeof x === 'object' && 'length' in x;")))
1600
1601 (define-builtin aref (array n)
1602   (js!selfcall
1603     "var x = " "(" array ")[" n "];" *newline*
1604     "if (x === undefined) throw 'Out of range';" *newline*
1605     "return x;" *newline*))
1606
1607 (define-builtin aset (array n value)
1608   (js!selfcall
1609     "var x = " array ";" *newline*
1610     "var i = " n ";" *newline*
1611     "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1612     "return x[i] = " value ";" *newline*))
1613
1614 (define-builtin get-internal-real-time ()
1615   "(new Date()).getTime()")
1616
1617 (define-builtin values-array (array)
1618   (if *multiple-value-p*
1619       (code "values.apply(this, " array ")")
1620       (code "pv.apply(this, " array ")")))
1621
1622 (define-raw-builtin values (&rest args)
1623   (if *multiple-value-p*
1624       (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
1625       (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1626
1627 ;; Receives the JS function as first argument as a literal string. The
1628 ;; second argument is compiled and should evaluate to a vector of
1629 ;; values to apply to the the function. The result returned.
1630 (define-builtin %js-call (fun args)
1631   (code fun ".apply(this, " args ")"))
1632
1633 #+common-lisp
1634 (defvar *macroexpander-cache*
1635   (make-hash-table :test #'eq))
1636
1637 (defun !macro-function (symbol)
1638   (unless (symbolp symbol)
1639     (error "`~S' is not a symbol." symbol))
1640   (let ((b (lookup-in-lexenv symbol *environment* 'function)))
1641     (if (and b (eq (binding-type b) 'macro))
1642         (let ((expander (binding-value b)))
1643           (cond
1644             #+common-lisp
1645             ((gethash b *macroexpander-cache*)
1646              (setq expander (gethash b *macroexpander-cache*)))
1647             ((listp expander)
1648              (let ((compiled (eval expander)))
1649                ;; The list representation are useful while
1650                ;; bootstrapping, as we can dump the definition of the
1651                ;; macros easily, but they are slow because we have to
1652                ;; evaluate them and compile them now and again. So, let
1653                ;; us replace the list representation version of the
1654                ;; function with the compiled one.
1655                ;;
1656                #+jscl (setf (binding-value b) compiled)
1657                #+common-lisp (setf (gethash b *macroexpander-cache*) compiled)
1658                (setq expander compiled))))
1659           expander)
1660         nil)))
1661
1662 (defun !macroexpand-1 (form)
1663   (cond
1664     ((symbolp form)
1665      (let ((b (lookup-in-lexenv form *environment* 'variable)))
1666        (if (and b (eq (binding-type b) 'macro))
1667            (values (binding-value b) t)
1668            (values form nil))))
1669     ((consp form)
1670      (let ((macrofun (!macro-function (car form))))
1671        (if macrofun
1672            (values (apply macrofun (cdr form)) t)
1673            (values form nil))))
1674     (t
1675      (values form nil))))
1676
1677 (defun compile-funcall (function args)
1678   (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
1679          (arglist (concat "(" (join (list* values-funcs
1680                                            (integer-to-string (length args))
1681                                            (mapcar #'ls-compile args)) ", ") ")")))
1682     (unless (or (symbolp function)
1683                 (and (consp function)
1684                      (eq (car function) 'lambda)))
1685       (error "Bad function designator `~S'" function))
1686     (cond
1687       ((translate-function function)
1688        (concat (translate-function function) arglist))
1689       ((and (symbolp function)
1690             #+jscl (eq (symbol-package function) (find-package "COMMON-LISP"))
1691             #+common-lisp t)
1692        (code (ls-compile `',function) ".fvalue" arglist))
1693       (t
1694        (code (ls-compile `#',function) arglist)))))
1695
1696 (defun ls-compile-block (sexps &optional return-last-p)
1697   (if return-last-p
1698       (code (ls-compile-block (butlast sexps))
1699             "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
1700       (join-trailing
1701        (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1702        (concat ";" *newline*))))
1703
1704 (defun ls-compile (sexp &optional multiple-value-p)
1705   (multiple-value-bind (sexp expandedp) (!macroexpand-1 sexp)
1706     (when expandedp
1707       (return-from ls-compile (ls-compile sexp multiple-value-p)))
1708     ;; The expression has been macroexpanded. Now compile it!
1709     (let ((*multiple-value-p* multiple-value-p))
1710       (cond
1711         ((symbolp sexp)
1712          (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1713            (cond
1714              ((and b (not (member 'special (binding-declarations b))))
1715               (binding-value b))
1716              ((or (keywordp sexp)
1717                   (and b (member 'constant (binding-declarations b))))
1718               (code (ls-compile `',sexp) ".value"))
1719              (t
1720               (ls-compile `(symbol-value ',sexp))))))
1721         ((integerp sexp) (integer-to-string sexp))
1722         ((floatp sexp) (float-to-string sexp))
1723         ((characterp sexp) (code "\"" (escape-string (string sexp)) "\""))
1724         ((stringp sexp) (code "\"" (escape-string sexp) "\""))
1725         ((arrayp sexp) (literal sexp))
1726         ((listp sexp)
1727          (let ((name (car sexp))
1728                (args (cdr sexp)))
1729            (cond
1730              ;; Special forms
1731              ((assoc name *compilations*)
1732               (let ((comp (second (assoc name *compilations*))))
1733                 (apply comp args)))
1734              ;; Built-in functions
1735              ((and (assoc name *builtins*)
1736                    (not (claimp name 'function 'notinline)))
1737               (let ((comp (second (assoc name *builtins*))))
1738                 (apply comp args)))
1739              (t
1740               (compile-funcall name args)))))
1741         (t
1742          (error "How should I compile `~S'?" sexp))))))
1743
1744
1745 (defvar *compile-print-toplevels* nil)
1746
1747 (defun truncate-string (string &optional (width 60))
1748   (let ((n (or (position #\newline string)
1749                (min width (length string)))))
1750     (subseq string 0 n)))
1751
1752 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
1753   (let ((*toplevel-compilations* nil))
1754     (cond
1755       ((and (consp sexp) (eq (car sexp) 'progn))
1756        (let ((subs (mapcar (lambda (s)
1757                              (ls-compile-toplevel s t))
1758                            (cdr sexp))))
1759          (join (remove-if #'null-or-empty-p subs))))
1760       (t
1761        (when *compile-print-toplevels*
1762          (let ((form-string (prin1-to-string sexp)))
1763            (write-string "Compiling ")
1764            (write-string (truncate-string form-string))
1765            (write-line "...")))
1766
1767        (let ((code (ls-compile sexp multiple-value-p)))
1768          (code (join-trailing (get-toplevel-compilations)
1769                               (code ";" *newline*))
1770                (when code
1771                  (code code ";" *newline*))))))))