notinline version of + and -
[jscl.git] / ecmalisp.lisp
1 ;;; ecmalisp.lisp ---
2
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
6 ;; This program 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 ;; This program 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 this program.  If not, see <http://www.gnu.org/licenses/>.
18
19 ;;; This code is executed when ecmalisp compiles this file
20 ;;; itself. The compiler provides compilation of some special forms,
21 ;;; as well as funcalls and macroexpansion, but no functions. So, we
22 ;;; define the Lisp world from scratch. This code has to define enough
23 ;;; language to the compiler to be able to run.
24
25 #+ecmalisp
26 (progn
27   (eval-when-compile
28     (%compile-defmacro 'defmacro
29                        '(lambda (name args &rest body)
30                          `(eval-when-compile
31                             (%compile-defmacro ',name
32                                                '(lambda ,(mapcar (lambda (x)
33                                                                    (if (eq x '&body)
34                                                                        '&rest
35                                                                        x))
36                                                                  args)
37                                                  ,@body))))))
38
39   (defmacro declaim (&rest decls)
40     `(eval-when-compile
41        ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
42
43   (declaim (constant nil t) (special t nil))
44   (setq nil 'nil)
45   (setq t 't)
46
47   (defmacro when (condition &body body)
48     `(if ,condition (progn ,@body) nil))
49
50   (defmacro unless (condition &body body)
51     `(if ,condition nil (progn ,@body)))
52
53   (defmacro defvar (name value &optional docstring)
54     `(progn
55        (declaim (special ,name))
56        (unless (boundp ',name) (setq ,name ,value))
57        ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
58        ',name))
59
60   (defmacro defparameter (name value &optional docstring)
61     `(progn
62        (setq ,name ,value)
63        ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
64        ',name))
65
66   (defmacro named-lambda (name args &rest body)
67     (let ((x (gensym "FN")))
68       `(let ((,x (lambda ,args ,@body)))
69          (oset ,x "fname" ,name)
70          ,x)))
71
72   (defmacro defun (name args &rest body)
73     `(progn
74        (declaim (non-overridable ,name))
75        (fset ',name
76              (named-lambda ,(symbol-name name) ,args
77                ,@(if (and (stringp (car body)) (not (null (cdr body))))
78                      `(,(car body) (block ,name ,@(cdr body)))
79                      `((block ,name ,@body)))))
80        ',name))
81
82   (defun null (x)
83     (eq x nil))
84
85   (defmacro return (&optional value)
86     `(return-from nil ,value))
87
88   (defmacro while (condition &body body)
89     `(block nil (%while ,condition ,@body)))
90
91   (defvar *gensym-counter* 0)
92   (defun gensym (&optional (prefix "G"))
93     (setq *gensym-counter* (+ *gensym-counter* 1))
94     (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
95
96   (defun boundp (x)
97     (boundp x))
98
99   ;; Basic functions
100   (defun = (x y) (= x y))
101   (defun * (x y) (* x y))
102   (defun / (x y) (/ x y))
103   (defun 1+ (x) (+ x 1))
104   (defun 1- (x) (- x 1))
105   (defun zerop (x) (= x 0))
106   (defun truncate (x y) (floor (/ x y)))
107
108   (defun eql (x y) (eq x y))
109
110   (defun not (x) (if x nil t))
111
112   (defun cons (x y ) (cons x y))
113   (defun consp (x) (consp x))
114
115   (defun car (x)
116     "Return the CAR part of a cons, or NIL if X is null."
117     (car x))
118
119   (defun cdr (x) (cdr x))
120   (defun caar (x) (car (car x)))
121   (defun cadr (x) (car (cdr x)))
122   (defun cdar (x) (cdr (car x)))
123   (defun cddr (x) (cdr (cdr x)))
124   (defun caddr (x) (car (cdr (cdr x))))
125   (defun cdddr (x) (cdr (cdr (cdr x))))
126   (defun cadddr (x) (car (cdr (cdr (cdr x)))))
127   (defun first (x) (car x))
128   (defun second (x) (cadr x))
129   (defun third (x) (caddr x))
130   (defun fourth (x) (cadddr x))
131
132   (defun list (&rest args) args)
133   (defun atom (x)
134     (not (consp x)))
135
136   ;; Basic macros
137
138   (defmacro incf (x &optional (delta 1))
139     `(setq ,x (+ ,x ,delta)))
140
141   (defmacro decf (x &optional (delta 1))
142     `(setq ,x (- ,x ,delta)))
143
144   (defmacro push (x place)
145     `(setq ,place (cons ,x ,place)))
146
147   (defmacro dolist (iter &body body)
148     (let ((var (first iter))
149           (g!list (gensym)))
150       `(block nil
151          (let ((,g!list ,(second iter))
152                (,var nil))
153            (%while ,g!list
154                    (setq ,var (car ,g!list))
155                    (tagbody ,@body)
156                    (setq ,g!list (cdr ,g!list)))
157            ,(third iter)))))
158
159   (defmacro dotimes (iter &body body)
160     (let ((g!to (gensym))
161           (var (first iter))
162           (to (second iter))
163           (result (third iter)))
164       `(block nil
165          (let ((,var 0)
166                (,g!to ,to))
167            (%while (< ,var ,g!to)
168                    (tagbody ,@body)
169                    (incf ,var))
170            ,result))))
171
172   (defmacro cond (&rest clausules)
173     (if (null clausules)
174         nil
175         (if (eq (caar clausules) t)
176             `(progn ,@(cdar clausules))
177             `(if ,(caar clausules)
178                  (progn ,@(cdar clausules))
179                  (cond ,@(cdr clausules))))))
180
181   (defmacro case (form &rest clausules)
182     (let ((!form (gensym)))
183       `(let ((,!form ,form))
184          (cond
185            ,@(mapcar (lambda (clausule)
186                        (if (eq (car clausule) t)
187                            clausule
188                            `((eql ,!form ',(car clausule))
189                              ,@(cdr clausule))))
190                      clausules)))))
191
192   (defmacro ecase (form &rest clausules)
193     `(case ,form
194        ,@(append
195           clausules
196           `((t
197              (error "ECASE expression failed."))))))
198
199   (defmacro and (&rest forms)
200     (cond
201       ((null forms)
202        t)
203       ((null (cdr forms))
204        (car forms))
205       (t
206        `(if ,(car forms)
207             (and ,@(cdr forms))
208             nil))))
209
210   (defmacro or (&rest forms)
211     (cond
212       ((null forms)
213        nil)
214       ((null (cdr forms))
215        (car forms))
216       (t
217        (let ((g (gensym)))
218          `(let ((,g ,(car forms)))
219             (if ,g ,g (or ,@(cdr forms))))))))
220
221   (defmacro prog1 (form &body body)
222     (let ((value (gensym)))
223       `(let ((,value ,form))
224          ,@body
225          ,value)))
226
227   (defmacro prog2 (form1 result &body body)
228     `(prog1 (progn ,form1 ,result) ,@body)))
229
230
231 ;;; This couple of helper functions will be defined in both Common
232 ;;; Lisp and in Ecmalisp.
233 (defun ensure-list (x)
234   (if (listp x)
235       x
236       (list x)))
237
238 (defun !reduce (func list initial)
239   (if (null list)
240       initial
241       (!reduce func
242                (cdr list)
243                (funcall func initial (car list)))))
244
245 ;;; Go on growing the Lisp language in Ecmalisp, with more high
246 ;;; level utilities as well as correct versions of other
247 ;;; constructions.
248 #+ecmalisp
249 (progn
250   (defun + (&rest args)
251     (let ((r 0))
252       (dolist (x args r)
253         (incf r x))))
254
255   (defun - (x &rest others)
256     (if (null others)
257         (- x)
258         (let ((r x))
259           (dolist (y others r)
260             (decf r y)))))
261
262   (defun append-two (list1 list2)
263     (if (null list1)
264         list2
265         (cons (car list1)
266               (append (cdr list1) list2))))
267
268   (defun append (&rest lists)
269     (!reduce #'append-two lists '()))
270
271   (defun revappend (list1 list2)
272     (while list1
273       (push (car list1) list2)
274       (setq list1 (cdr list1)))
275     list2)
276
277   (defun reverse (list)
278     (revappend list '()))
279
280   (defun list-length (list)
281     (let ((l 0))
282       (while (not (null list))
283         (incf l)
284         (setq list (cdr list)))
285       l))
286
287   (defun length (seq)
288     (if (stringp seq)
289         (string-length seq)
290         (list-length seq)))
291
292   (defun concat-two (s1 s2)
293     (concat-two s1 s2))
294
295   (defun mapcar (func list)
296     (if (null list)
297         '()
298         (cons (funcall func (car list))
299               (mapcar func (cdr list)))))
300
301   (defun identity (x) x)
302
303   (defun copy-list (x)
304     (mapcar #'identity x))
305
306   (defun code-char (x) x)
307   (defun char-code (x) x)
308   (defun char= (x y) (= x y))
309
310   (defun integerp (x)
311     (and (numberp x) (= (floor x) x)))
312
313   (defun plusp (x) (< 0 x))
314   (defun minusp (x) (< x 0))
315
316   (defun listp (x)
317     (or (consp x) (null x)))
318
319   (defun nthcdr (n list)
320     (while (and (plusp n) list)
321       (setq n (1- n))
322       (setq list (cdr list)))
323     list)
324
325   (defun nth (n list)
326     (car (nthcdr n list)))
327
328   (defun last (x)
329     (while (consp (cdr x))
330       (setq x (cdr x)))
331     x)
332
333   (defun butlast (x)
334     (and (consp (cdr x))
335          (cons (car x) (butlast (cdr x)))))
336
337   (defun member (x list)
338     (while list
339       (when (eql x (car list))
340         (return list))
341       (setq list (cdr list))))
342
343   (defun remove (x list)
344     (cond
345       ((null list)
346        nil)
347       ((eql x (car list))
348        (remove x (cdr list)))
349       (t
350        (cons (car list) (remove x (cdr list))))))
351
352   (defun remove-if (func list)
353     (cond
354       ((null list)
355        nil)
356       ((funcall func (car list))
357        (remove-if func (cdr list)))
358       (t
359        (cons (car list) (remove-if func (cdr list))))))
360
361   (defun remove-if-not (func list)
362     (cond
363       ((null list)
364        nil)
365       ((funcall func (car list))
366        (cons (car list) (remove-if-not func (cdr list))))
367       (t
368        (remove-if-not func (cdr list)))))
369
370   (defun digit-char-p (x)
371     (if (and (<= #\0 x) (<= x #\9))
372         (- x #\0)
373         nil))
374
375   (defun subseq (seq a &optional b)
376     (cond
377       ((stringp seq)
378        (if b
379            (slice seq a b)
380            (slice seq a)))
381       (t
382        (error "Unsupported argument."))))
383
384   (defun parse-integer (string)
385     (let ((value 0)
386           (index 0)
387           (size (length string)))
388       (while (< index size)
389         (setq value (+ (* value 10) (digit-char-p (char string index))))
390         (incf index))
391       value))
392
393   (defun some (function seq)
394     (cond
395       ((stringp seq)
396        (let ((index 0)
397              (size (length seq)))
398          (while (< index size)
399            (when (funcall function (char seq index))
400              (return-from some t))
401            (incf index))
402          nil))
403       ((listp seq)
404        (dolist (x seq nil)
405          (when (funcall function x)
406            (return t))))
407       (t
408        (error "Unknown sequence."))))
409
410   (defun every (function seq)
411     (cond
412       ((stringp seq)
413        (let ((index 0)
414              (size (length seq)))
415          (while (< index size)
416            (unless (funcall function (char seq index))
417              (return-from every nil))
418            (incf index))
419          t))
420       ((listp seq)
421        (dolist (x seq t)
422          (unless (funcall function x)
423            (return))))
424       (t
425        (error "Unknown sequence."))))
426
427   (defun assoc (x alist)
428     (while alist
429       (if (eql x (caar alist))
430           (return)
431           (setq alist (cdr alist))))
432     (car alist))
433
434   (defun string (x)
435     (cond ((stringp x) x)
436           ((symbolp x) (symbol-name x))
437           (t (char-to-string x))))
438
439   (defun string= (s1 s2)
440     (equal s1 s2))
441
442   (defun fdefinition (x)
443     (cond
444       ((functionp x)
445        x)
446       ((symbolp x)
447        (symbol-function x))
448       (t
449        (error "Invalid function"))))
450
451   (defun disassemble (function)
452     (write-line (lambda-code (fdefinition function)))
453     nil)
454
455   (defun documentation (x type)
456     "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
457     (ecase type
458       (function
459        (let ((func (fdefinition x)))
460          (oget func "docstring")))
461       (variable
462        (unless (symbolp x)
463          (error "Wrong argument type! it should be a symbol"))
464        (oget x "vardoc"))))
465
466   ;; Packages
467
468   (defvar *package-list* nil)
469
470   (defun list-all-packages ()
471     *package-list*)
472
473   (defun make-package (name &optional use)
474     (let ((package (new))
475           (use (mapcar #'find-package-or-fail use)))
476       (oset package "packageName" name)
477       (oset package "symbols" (new))
478       (oset package "exports" (new))
479       (oset package "use" use)
480       (push package *package-list*)
481       package))
482
483   (defun packagep (x)
484     (and (objectp x) (in "symbols" x)))
485
486   (defun find-package (package-designator)
487     (when (packagep package-designator)
488       (return-from find-package package-designator))
489     (let ((name (string package-designator)))
490       (dolist (package *package-list*)
491         (when (string= (package-name package) name)
492           (return package)))))
493
494   (defun find-package-or-fail (package-designator)
495     (or (find-package package-designator)
496         (error "Package unknown.")))
497
498   (defun package-name (package-designator)
499     (let ((package (find-package-or-fail package-designator)))
500       (oget package "packageName")))
501
502   (defun %package-symbols (package-designator)
503     (let ((package (find-package-or-fail package-designator)))
504       (oget package "symbols")))
505
506   (defun package-use-list (package-designator)
507     (let ((package (find-package-or-fail package-designator)))
508       (oget package "use")))
509
510   (defun %package-external-symbols (package-designator)
511     (let ((package (find-package-or-fail package-designator)))
512       (oget package "exports")))
513
514   (defvar *common-lisp-package*
515     (make-package "CL"))
516
517   (defvar *user-package*
518     (make-package "CL-USER" (list *common-lisp-package*)))
519
520   (defvar *keyword-package*
521     (make-package "KEYWORD"))
522
523   (defun keywordp (x)
524     (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
525
526   (defvar *package* *common-lisp-package*)
527
528   (defmacro in-package (package-designator)
529     `(eval-when-compile
530        (setq *package* (find-package-or-fail ,package-designator))))
531
532   ;; This function is used internally to initialize the CL package
533   ;; with the symbols built during bootstrap.
534   (defun %intern-symbol (symbol)
535     (let ((symbols (%package-symbols *common-lisp-package*)))
536       (oset symbol "package" *common-lisp-package*)
537       (oset symbols (symbol-name symbol) symbol)))
538
539   (defun %find-symbol (name package)
540     (let ((package (find-package-or-fail package)))
541       (let ((symbols (%package-symbols package)))
542         (if (in name symbols)
543             (cons (oget symbols name) t)
544             (dolist (used (package-use-list package) (cons nil nil))
545               (let ((exports (%package-external-symbols used)))
546                 (when (in name exports)
547                   (return-from %find-symbol
548                     (cons (oget exports name) t)))))))))
549
550   (defun find-symbol (name &optional (package *package*))
551     (car (%find-symbol name package)))
552
553   (defun intern (name &optional (package *package*))
554     (let ((package (find-package-or-fail package)))
555       (let ((result (%find-symbol name package)))
556         (if (cdr result)
557             (car result)
558             (let ((symbols (%package-symbols package)))
559               (oget symbols name)
560               (let ((symbol (make-symbol name)))
561                 (oset symbol "package" package)
562                 (when (eq package *keyword-package*)
563                   (oset symbol "value" symbol)
564                   (export (list symbol) package))
565                 (oset symbols name symbol)))))))
566
567   (defun symbol-package (symbol)
568     (unless (symbolp symbol)
569       (error "it is not a symbol"))
570     (oget symbol "package"))
571
572   (defun export (symbols &optional (package *package*))
573     (let ((exports (%package-external-symbols package)))
574       (dolist (symb symbols t)
575         (oset exports (symbol-name symb) symb)))))
576
577
578 ;;; The compiler offers some primitives and special forms which are
579 ;;; not found in Common Lisp, for instance, while. So, we grow Common
580 ;;; Lisp a bit to it can execute the rest of the file.
581 #+common-lisp
582 (progn
583   (defmacro while (condition &body body)
584     `(do ()
585          ((not ,condition))
586        ,@body))
587
588   (defmacro eval-when-compile (&body body)
589     `(eval-when (:compile-toplevel :load-toplevel :execute)
590        ,@body))
591
592   (defun concat-two (s1 s2)
593     (concatenate 'string s1 s2))
594
595   (defun setcar (cons new)
596     (setf (car cons) new))
597   (defun setcdr (cons new)
598     (setf (cdr cons) new)))
599
600 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
601 ;;; from here, this code will compile on both. We define some helper
602 ;;; functions now for string manipulation and so on. They will be
603 ;;; useful in the compiler, mostly.
604
605 (defvar *newline* (string (code-char 10)))
606
607 (defun concat (&rest strs)
608   (!reduce #'concat-two strs ""))
609
610 (defmacro concatf (variable &body form)
611   `(setq ,variable (concat ,variable (progn ,@form))))
612
613 ;;; Concatenate a list of strings, with a separator
614 (defun join (list &optional (separator ""))
615   (cond
616     ((null list)
617      "")
618     ((null (cdr list))
619      (car list))
620     (t
621      (concat (car list)
622              separator
623              (join (cdr list) separator)))))
624
625 (defun join-trailing (list &optional (separator ""))
626   (if (null list)
627       ""
628       (concat (car list) separator (join-trailing (cdr list) separator))))
629
630 (defun mapconcat (func list)
631   (join (mapcar func list)))
632
633 ;;; Like CONCAT, but prefix each line with four spaces. Two versions
634 ;;; of this function are available, because the Ecmalisp version is
635 ;;; very slow and bootstraping was annoying.
636
637 #+ecmalisp
638 (defun indent (&rest string)
639   (let ((input (join string)))
640     (let ((output "")
641           (index 0)
642           (size (length input)))
643       (when (plusp (length input)) (concatf output "    "))
644       (while (< index size)
645         (let ((str
646                (if (and (char= (char input index) #\newline)
647                         (< index (1- size))
648                         (not (char= (char input (1+ index)) #\newline)))
649                    (concat (string #\newline) "    ")
650                    (string (char input index)))))
651           (concatf output str))
652         (incf index))
653       output)))
654
655 #+common-lisp
656 (defun indent (&rest string)
657   (with-output-to-string (*standard-output*)
658     (with-input-from-string (input (join string))
659       (loop
660          for line = (read-line input nil)
661          while line
662          do (write-string "    ")
663          do (write-line line)))))
664
665
666 (defun integer-to-string (x)
667   (cond
668     ((zerop x)
669      "0")
670     ((minusp x)
671      (concat "-" (integer-to-string (- 0 x))))
672     (t
673      (let ((digits nil))
674        (while (not (zerop x))
675          (push (mod x 10) digits)
676          (setq x (truncate x 10)))
677        (join (mapcar (lambda (d) (string (char "0123456789" d)))
678                      digits))))))
679
680
681 ;;; Wrap X with a Javascript code to convert the result from
682 ;;; Javascript generalized booleans to T or NIL.
683 (defun js!bool (x)
684   (concat "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
685
686 ;;; Concatenate the arguments and wrap them with a self-calling
687 ;;; Javascript anonymous function. It is used to make some Javascript
688 ;;; statements valid expressions and provide a private scope as well.
689 ;;; It could be defined as function, but we could do some
690 ;;; preprocessing in the future.
691 (defmacro js!selfcall (&body body)
692   `(concat "(function(){" *newline* (indent ,@body) "})()"))
693
694
695 ;;; Printer
696
697 #+ecmalisp
698 (progn
699   (defun prin1-to-string (form)
700     (cond
701       ((symbolp form)
702        (if (cdr (%find-symbol (symbol-name form) *package*))
703            (symbol-name form)
704            (let ((package (symbol-package form))
705                  (name (symbol-name form)))
706              (concat (if (eq package (find-package "KEYWORD"))
707                          ""
708                          (package-name package))
709                      ":" name))))
710       ((integerp form) (integer-to-string form))
711       ((stringp form) (concat "\"" (escape-string form) "\""))
712       ((functionp form)
713        (let ((name (oget form "fname")))
714          (if name
715              (concat "#<FUNCTION " name ">")
716              (concat "#<FUNCTION>"))))
717       ((listp form)
718        (concat "("
719                (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
720                (let ((last (last form)))
721                  (if (null (cdr last))
722                      (prin1-to-string (car last))
723                      (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
724                ")"))
725       ((packagep form)
726        (concat "#<PACKAGE " (package-name form) ">"))))
727
728   (defun write-line (x)
729     (write-string x)
730     (write-string *newline*)
731     x)
732
733   (defun warn (string)
734     (write-string "WARNING: ")
735     (write-line string))
736
737   (defun print (x)
738     (write-line (prin1-to-string x))
739     x))
740
741
742 ;;;; Reader
743
744 ;;; The Lisp reader, parse strings and return Lisp objects. The main
745 ;;; entry points are `ls-read' and `ls-read-from-string'.
746
747 (defun make-string-stream (string)
748   (cons string 0))
749
750 (defun %peek-char (stream)
751   (and (< (cdr stream) (length (car stream)))
752        (char (car stream) (cdr stream))))
753
754 (defun %read-char (stream)
755   (and (< (cdr stream) (length (car stream)))
756        (prog1 (char (car stream) (cdr stream))
757          (setcdr stream (1+ (cdr stream))))))
758
759 (defun whitespacep (ch)
760   (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
761
762 (defun skip-whitespaces (stream)
763   (let (ch)
764     (setq ch (%peek-char stream))
765     (while (and ch (whitespacep ch))
766       (%read-char stream)
767       (setq ch (%peek-char stream)))))
768
769 (defun terminalp (ch)
770   (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
771
772 (defun read-until (stream func)
773   (let ((string "")
774         (ch))
775     (setq ch (%peek-char stream))
776     (while (and ch (not (funcall func ch)))
777       (setq string (concat string (string ch)))
778       (%read-char stream)
779       (setq ch (%peek-char stream)))
780     string))
781
782 (defun skip-whitespaces-and-comments (stream)
783   (let (ch)
784     (skip-whitespaces stream)
785     (setq ch (%peek-char stream))
786     (while (and ch (char= ch #\;))
787       (read-until stream (lambda (x) (char= x #\newline)))
788       (skip-whitespaces stream)
789       (setq ch (%peek-char stream)))))
790
791 (defun %read-list (stream)
792   (skip-whitespaces-and-comments stream)
793   (let ((ch (%peek-char stream)))
794     (cond
795       ((null ch)
796        (error "Unspected EOF"))
797       ((char= ch #\))
798        (%read-char stream)
799        nil)
800       ((char= ch #\.)
801        (%read-char stream)
802        (prog1 (ls-read stream)
803          (skip-whitespaces-and-comments stream)
804          (unless (char= (%read-char stream) #\))
805            (error "')' was expected."))))
806       (t
807        (cons (ls-read stream) (%read-list stream))))))
808
809 (defun read-string (stream)
810   (let ((string "")
811         (ch nil))
812     (setq ch (%read-char stream))
813     (while (not (eql ch #\"))
814       (when (null ch)
815         (error "Unexpected EOF"))
816       (when (eql ch #\\)
817         (setq ch (%read-char stream)))
818       (setq string (concat string (string ch)))
819       (setq ch (%read-char stream)))
820     string))
821
822 (defun read-sharp (stream)
823   (%read-char stream)
824   (ecase (%read-char stream)
825     (#\'
826      (list 'function (ls-read stream)))
827     (#\\
828      (let ((cname
829             (concat (string (%read-char stream))
830                     (read-until stream #'terminalp))))
831        (cond
832          ((string= cname "space") (char-code #\space))
833          ((string= cname "tab") (char-code #\tab))
834          ((string= cname "newline") (char-code #\newline))
835          (t (char-code (char cname 0))))))
836     (#\+
837      (let ((feature (read-until stream #'terminalp)))
838        (cond
839          ((string= feature "common-lisp")
840           (ls-read stream)              ;ignore
841           (ls-read stream))
842          ((string= feature "ecmalisp")
843           (ls-read stream))
844          (t
845           (error "Unknown reader form.")))))))
846
847 ;;; Parse a string of the form NAME, PACKAGE:NAME or
848 ;;; PACKAGE::NAME and return the name. If the string is of the
849 ;;; form 1) or 3), but the symbol does not exist, it will be created
850 ;;; and interned in that package.
851 (defun read-symbol (string)
852   (let ((size (length string))
853         package name internalp index)
854     (setq index 0)
855     (while (and (< index size)
856                 (not (char= (char string index) #\:)))
857       (incf index))
858     (cond
859       ;; No package prefix
860       ((= index size)
861        (setq name string)
862        (setq package *package*)
863        (setq internalp t))
864       (t
865        ;; Package prefix
866        (if (zerop index)
867            (setq package "KEYWORD")
868            (setq package (string-upcase (subseq string 0 index))))
869        (incf index)
870        (when (char= (char string index) #\:)
871          (setq internalp t)
872          (incf index))
873        (setq name (subseq string index))))
874     ;; Canonalize symbol name and package
875     (setq name (string-upcase name))
876     (setq package (find-package package))
877     ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
878     ;; external symbol from PACKAGE.
879     (if (or internalp (eq package (find-package "KEYWORD")))
880         (intern name package)
881         (find-symbol name package))))
882
883 (defvar *eof* (gensym))
884 (defun ls-read (stream)
885   (skip-whitespaces-and-comments stream)
886   (let ((ch (%peek-char stream)))
887     (cond
888       ((or (null ch) (char= ch #\)))
889        *eof*)
890       ((char= ch #\()
891        (%read-char stream)
892        (%read-list stream))
893       ((char= ch #\')
894        (%read-char stream)
895        (list 'quote (ls-read stream)))
896       ((char= ch #\`)
897        (%read-char stream)
898        (list 'backquote (ls-read stream)))
899       ((char= ch #\")
900        (%read-char stream)
901        (read-string stream))
902       ((char= ch #\,)
903        (%read-char stream)
904        (if (eql (%peek-char stream) #\@)
905            (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
906            (list 'unquote (ls-read stream))))
907       ((char= ch #\#)
908        (read-sharp stream))
909       (t
910        (let ((string (read-until stream #'terminalp)))
911          (if (every #'digit-char-p string)
912              (parse-integer string)
913              (read-symbol string)))))))
914
915 (defun ls-read-from-string (string)
916   (ls-read (make-string-stream string)))
917
918
919 ;;;; Compiler
920
921 ;;; Translate the Lisp code to Javascript. It will compile the special
922 ;;; forms. Some primitive functions are compiled as special forms
923 ;;; too. The respective real functions are defined in the target (see
924 ;;; the beginning of this file) as well as some primitive functions.
925
926 (defvar *compilation-unit-checks* '())
927
928 (defun make-binding (name type value &optional declarations)
929   (list name type value declarations))
930
931 (defun binding-name (b) (first b))
932 (defun binding-type (b) (second b))
933 (defun binding-value (b) (third b))
934 (defun binding-declarations (b) (fourth b))
935
936 (defun set-binding-value (b value)
937   (setcar (cddr b) value))
938
939 (defun set-binding-declarations (b value)
940   (setcar (cdddr b) value))
941
942 (defun push-binding-declaration (decl b)
943   (set-binding-declarations b (cons decl (binding-declarations b))))
944
945
946 (defun make-lexenv ()
947   (list nil nil nil nil))
948
949 (defun copy-lexenv (lexenv)
950   (copy-list lexenv))
951
952 (defun push-to-lexenv (binding lexenv namespace)
953   (ecase namespace
954     (variable   (setcar        lexenv  (cons binding (car lexenv))))
955     (function   (setcar   (cdr lexenv) (cons binding (cadr lexenv))))
956     (block      (setcar  (cddr lexenv) (cons binding (caddr lexenv))))
957     (gotag      (setcar (cdddr lexenv) (cons binding (cadddr lexenv))))))
958
959 (defun extend-lexenv (bindings lexenv namespace)
960   (let ((env (copy-lexenv lexenv)))
961     (dolist (binding (reverse bindings) env)
962       (push-to-lexenv binding env namespace))))
963
964 (defun lookup-in-lexenv (name lexenv namespace)
965   (assoc name (ecase namespace
966                 (variable (first lexenv))
967                 (function (second lexenv))
968                 (block (third lexenv))
969                 (gotag (fourth lexenv)))))
970
971 (defvar *environment* (make-lexenv))
972
973 (defvar *variable-counter* 0)
974 (defun gvarname (symbol)
975   (concat "v" (integer-to-string (incf *variable-counter*))))
976
977 (defun translate-variable (symbol)
978   (binding-value (lookup-in-lexenv symbol *environment* 'variable)))
979
980 (defun extend-local-env (args)
981   (let ((new (copy-lexenv *environment*)))
982     (dolist (symbol args new)
983       (let ((b (make-binding symbol 'lexical-variable (gvarname symbol))))
984         (push-to-lexenv b new 'variable)))))
985
986 ;;; Toplevel compilations
987 (defvar *toplevel-compilations* nil)
988
989 (defun toplevel-compilation (string)
990   (push string *toplevel-compilations*))
991
992 (defun null-or-empty-p (x)
993   (zerop (length x)))
994
995 (defun get-toplevel-compilations ()
996   (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
997
998 (defun %compile-defmacro (name lambda)
999   (toplevel-compilation (ls-compile `',name))
1000   (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function))
1001
1002 (defun global-binding (name type namespace)
1003   (or (lookup-in-lexenv name *environment* namespace)
1004       (let ((b (make-binding name type nil)))
1005         (push-to-lexenv b *environment* namespace)
1006         b)))
1007
1008 (defun claimp (symbol namespace claim)
1009   (let ((b (lookup-in-lexenv symbol *environment* namespace)))
1010     (and b (member claim (binding-declarations b)))))
1011
1012 (defun !proclaim (decl)
1013   (case (car decl)
1014     (special
1015      (dolist (name (cdr decl))
1016        (let ((b (global-binding name 'variable 'variable)))
1017          (push-binding-declaration 'special b))))
1018     (notinline
1019      (dolist (name (cdr decl))
1020        (let ((b (global-binding name 'function 'function)))
1021          (push-binding-declaration 'notinline b))))
1022     (constant
1023      (dolist (name (cdr decl))
1024        (let ((b (global-binding name 'variable 'variable)))
1025          (push-binding-declaration 'constant b))))
1026     (non-overridable
1027      (dolist (name (cdr decl))
1028        (let ((b (global-binding name 'function 'function)))
1029          (push-binding-declaration 'non-overridable b))))))
1030
1031 #+ecmalisp
1032 (fset 'proclaim #'!proclaim)
1033
1034 ;;; Special forms
1035
1036 (defvar *compilations* nil)
1037
1038 (defmacro define-compilation (name args &body body)
1039   ;; Creates a new primitive `name' with parameters args and
1040   ;; @body. The body can access to the local environment through the
1041   ;; variable *ENVIRONMENT*.
1042   `(push (list ',name (lambda ,args (block ,name ,@body)))
1043          *compilations*))
1044
1045 (define-compilation if (condition true false)
1046   (concat "(" (ls-compile condition) " !== " (ls-compile nil)
1047           " ? " (ls-compile true)
1048           " : " (ls-compile false)
1049           ")"))
1050
1051 (defvar *lambda-list-keywords* '(&optional &rest))
1052
1053 (defun list-until-keyword (list)
1054   (if (or (null list) (member (car list) *lambda-list-keywords*))
1055       nil
1056       (cons (car list) (list-until-keyword (cdr list)))))
1057
1058 (defun lambda-list-required-arguments (lambda-list)
1059   (list-until-keyword lambda-list))
1060
1061 (defun lambda-list-optional-arguments-with-default (lambda-list)
1062   (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list)))))
1063
1064 (defun lambda-list-optional-arguments (lambda-list)
1065   (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list)))
1066
1067 (defun lambda-list-rest-argument (lambda-list)
1068   (let ((rest (list-until-keyword (cdr (member '&rest lambda-list)))))
1069     (when (cdr rest)
1070       (error "Bad lambda-list"))
1071     (car rest)))
1072
1073
1074 (defun lambda-docstring-wrapper (docstring &rest strs)
1075   (if docstring
1076       (js!selfcall
1077         "var func = " (join strs) ";" *newline*
1078         "func.docstring = '" docstring "';" *newline*
1079         "return func;" *newline*)
1080       (join strs)))
1081
1082 (define-compilation lambda (lambda-list &rest body)
1083   (let ((required-arguments (lambda-list-required-arguments lambda-list))
1084         (optional-arguments (lambda-list-optional-arguments lambda-list))
1085         (rest-argument (lambda-list-rest-argument lambda-list))
1086         documentation)
1087     ;; Get the documentation string for the lambda function
1088     (when (and (stringp (car body))
1089                (not (null (cdr body))))
1090       (setq documentation (car body))
1091       (setq body (cdr body)))
1092     (let ((n-required-arguments (length required-arguments))
1093           (n-optional-arguments (length optional-arguments))
1094           (*environment* (extend-local-env
1095                           (append (ensure-list rest-argument)
1096                                   required-arguments
1097                                   optional-arguments))))
1098       (lambda-docstring-wrapper
1099        documentation
1100        "(function ("
1101        (join (mapcar #'translate-variable
1102                      (append required-arguments optional-arguments))
1103              ",")
1104        "){" *newline*
1105        ;; Check number of arguments
1106        (indent
1107         (if required-arguments
1108             (concat "if (arguments.length < " (integer-to-string n-required-arguments)
1109                     ") throw 'too few arguments';" *newline*)
1110             "")
1111         (if (not rest-argument)
1112             (concat "if (arguments.length > "
1113                     (integer-to-string (+ n-required-arguments n-optional-arguments))
1114                     ") throw 'too many arguments';" *newline*)
1115             "")
1116         ;; Optional arguments
1117         (if optional-arguments
1118             (concat "switch(arguments.length){" *newline*
1119                     (let ((optional-and-defaults
1120                            (lambda-list-optional-arguments-with-default lambda-list))
1121                           (cases nil)
1122                           (idx 0))
1123                       (progn
1124                         (while (< idx n-optional-arguments)
1125                           (let ((arg (nth idx optional-and-defaults)))
1126                             (push (concat "case "
1127                                           (integer-to-string (+ idx n-required-arguments)) ":" *newline*
1128                                           (translate-variable (car arg))
1129                                           "="
1130                                           (ls-compile (cadr arg))
1131                                           ";" *newline*)
1132                                   cases)
1133                             (incf idx)))
1134                         (push (concat "default: break;" *newline*) cases)
1135                         (join (reverse cases))))
1136                     "}" *newline*)
1137             "")
1138         ;; &rest/&body argument
1139         (if rest-argument
1140             (let ((js!rest (translate-variable rest-argument)))
1141               (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
1142                       "for (var i = arguments.length-1; i>="
1143                       (integer-to-string (+ n-required-arguments n-optional-arguments))
1144                       "; i--)" *newline*
1145                       (indent js!rest " = "
1146                               "{car: arguments[i], cdr: ") js!rest "};"
1147                       *newline*))
1148             "")
1149         ;; Body
1150         (ls-compile-block body t)) *newline*
1151        "})"))))
1152
1153 (define-compilation setq (var val)
1154   (let ((b (lookup-in-lexenv var *environment* 'variable)))
1155     (if (eq (binding-type b) 'lexical-variable)
1156         (concat (binding-value b) " = " (ls-compile val))
1157         (ls-compile `(set ',var ,val)))))
1158
1159 ;;; FFI Variable accessors
1160 (define-compilation js-vref (var)
1161   var)
1162
1163 (define-compilation js-vset (var val)
1164   (concat "(" var " = " (ls-compile val) ")"))
1165
1166
1167 ;;; Literals
1168 (defun escape-string (string)
1169   (let ((output "")
1170         (index 0)
1171         (size (length string)))
1172     (while (< index size)
1173       (let ((ch (char string index)))
1174         (when (or (char= ch #\") (char= ch #\\))
1175           (setq output (concat output "\\")))
1176         (when (or (char= ch #\newline))
1177           (setq output (concat output "\\"))
1178           (setq ch #\n))
1179         (setq output (concat output (string ch))))
1180       (incf index))
1181     output))
1182
1183
1184 (defvar *literal-symbols* nil)
1185 (defvar *literal-counter* 0)
1186
1187 (defun genlit ()
1188   (concat "l" (integer-to-string (incf *literal-counter*))))
1189
1190 (defun literal (sexp &optional recursive)
1191   (cond
1192     ((integerp sexp) (integer-to-string sexp))
1193     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1194     ((symbolp sexp)
1195      (or (cdr (assoc sexp *literal-symbols*))
1196          (let ((v (genlit))
1197                (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
1198                   #+ecmalisp (ls-compile
1199                               `(intern ,(symbol-name sexp)
1200                                        ,(package-name (symbol-package sexp))))))
1201            (push (cons sexp v) *literal-symbols*)
1202            (toplevel-compilation (concat "var " v " = " s))
1203            v)))
1204     ((consp sexp)
1205      (let ((c (concat "{car: " (literal (car sexp) t) ", "
1206                       "cdr: " (literal (cdr sexp) t) "}")))
1207        (if recursive
1208            c
1209            (let ((v (genlit)))
1210              (toplevel-compilation (concat "var " v " = " c))
1211              v))))))
1212
1213 (define-compilation quote (sexp)
1214   (literal sexp))
1215
1216 (define-compilation %while (pred &rest body)
1217   (js!selfcall
1218     "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
1219     (indent (ls-compile-block body))
1220     "}"
1221     "return " (ls-compile nil) ";" *newline*))
1222
1223 (define-compilation function (x)
1224   (cond
1225     ((and (listp x) (eq (car x) 'lambda))
1226      (ls-compile x))
1227     ((symbolp x)
1228      (ls-compile `(symbol-function ',x)))))
1229
1230 (define-compilation eval-when-compile (&rest body)
1231   (eval (cons 'progn body))
1232   nil)
1233
1234 (defmacro define-transformation (name args form)
1235   `(define-compilation ,name ,args
1236      (ls-compile ,form)))
1237
1238 (define-compilation progn (&rest body)
1239   (js!selfcall (ls-compile-block body t)))
1240
1241 (defun special-variable-p (x)
1242   (claimp x 'variable 'special))
1243
1244 ;;; Wrap CODE to restore the symbol values of the dynamic
1245 ;;; bindings. BINDINGS is a list of pairs of the form
1246 ;;; (SYMBOL . PLACE),  where PLACE is a Javascript variable
1247 ;;; name to initialize the symbol value and where to stored
1248 ;;; the old value.
1249 (defun let-binding-wrapper (bindings body)
1250   (when (null bindings)
1251     (return-from let-binding-wrapper body))
1252   (concat
1253    "try {" *newline*
1254    (indent "var tmp;" *newline*
1255            (mapconcat
1256             (lambda (b)
1257               (let ((s (ls-compile `(quote ,(car b)))))
1258                 (concat "tmp = " s ".value;" *newline*
1259                         s ".value = " (cdr b) ";" *newline*
1260                         (cdr b) " = tmp;" *newline*)))
1261             bindings)
1262            body *newline*)
1263    "}" *newline*
1264    "finally {"  *newline*
1265    (indent
1266     (mapconcat (lambda (b)
1267                  (let ((s (ls-compile `(quote ,(car b)))))
1268                    (concat s ".value" " = " (cdr b) ";" *newline*)))
1269                bindings))
1270    "}" *newline*))
1271
1272 (define-compilation let (bindings &rest body)
1273   (let ((bindings (mapcar #'ensure-list bindings)))
1274     (let ((variables (mapcar #'first bindings)))
1275       (let ((cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
1276             (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
1277             (dynamic-bindings))
1278         (concat "(function("
1279                 (join (mapcar (lambda (x)
1280                                 (if (special-variable-p x)
1281                                     (let ((v (gvarname x)))
1282                                       (push (cons x v) dynamic-bindings)
1283                                       v)
1284                                     (translate-variable x)))
1285                               variables)
1286                       ",")
1287                 "){" *newline*
1288                 (let ((body (ls-compile-block body t)))
1289                   (indent (let-binding-wrapper dynamic-bindings body)))
1290                 "})(" (join cvalues ",") ")")))))
1291
1292
1293 ;;; Return the code to initialize BINDING, and push it extending the
1294 ;;; current lexical environment if the variable is special.
1295 (defun let*-initialize-value (binding)
1296   (let ((var (first binding))
1297         (value (second binding)))
1298     (if (special-variable-p var)
1299         (concat (ls-compile `(setq ,var ,value)) ";" *newline*)
1300         (let ((v (gvarname var)))
1301           (let ((b (make-binding var 'variable v)))
1302             (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*)
1303               (push-to-lexenv b *environment* 'variable)))))))
1304
1305 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
1306 ;;; DOES NOT generate code to initialize the value of the symbols,
1307 ;;; unlike let-binding-wrapper.
1308 (defun let*-binding-wrapper (symbols body)
1309   (when (null symbols)
1310     (return-from let*-binding-wrapper body))
1311   (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
1312                        (remove-if-not #'special-variable-p symbols))))
1313     (concat
1314      "try {" *newline*
1315      (indent
1316       (mapconcat (lambda (b)
1317                    (let ((s (ls-compile `(quote ,(car b)))))
1318                      (concat "var " (cdr b) " = " s ".value;" *newline*)))
1319                  store)
1320       body)
1321      "}" *newline*
1322      "finally {" *newline*
1323      (indent
1324       (mapconcat (lambda (b)
1325                    (let ((s (ls-compile `(quote ,(car b)))))
1326                      (concat s ".value" " = " (cdr b) ";" *newline*)))
1327                  store))
1328      "}" *newline*)))
1329
1330
1331 (define-compilation let* (bindings &rest body)
1332   (let ((bindings (mapcar #'ensure-list bindings))
1333         (*environment* (copy-lexenv *environment*)))
1334     (js!selfcall
1335       (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
1336             (body (concat (mapconcat #'let*-initialize-value bindings)
1337                           (ls-compile-block body t))))
1338         (let*-binding-wrapper specials body)))))
1339
1340
1341 (defvar *block-counter* 0)
1342
1343 (define-compilation block (name &rest body)
1344   (let ((tr (integer-to-string (incf *block-counter*))))
1345     (let ((b (make-binding name 'block tr)))
1346       (js!selfcall
1347         "try {" *newline*
1348         (let ((*environment* (extend-lexenv (list b) *environment* 'block)))
1349           (indent "return " (ls-compile `(progn ,@body)) ";" *newline*))
1350         "}" *newline*
1351         "catch (cf){" *newline*
1352         "    if (cf.type == 'block' && cf.id == " tr ")" *newline*
1353         "        return cf.value;" *newline*
1354         "    else" *newline*
1355         "        throw cf;" *newline*
1356         "}" *newline*))))
1357
1358 (define-compilation return-from (name &optional value)
1359   (let ((b (lookup-in-lexenv name *environment* 'block)))
1360     (if b
1361         (js!selfcall
1362           "throw ({"
1363           "type: 'block', "
1364           "id: " (binding-value b) ", "
1365           "value: " (ls-compile value) ", "
1366           "message: 'Return from unknown block " (symbol-name name) ".'"
1367           "})")
1368         (error (concat "Unknown block `" (symbol-name name) "'.")))))
1369
1370
1371 (define-compilation catch (id &rest body)
1372   (js!selfcall
1373     "var id = " (ls-compile id) ";" *newline*
1374     "try {" *newline*
1375     (indent "return " (ls-compile `(progn ,@body))
1376             ";" *newline*)
1377     "}" *newline*
1378     "catch (cf){" *newline*
1379     "    if (cf.type == 'catch' && cf.id == id)" *newline*
1380     "        return cf.value;" *newline*
1381     "    else" *newline*
1382     "        throw cf;" *newline*
1383     "}" *newline*))
1384
1385 (define-compilation throw (id value)
1386   (js!selfcall
1387     "throw ({"
1388     "type: 'catch', "
1389     "id: " (ls-compile id) ", "
1390     "value: " (ls-compile value) ", "
1391     "message: 'Throw uncatched.'"
1392     "})"))
1393
1394
1395 (defvar *tagbody-counter* 0)
1396 (defvar *go-tag-counter* 0)
1397
1398 (defun go-tag-p (x)
1399   (or (integerp x) (symbolp x)))
1400
1401 (defun declare-tagbody-tags (tbidx body)
1402   (let ((bindings
1403          (mapcar (lambda (label)
1404                    (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
1405                      (make-binding label 'gotag (list tbidx tagidx))))
1406                  (remove-if-not #'go-tag-p body))))
1407     (extend-lexenv bindings *environment* 'gotag)))
1408
1409 (define-compilation tagbody (&rest body)
1410   ;; Ignore the tagbody if it does not contain any go-tag. We do this
1411   ;; because 1) it is easy and 2) many built-in forms expand to a
1412   ;; implicit tagbody, so we save some space.
1413   (unless (some #'go-tag-p body)
1414     (return-from tagbody (ls-compile `(progn ,@body nil))))
1415   ;; The translation assumes the first form in BODY is a label
1416   (unless (go-tag-p (car body))
1417     (push (gensym "START") body))
1418   ;; Tagbody compilation
1419   (let ((tbidx (integer-to-string *tagbody-counter*)))
1420     (let ((*environment* (declare-tagbody-tags tbidx body))
1421           initag)
1422       (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
1423         (setq initag (second (binding-value b))))
1424       (js!selfcall
1425         "var tagbody_" tbidx " = " initag ";" *newline*
1426         "tbloop:" *newline*
1427         "while (true) {" *newline*
1428         (indent "try {" *newline*
1429                 (indent (let ((content ""))
1430                           (concat "switch(tagbody_" tbidx "){" *newline*
1431                                   "case " initag ":" *newline*
1432                                   (dolist (form (cdr body) content)
1433                                     (concatf content
1434                                       (if (not (go-tag-p form))
1435                                           (indent (ls-compile form) ";" *newline*)
1436                                           (let ((b (lookup-in-lexenv form *environment* 'gotag)))
1437                                             (concat "case " (second (binding-value b)) ":" *newline*)))))
1438                                   "default:" *newline*
1439                                   "    break tbloop;" *newline*
1440                                   "}" *newline*)))
1441                 "}" *newline*
1442                 "catch (jump) {" *newline*
1443                 "    if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
1444                 "        tagbody_" tbidx " = jump.label;" *newline*
1445                 "    else" *newline*
1446                 "        throw(jump);" *newline*
1447                 "}" *newline*)
1448         "}" *newline*
1449         "return " (ls-compile nil) ";" *newline*))))
1450
1451 (define-compilation go (label)
1452   (let ((b (lookup-in-lexenv label *environment* 'gotag))
1453         (n (cond
1454              ((symbolp label) (symbol-name label))
1455              ((integerp label) (integer-to-string label)))))
1456     (if b
1457         (js!selfcall
1458           "throw ({"
1459           "type: 'tagbody', "
1460           "id: " (first (binding-value b)) ", "
1461           "label: " (second (binding-value b)) ", "
1462           "message: 'Attempt to GO to non-existing tag " n "'"
1463           "})" *newline*)
1464         (error (concat "Unknown tag `" n "'.")))))
1465
1466
1467 (define-compilation unwind-protect (form &rest clean-up)
1468   (js!selfcall
1469     "var ret = " (ls-compile nil) ";" *newline*
1470     "try {" *newline*
1471     (indent "ret = " (ls-compile form) ";" *newline*)
1472     "} finally {" *newline*
1473     (indent (ls-compile-block clean-up))
1474     "}" *newline*
1475     "return ret;" *newline*))
1476
1477
1478 ;;; A little backquote implementation without optimizations of any
1479 ;;; kind for ecmalisp.
1480 (defun backquote-expand-1 (form)
1481   (cond
1482     ((symbolp form)
1483      (list 'quote form))
1484     ((atom form)
1485      form)
1486     ((eq (car form) 'unquote)
1487      (car form))
1488     ((eq (car form) 'backquote)
1489      (backquote-expand-1 (backquote-expand-1 (cadr form))))
1490     (t
1491      (cons 'append
1492            (mapcar (lambda (s)
1493                      (cond
1494                        ((and (listp s) (eq (car s) 'unquote))
1495                         (list 'list (cadr s)))
1496                        ((and (listp s) (eq (car s) 'unquote-splicing))
1497                         (cadr s))
1498                        (t
1499                         (list 'list (backquote-expand-1 s)))))
1500                    form)))))
1501
1502 (defun backquote-expand (form)
1503   (if (and (listp form) (eq (car form) 'backquote))
1504       (backquote-expand-1 (cadr form))
1505       form))
1506
1507 (defmacro backquote (form)
1508   (backquote-expand-1 form))
1509
1510 (define-transformation backquote (form)
1511   (backquote-expand-1 form))
1512
1513 ;;; Primitives
1514
1515 (defvar *builtins* nil)
1516
1517 (defmacro define-raw-builtin (name args &body body)
1518   ;; Creates a new primitive function `name' with parameters args and
1519   ;; @body. The body can access to the local environment through the
1520   ;; variable *ENVIRONMENT*.
1521   `(push (list ',name (lambda ,args (block ,name ,@body)))
1522          *builtins*))
1523
1524 (defmacro define-builtin (name args &body body)
1525   `(progn
1526      (define-raw-builtin ,name ,args
1527        (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1528          ,@body))))
1529
1530 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1531 (defmacro type-check (decls &body body)
1532   `(js!selfcall
1533      ,@(mapcar (lambda (decl)
1534                    `(concat "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1535                  decls)
1536      ,@(mapcar (lambda (decl)
1537                  `(concat "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1538                           (indent "throw 'The value ' + "
1539                                   ,(first decl)
1540                                   " + ' is not a type "
1541                                   ,(second decl)
1542                                   ".';"
1543                                   *newline*)))
1544                decls)
1545      (concat "return " (progn ,@body) ";" *newline*)))
1546
1547 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1548 ;;; a variable which holds a list of forms. It will compile them and
1549 ;;; store the result in some Javascript variables. BODY is evaluated
1550 ;;; with ARGS bound to the list of these variables to generate the
1551 ;;; code which performs the transformation on these variables.
1552
1553 (defun variable-arity-call (args function)
1554   (unless (consp args)
1555     (error "ARGS must be a non-empty list"))
1556   (let ((counter 0)
1557         (variables '())
1558         (prelude ""))
1559     (dolist (x args)
1560       (let ((v (concat "x" (integer-to-string (incf counter)))))
1561         (push v variables)
1562         (concatf prelude
1563                  (concat "var " v " = " (ls-compile x) ";" *newline*
1564                          "if (typeof " v " !== 'number') throw 'Not a number!';"
1565                          *newline*))))
1566     (js!selfcall prelude (funcall function (reverse variables)))))
1567
1568
1569 (defmacro variable-arity (args &body body)
1570   (unless (symbolp args)
1571     (error "Bad usage of VARIABLE-ARITY, yo must pass a symbol"))
1572   `(variable-arity-call ,args
1573                         (lambda (,args)
1574                           (concat "return " ,@body ";" *newline*))))
1575
1576
1577 (defun num-op-num (x op y)
1578   (type-check (("x" "number" x) ("y" "number" y))
1579     (concat "x" op "y")))
1580
1581 (define-raw-builtin + (&rest numbers)
1582   (if (null numbers)
1583       "0"
1584       (variable-arity numbers
1585         (join numbers "+"))))
1586
1587 (define-raw-builtin - (x &rest others)
1588   (let ((args (cons x others)))
1589     (variable-arity args
1590       (if (null others)
1591           (concat "-" (car args))
1592           (join args "-")))))
1593
1594
1595 (define-builtin * (x y) (num-op-num x "*" y))
1596 (define-builtin / (x y) (num-op-num x "/" y))
1597
1598 (define-builtin mod (x y) (num-op-num x "%" y))
1599
1600 (define-builtin < (x y)  (js!bool (num-op-num x "<" y)))
1601 (define-builtin > (x y)  (js!bool (num-op-num x ">" y)))
1602 (define-builtin = (x y)  (js!bool (num-op-num x "==" y)))
1603 (define-builtin <= (x y) (js!bool (num-op-num x "<=" y)))
1604 (define-builtin >= (x y) (js!bool (num-op-num x ">=" y)))
1605
1606 (define-builtin numberp (x)
1607   (js!bool (concat "(typeof (" x ") == \"number\")")))
1608
1609 (define-builtin floor (x)
1610   (type-check (("x" "number" x))
1611     "Math.floor(x)"))
1612
1613 (define-builtin cons (x y)
1614   (concat "({car: " x ", cdr: " y "})"))
1615
1616 (define-builtin consp (x)
1617   (js!bool
1618    (js!selfcall
1619      "var tmp = " x ";" *newline*
1620      "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1621
1622 (define-builtin car (x)
1623   (js!selfcall
1624     "var tmp = " x ";" *newline*
1625     "return tmp === " (ls-compile nil)
1626     "? " (ls-compile nil)
1627     ": tmp.car;" *newline*))
1628
1629 (define-builtin cdr (x)
1630   (js!selfcall
1631     "var tmp = " x ";" *newline*
1632     "return tmp === " (ls-compile nil) "? "
1633     (ls-compile nil)
1634     ": tmp.cdr;" *newline*))
1635
1636 (define-builtin setcar (x new)
1637   (type-check (("x" "object" x))
1638     (concat "(x.car = " new ")")))
1639
1640 (define-builtin setcdr (x new)
1641   (type-check (("x" "object" x))
1642     (concat "(x.cdr = " new ")")))
1643
1644 (define-builtin symbolp (x)
1645   (js!bool
1646    (js!selfcall
1647      "var tmp = " x ";" *newline*
1648      "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1649
1650 (define-builtin make-symbol (name)
1651   (type-check (("name" "string" name))
1652     "({name: name})"))
1653
1654 (define-builtin symbol-name (x)
1655   (concat "(" x ").name"))
1656
1657 (define-builtin set (symbol value)
1658   (concat "(" symbol ").value = " value))
1659
1660 (define-builtin fset (symbol value)
1661   (concat "(" symbol ").function = " value))
1662
1663 (define-builtin boundp (x)
1664   (js!bool (concat "(" x ".value !== undefined)")))
1665
1666 (define-builtin symbol-value (x)
1667   (js!selfcall
1668     "var symbol = " x ";" *newline*
1669     "var value = symbol.value;" *newline*
1670     "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1671     "return value;" *newline*))
1672
1673 (define-builtin symbol-function (x)
1674   (js!selfcall
1675     "var symbol = " x ";" *newline*
1676     "var func = symbol.function;" *newline*
1677     "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1678     "return func;" *newline*))
1679
1680 (define-builtin symbol-plist (x)
1681   (concat "((" x ").plist || " (ls-compile nil) ")"))
1682
1683 (define-builtin lambda-code (x)
1684   (concat "(" x ").toString()"))
1685
1686
1687 (define-builtin eq    (x y) (js!bool (concat "(" x " === " y ")")))
1688 (define-builtin equal (x y) (js!bool (concat "(" x  " == " y ")")))
1689
1690 (define-builtin char-to-string (x)
1691   (type-check (("x" "number" x))
1692     "String.fromCharCode(x)"))
1693
1694 (define-builtin stringp (x)
1695   (js!bool (concat "(typeof(" x ") == \"string\")")))
1696
1697 (define-builtin string-upcase (x)
1698   (type-check (("x" "string" x))
1699     "x.toUpperCase()"))
1700
1701 (define-builtin string-length (x)
1702   (type-check (("x" "string" x))
1703     "x.length"))
1704
1705 (define-raw-builtin slice (string a &optional b)
1706   (js!selfcall
1707     "var str = " (ls-compile string) ";" *newline*
1708     "var a = " (ls-compile a) ";" *newline*
1709     "var b;" *newline*
1710     (if b
1711         (concat "b = " (ls-compile b) ";" *newline*)
1712         "")
1713     "return str.slice(a,b);" *newline*))
1714
1715 (define-builtin char (string index)
1716   (type-check (("string" "string" string)
1717                ("index" "number" index))
1718     "string.charCodeAt(index)"))
1719
1720 (define-builtin concat-two (string1 string2)
1721   (type-check (("string1" "string" string1)
1722                ("string2" "string" string2))
1723     "string1.concat(string2)"))
1724
1725 (define-raw-builtin funcall (func &rest args)
1726   (concat "(" (ls-compile func) ")("
1727           (join (mapcar #'ls-compile args)
1728                 ", ")
1729           ")"))
1730
1731 (define-raw-builtin apply (func &rest args)
1732   (if (null args)
1733       (concat "(" (ls-compile func) ")()")
1734       (let ((args (butlast args))
1735             (last (car (last args))))
1736         (js!selfcall
1737           "var f = " (ls-compile func) ";" *newline*
1738           "var args = [" (join (mapcar #'ls-compile args)
1739                                ", ")
1740           "];" *newline*
1741           "var tail = (" (ls-compile last) ");" *newline*
1742           "while (tail != " (ls-compile nil) "){" *newline*
1743           "    args.push(tail.car);" *newline*
1744           "    tail = tail.cdr;" *newline*
1745           "}" *newline*
1746           "return f.apply(this, args);" *newline*))))
1747
1748 (define-builtin js-eval (string)
1749   (type-check (("string" "string" string))
1750     "eval.apply(window, [string])"))
1751
1752 (define-builtin error (string)
1753   (js!selfcall "throw " string ";" *newline*))
1754
1755 (define-builtin new () "{}")
1756
1757 (define-builtin objectp (x)
1758   (js!bool (concat "(typeof (" x ") === 'object')")))
1759
1760 (define-builtin oget (object key)
1761   (js!selfcall
1762     "var tmp = " "(" object ")[" key "];" *newline*
1763     "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1764
1765 (define-builtin oset (object key value)
1766   (concat "((" object ")[" key "] = " value ")"))
1767
1768 (define-builtin in (key object)
1769   (js!bool (concat "((" key ") in (" object "))")))
1770
1771 (define-builtin functionp (x)
1772   (js!bool (concat "(typeof " x " == 'function')")))
1773
1774 (define-builtin write-string (x)
1775   (type-check (("x" "string" x))
1776     "lisp.write(x)"))
1777
1778 (defun macro (x)
1779   (and (symbolp x)
1780        (let ((b (lookup-in-lexenv x *environment* 'function)))
1781          (and (eq (binding-type b) 'macro)
1782               b))))
1783
1784 (defun ls-macroexpand-1 (form)
1785   (let ((macro-binding (macro (car form))))
1786     (if macro-binding
1787         (let ((expander (binding-value macro-binding)))
1788           (when (listp expander)
1789             (let ((compiled (eval expander)))
1790               ;; The list representation are useful while
1791               ;; bootstrapping, as we can dump the definition of the
1792               ;; macros easily, but they are slow because we have to
1793               ;; evaluate them and compile them now and again. So, let
1794               ;; us replace the list representation version of the
1795               ;; function with the compiled one.
1796               ;;
1797               #+ecmalisp (set-binding-value macro-binding compiled)
1798               (setq expander compiled)))
1799           (apply expander (cdr form)))
1800         form)))
1801
1802 (defun compile-funcall (function args)
1803   (if (and (symbolp function)
1804            (claimp function 'function 'non-overridable))
1805       (concat (ls-compile `',function) ".function("
1806               (join (mapcar #'ls-compile args)
1807                     ", ")
1808               ")")
1809       (concat (ls-compile `#',function) "("
1810               (join (mapcar #'ls-compile args)
1811                     ", ")
1812               ")")))
1813
1814 (defun ls-compile-block (sexps &optional return-last-p)
1815   (if return-last-p
1816       (concat (ls-compile-block (butlast sexps))
1817               "return " (ls-compile (car (last sexps))) ";")
1818       (join-trailing
1819        (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
1820        (concat ";" *newline*))))
1821
1822 (defun ls-compile (sexp)
1823   (cond
1824     ((symbolp sexp)
1825      (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
1826        (cond
1827          ((and b (not (member 'special (binding-declarations b))))
1828           (binding-value b))
1829          ((or (keywordp sexp)
1830               (member 'constant (binding-declarations b)))
1831           (concat (ls-compile `',sexp) ".value"))
1832          (t
1833           (ls-compile `(symbol-value ',sexp))))))
1834     ((integerp sexp) (integer-to-string sexp))
1835     ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1836     ((listp sexp)
1837      (let ((name (car sexp))
1838            (args (cdr sexp)))
1839        (cond
1840          ;; Special forms
1841          ((assoc name *compilations*)
1842           (let ((comp (second (assoc name *compilations*))))
1843             (apply comp args)))
1844          ;; Built-in functions
1845          ((and (assoc name *builtins*)
1846                (not (claimp name 'function 'notinline)))
1847           (let ((comp (second (assoc name *builtins*))))
1848             (apply comp args)))
1849          (t
1850           (if (macro name)
1851               (ls-compile (ls-macroexpand-1 sexp))
1852               (compile-funcall name args))))))))
1853
1854 (defun ls-compile-toplevel (sexp)
1855   (let ((*toplevel-compilations* nil))
1856     (cond
1857       ((and (consp sexp) (eq (car sexp) 'progn))
1858        (let ((subs (mapcar #'ls-compile-toplevel (cdr sexp))))
1859          (join (remove-if #'null-or-empty-p subs))))
1860       (t
1861        (let ((code (ls-compile sexp)))
1862          (concat (join-trailing (get-toplevel-compilations)
1863                                 (concat ";" *newline*))
1864                  (if code
1865                      (concat code ";" *newline*)
1866                      "")))))))
1867
1868
1869 ;;; Once we have the compiler, we define the runtime environment and
1870 ;;; interactive development (eval), which works calling the compiler
1871 ;;; and evaluating the Javascript result globally.
1872
1873 #+ecmalisp
1874 (progn
1875   (defmacro with-compilation-unit (&body body)
1876     `(prog1
1877          (progn
1878            (setq *compilation-unit-checks* nil)
1879            ,@body)
1880        (dolist (check *compilation-unit-checks*)
1881          (funcall check))))
1882
1883   (defun eval (x)
1884     (let ((code
1885            (with-compilation-unit
1886                (ls-compile-toplevel x))))
1887       (js-eval code)))
1888
1889   (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= =
1890 = > >= and append apply assoc atom block boundp boundp butlast caar
1891 cadddr caddr cadr car car case catch cdar cdddr cddr cdr cdr char
1892 char-code char= code-char cond cons consp copy-list decf declaim
1893 defparameter defun defvar digit-char-p disassemble documentation
1894 dolist dotimes ecase eq eql equal error eval every export fdefinition
1895 find-package find-symbol first fourth fset funcall function functionp
1896 gensym go identity if in-package incf integerp integerp intern
1897 keywordp lambda last length let let* list-all-packages list listp
1898 make-package make-symbol mapcar member minusp mod nil not nth nthcdr
1899 null numberp or package-name package-use-list packagep plusp
1900 prin1-to-string print proclaim prog1 prog2 pron push quote remove
1901 remove-if remove-if-not return return-from revappend reverse second
1902 set setq some string-upcase string string= stringp subseq
1903 symbol-function symbol-name symbol-package symbol-plist symbol-value
1904 symbolp t tagbody third throw truncate unless unwind-protect variable
1905 warn when write-line write-string zerop))
1906
1907   (setq *package* *user-package*)
1908
1909   (js-eval "var lisp")
1910   (js-vset "lisp" (new))
1911   (js-vset "lisp.read" #'ls-read-from-string)
1912   (js-vset "lisp.print" #'prin1-to-string)
1913   (js-vset "lisp.eval" #'eval)
1914   (js-vset "lisp.compile" #'ls-compile-toplevel)
1915   (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
1916   (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str))))
1917
1918   ;; Set the initial global environment to be equal to the host global
1919   ;; environment at this point of the compilation.
1920   (eval-when-compile
1921     (toplevel-compilation
1922      (ls-compile
1923       `(progn
1924          ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))
1925                    *literal-symbols*)
1926          (setq *literal-symbols* ',*literal-symbols*)
1927          (setq *environment* ',*environment*)
1928          (setq *variable-counter* ,*variable-counter*)
1929          (setq *gensym-counter* ,*gensym-counter*)
1930          (setq *block-counter* ,*block-counter*)))))
1931
1932   (eval-when-compile
1933     (toplevel-compilation
1934      (ls-compile
1935       `(setq *literal-counter* ,*literal-counter*)))))
1936
1937
1938 ;;; Finally, we provide a couple of functions to easily bootstrap
1939 ;;; this. It just calls the compiler with this file as input.
1940
1941 #+common-lisp
1942 (progn
1943   (defun read-whole-file (filename)
1944     (with-open-file (in filename)
1945       (let ((seq (make-array (file-length in) :element-type 'character)))
1946         (read-sequence seq in)
1947         seq)))
1948
1949   (defun ls-compile-file (filename output)
1950     (setq *compilation-unit-checks* nil)
1951     (with-open-file (out output :direction :output :if-exists :supersede)
1952       (let* ((source (read-whole-file filename))
1953              (in (make-string-stream source)))
1954         (loop
1955            for x = (ls-read in)
1956            until (eq x *eof*)
1957            for compilation = (ls-compile-toplevel x)
1958            when (plusp (length compilation))
1959            do (write-string compilation out))
1960         (dolist (check *compilation-unit-checks*)
1961           (funcall check))
1962         (setq *compilation-unit-checks* nil))))
1963
1964   (defun bootstrap ()
1965     (setq *environment* (make-lexenv))
1966     (setq *literal-symbols* nil)
1967     (setq *variable-counter* 0
1968           *gensym-counter* 0
1969           *literal-counter* 0
1970           *block-counter* 0)
1971     (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))