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