3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
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.
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.
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/>.
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.
28 (%compile-defmacro 'defmacro
30 (lambda (name args &rest body)
32 (%compile-defmacro ',name
34 (lambda ,(mapcar #'(lambda (x)
41 (defmacro declaim (&rest decls)
43 ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
45 (defmacro defconstant (name value &optional docstring)
47 (declaim (special ,name))
48 (declaim (constant ,name))
50 ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
54 (defconstant nil 'nil)
57 (defmacro lambda (args &body body)
58 `(function (lambda ,args ,@body)))
60 (defmacro when (condition &body body)
61 `(if ,condition (progn ,@body) nil))
63 (defmacro unless (condition &body body)
64 `(if ,condition nil (progn ,@body)))
66 (defmacro defvar (name value &optional docstring)
68 (declaim (special ,name))
69 (unless (boundp ',name) (setq ,name ,value))
70 ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
73 (defmacro defparameter (name value &optional docstring)
76 ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
79 (defmacro named-lambda (name args &rest body)
80 (let ((x (gensym "FN")))
81 `(let ((,x (lambda ,args ,@body)))
82 (oset ,x "fname" ,name)
85 (defmacro defun (name args &rest body)
88 (named-lambda ,(symbol-name name) ,args
89 ,@(if (and (stringp (car body)) (not (null (cdr body))))
90 `(,(car body) (block ,name ,@(cdr body)))
91 `((block ,name ,@body)))))
102 (error "type-error"))))
104 (defmacro return (&optional value)
105 `(return-from nil ,value))
107 (defmacro while (condition &body body)
108 `(block nil (%while ,condition ,@body)))
110 (defvar *gensym-counter* 0)
111 (defun gensym (&optional (prefix "G"))
112 (setq *gensym-counter* (+ *gensym-counter* 1))
113 (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
119 (defun = (x y) (= x y))
120 (defun * (x y) (* x y))
121 (defun / (x y) (/ x y))
122 (defun 1+ (x) (+ x 1))
123 (defun 1- (x) (- x 1))
124 (defun zerop (x) (= x 0))
125 (defun truncate (x y) (floor (/ x y)))
127 (defun eql (x y) (eq x y))
129 (defun not (x) (if x nil t))
131 (defun cons (x y ) (cons x y))
132 (defun consp (x) (consp x))
135 "Return the CAR part of a cons, or NIL if X is null."
138 (defun cdr (x) (cdr x))
139 (defun caar (x) (car (car x)))
140 (defun cadr (x) (car (cdr x)))
141 (defun cdar (x) (cdr (car x)))
142 (defun cddr (x) (cdr (cdr x)))
143 (defun cadar (x) (car (cdr (car x))))
144 (defun caddr (x) (car (cdr (cdr x))))
145 (defun cdddr (x) (cdr (cdr (cdr x))))
146 (defun cadddr (x) (car (cdr (cdr (cdr x)))))
147 (defun first (x) (car x))
148 (defun second (x) (cadr x))
149 (defun third (x) (caddr x))
150 (defun fourth (x) (cadddr x))
151 (defun rest (x) (cdr x))
153 (defun list (&rest args) args)
159 (defmacro incf (x &optional (delta 1))
160 `(setq ,x (+ ,x ,delta)))
162 (defmacro decf (x &optional (delta 1))
163 `(setq ,x (- ,x ,delta)))
165 (defmacro push (x place)
166 (multiple-value-bind (dummies vals newval setter getter)
167 (get-setf-expansion place)
170 ,@(mapcar #'list dummies vals)
171 (,(car newval) (cons ,g ,getter))
175 (defmacro dolist (iter &body body)
176 (let ((var (first iter))
179 (let ((,g!list ,(second iter))
182 (setq ,var (car ,g!list))
184 (setq ,g!list (cdr ,g!list)))
187 (defmacro dotimes (iter &body body)
188 (let ((g!to (gensym))
191 (result (third iter)))
195 (%while (< ,var ,g!to)
200 (defmacro cond (&rest clausules)
203 (if (eq (caar clausules) t)
204 `(progn ,@(cdar clausules))
205 `(if ,(caar clausules)
206 (progn ,@(cdar clausules))
207 (cond ,@(cdr clausules))))))
209 (defmacro case (form &rest clausules)
210 (let ((!form (gensym)))
211 `(let ((,!form ,form))
213 ,@(mapcar (lambda (clausule)
214 (if (eq (car clausule) t)
216 `((eql ,!form ',(car clausule))
220 (defmacro ecase (form &rest clausules)
225 (error "ECASE expression failed."))))))
227 (defmacro and (&rest forms)
238 (defmacro or (&rest forms)
246 `(let ((,g ,(car forms)))
247 (if ,g ,g (or ,@(cdr forms))))))))
249 (defmacro prog1 (form &body body)
250 (let ((value (gensym)))
251 `(let ((,value ,form))
255 (defmacro prog2 (form1 result &body body)
256 `(prog1 (progn ,form1 ,result) ,@body)))
259 ;;; This couple of helper functions will be defined in both Common
260 ;;; Lisp and in Ecmalisp.
261 (defun ensure-list (x)
266 (defun !reduce (func list &key initial-value)
271 :initial-value (funcall func initial-value (car list)))))
273 (defmacro with-collect (&body body)
274 (let ((head (gensym))
276 `(let* ((,head (cons 'sentinel nil))
279 (rplacd ,tail (cons x nil))
280 (setq ,tail (cdr ,tail))
285 ;;; Go on growing the Lisp language in Ecmalisp, with more high
286 ;;; level utilities as well as correct versions of other
290 (defun + (&rest args)
295 (defun - (x &rest others)
302 (defun append-two (list1 list2)
306 (append (cdr list1) list2))))
308 (defun append (&rest lists)
309 (!reduce #'append-two lists))
311 (defun revappend (list1 list2)
313 (push (car list1) list2)
314 (setq list1 (cdr list1)))
317 (defun reverse (list)
318 (revappend list '()))
320 (defmacro psetq (&rest pairs)
321 (let ( ;; For each pair, we store here a list of the form
322 ;; (VARIABLE GENSYM VALUE).
326 ((null pairs) (return))
328 (error "Odd paris in PSETQ"))
330 (let ((variable (car pairs))
331 (value (cadr pairs)))
332 (push `(,variable ,(gensym) ,value) assignments)
333 (setq pairs (cddr pairs))))))
334 (setq assignments (reverse assignments))
336 `(let ,(mapcar #'cdr assignments)
337 (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
339 (defmacro do (varlist endlist &body body)
341 (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
344 (return (progn ,@(cdr endlist))))
349 (and (consp (cddr v))
350 (list (first v) (third v))))
353 (defmacro do* (varlist endlist &body body)
355 (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
358 (return (progn ,@(cdr endlist))))
363 (and (consp (cddr v))
364 (list (first v) (third v))))
367 (defun list-length (list)
369 (while (not (null list))
371 (setq list (cdr list)))
383 (defun concat-two (s1 s2)
386 (defun map1 (func list)
389 (collect (funcall func (car list)))
390 (setq list (cdr list)))))
392 (defmacro loop (&body body)
395 (defun mapcar (func list &rest lists)
396 (let ((lists (cons list lists)))
400 (let ((elems (map1 #'car lists)))
401 (do ((tail lists (cdr tail)))
403 (when (null (car tail)) (return-from loop))
404 (rplaca tail (cdar tail)))
405 (collect (apply func elems))))))))
407 (defun identity (x) x)
409 (defun constantly (x)
414 (mapcar #'identity x))
416 (defun list* (arg &rest others)
417 (cond ((null others) arg)
418 ((null (cdr others)) (cons arg (car others)))
419 (t (do ((x others (cdr x)))
420 ((null (cddr x)) (rplacd x (cadr x))))
423 (defun code-char (x) x)
424 (defun char-code (x) x)
425 (defun char= (x y) (= x y))
428 (and (numberp x) (= (floor x) x)))
430 (defun plusp (x) (< 0 x))
431 (defun minusp (x) (< x 0))
434 (or (consp x) (null x)))
436 (defun nthcdr (n list)
437 (while (and (plusp n) list)
439 (setq list (cdr list)))
443 (car (nthcdr n list)))
446 (while (consp (cdr x))
452 (cons (car x) (butlast (cdr x)))))
454 (defun member (x list)
456 (when (eql x (car list))
458 (setq list (cdr list))))
460 (defun find (item list &key key (test #'eql))
462 (when (funcall test (funcall key x) item)
465 (defun remove (x list)
470 (remove x (cdr list)))
472 (cons (car list) (remove x (cdr list))))))
474 (defun remove-if (func list)
478 ((funcall func (car list))
479 (remove-if func (cdr list)))
482 (cons (car list) (remove-if func (cdr list))))))
484 (defun remove-if-not (func list)
488 ((funcall func (car list))
489 (cons (car list) (remove-if-not func (cdr list))))
491 (remove-if-not func (cdr list)))))
493 (defun digit-char-p (x)
494 (if (and (<= #\0 x) (<= x #\9))
498 (defun digit-char (weight)
500 (char "0123456789" weight)))
502 (defun subseq (seq a &optional b)
509 (error "Unsupported argument."))))
511 (defmacro do-sequence (iteration &body body)
514 `(let ((,seq ,(second iteration)))
519 (dotimes (,index (length ,seq))
520 (let ((,(first iteration)
525 (dolist (,(first iteration) ,seq)
528 (error "type-error!"))))))
530 (defun some (function seq)
531 (do-sequence (elt seq)
532 (when (funcall function elt)
533 (return-from some t))))
535 (defun every (function seq)
536 (do-sequence (elt seq)
537 (unless (funcall function elt)
538 (return-from every nil)))
541 (defun position (elt sequence)
549 (defun assoc (x alist)
551 (if (eql x (caar alist))
553 (setq alist (cdr alist))))
557 (cond ((stringp x) x)
558 ((symbolp x) (symbol-name x))
559 (t (char-to-string x))))
561 (defun string= (s1 s2)
564 (defun fdefinition (x)
571 (error "Invalid function"))))
573 (defun disassemble (function)
574 (write-line (lambda-code (fdefinition function)))
577 (defun documentation (x type)
578 "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
581 (let ((func (fdefinition x)))
582 (oget func "docstring")))
585 (error "Wrong argument type! it should be a symbol"))
588 (defmacro multiple-value-bind (variables value-from &body body)
589 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
593 (defmacro multiple-value-list (value-from)
594 `(multiple-value-call #'list ,value-from))
597 ;;; Generalized references (SETF)
599 (defvar *setf-expanders* nil)
601 (defun get-setf-expansion (place)
603 (let ((value (gensym)))
607 `(setq ,place ,value)
609 (let ((place (ls-macroexpand-1 place)))
610 (let* ((access-fn (car place))
611 (expander (cdr (assoc access-fn *setf-expanders*))))
612 (when (null expander)
613 (error "Unknown generalized reference."))
614 (apply expander (cdr place))))))
616 (defmacro define-setf-expander (access-fn lambda-list &body body)
617 (unless (symbolp access-fn)
618 (error "ACCESS-FN must be a symbol."))
619 `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
623 (defmacro setf (&rest pairs)
628 (error "Odd number of arguments to setf."))
630 (let ((place (ls-macroexpand-1 (first pairs)))
631 (value (second pairs)))
632 (multiple-value-bind (vars vals store-vars writer-form reader-form)
633 (get-setf-expansion place)
634 ;; TODO: Optimize the expansion a little bit to avoid let*
635 ;; or multiple-value-bind when unnecesary.
636 `(let* ,(mapcar #'list vars vals)
637 (multiple-value-bind ,store-vars
642 ,@(do ((pairs pairs (cddr pairs))
643 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
645 (reverse result)))))))
647 (define-setf-expander car (x)
648 (let ((cons (gensym))
649 (new-value (gensym)))
653 `(progn (rplaca ,cons ,new-value) ,new-value)
656 (define-setf-expander cdr (x)
657 (let ((cons (gensym))
658 (new-value (gensym)))
662 `(progn (rplacd ,cons ,new-value) ,new-value)
665 ;; Incorrect typecase, but used in NCONC.
666 (defmacro typecase (x &rest clausules)
667 (let ((value (gensym)))
670 ,@(mapcar (lambda (c)
684 ;; The NCONC function is based on the SBCL's one.
685 (defun nconc (&rest lists)
686 (flet ((fail (object)
687 (error "type-error in nconc")))
688 (do ((top lists (cdr top)))
690 (let ((top-of-top (car top)))
693 (let* ((result top-of-top)
695 (do ((elements (cdr top) (cdr elements)))
697 (let ((ele (car elements)))
699 (cons (rplacd (last splice) ele)
701 (null (rplacd (last splice) nil))
702 (atom (if (cdr elements)
704 (rplacd (last splice) ele))))))
710 (return top-of-top))))))))
713 (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
714 (2nd x 1st) ; 2nd follows first down the list.
715 (3rd y 2nd)) ;3rd follows 2nd down the list.
719 (defun notany (fn seq)
725 (defvar *package-list* nil)
727 (defun list-all-packages ()
730 (defun make-package (name &key use)
731 (let ((package (new))
732 (use (mapcar #'find-package-or-fail use)))
733 (oset package "packageName" name)
734 (oset package "symbols" (new))
735 (oset package "exports" (new))
736 (oset package "use" use)
737 (push package *package-list*)
741 (and (objectp x) (in "symbols" x)))
743 (defun find-package (package-designator)
744 (when (packagep package-designator)
745 (return-from find-package package-designator))
746 (let ((name (string package-designator)))
747 (dolist (package *package-list*)
748 (when (string= (package-name package) name)
751 (defun find-package-or-fail (package-designator)
752 (or (find-package package-designator)
753 (error "Package unknown.")))
755 (defun package-name (package-designator)
756 (let ((package (find-package-or-fail package-designator)))
757 (oget package "packageName")))
759 (defun %package-symbols (package-designator)
760 (let ((package (find-package-or-fail package-designator)))
761 (oget package "symbols")))
763 (defun package-use-list (package-designator)
764 (let ((package (find-package-or-fail package-designator)))
765 (oget package "use")))
767 (defun %package-external-symbols (package-designator)
768 (let ((package (find-package-or-fail package-designator)))
769 (oget package "exports")))
771 (defvar *common-lisp-package*
777 (defvar *user-package*
778 (make-package "CL-USER" :use (list *common-lisp-package*)))
780 (defvar *keyword-package*
781 (make-package "KEYWORD"))
784 (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
786 (defvar *package* *common-lisp-package*)
788 (defmacro in-package (package-designator)
790 (setq *package* (find-package-or-fail ,package-designator))))
792 ;; This function is used internally to initialize the CL package
793 ;; with the symbols built during bootstrap.
794 (defun %intern-symbol (symbol)
796 (if (in "package" symbol)
797 (find-package-or-fail (oget symbol "package"))
798 *common-lisp-package*))
799 (symbols (%package-symbols package)))
800 (oset symbol "package" package)
801 (when (eq package *keyword-package*)
802 (oset symbol "value" symbol))
803 (oset symbols (symbol-name symbol) symbol)))
805 (defun find-symbol (name &optional (package *package*))
806 (let* ((package (find-package-or-fail package))
807 (externals (%package-external-symbols package))
808 (symbols (%package-symbols package)))
811 (values (oget externals name) :external))
813 (values (oget symbols name) :internal))
815 (dolist (used (package-use-list package) (values nil nil))
816 (let ((exports (%package-external-symbols used)))
817 (when (in name exports)
818 (return (values (oget exports name) :inherit)))))))))
820 (defun intern (name &optional (package *package*))
821 (let ((package (find-package-or-fail package)))
822 (multiple-value-bind (symbol foundp)
823 (find-symbol name package)
825 (values symbol foundp)
826 (let ((symbols (%package-symbols package)))
828 (let ((symbol (make-symbol name)))
829 (oset symbol "package" package)
830 (when (eq package *keyword-package*)
831 (oset symbol "value" symbol)
832 (export (list symbol) package))
833 (when (eq package *js-package*)
834 (let ((sym-name (symbol-name symbol))
836 ;; Generate a trampoline to call the JS function
837 ;; properly. This trampoline is very inefficient,
838 ;; but it still works. Ideas to optimize this are
839 ;; provide a special lambda keyword
840 ;; cl::&rest-vector to avoid list argument
841 ;; consing, as well as allow inline declarations.
843 (eval `(lambda (&rest ,args)
844 (let ((,args (list-to-vector ,args)))
845 (%js-call (%js-vref ,sym-name) ,args)))))
846 ;; Define it as a symbol macro to access to the
847 ;; Javascript variable literally.
848 (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
849 (oset symbols name symbol)
850 (values symbol nil)))))))
852 (defun symbol-package (symbol)
853 (unless (symbolp symbol)
854 (error "it is not a symbol"))
855 (oget symbol "package"))
857 (defun export (symbols &optional (package *package*))
858 (let ((exports (%package-external-symbols package)))
859 (dolist (symb symbols t)
860 (oset exports (symbol-name symb) symb))))
862 (defun get-universal-time ()
863 (+ (get-unix-time) 2208988800)))
866 ;;; The compiler offers some primitives and special forms which are
867 ;;; not found in Common Lisp, for instance, while. So, we grow Common
868 ;;; Lisp a bit to it can execute the rest of the file.
871 (defmacro while (condition &body body)
876 (defmacro eval-when-compile (&body body)
877 `(eval-when (:compile-toplevel :load-toplevel :execute)
880 (defun concat-two (s1 s2)
881 (concatenate 'string s1 s2))
883 (defun aset (array idx value)
884 (setf (aref array idx) value)))
886 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
887 ;;; from here, this code will compile on both. We define some helper
888 ;;; functions now for string manipulation and so on. They will be
889 ;;; useful in the compiler, mostly.
891 (defvar *newline* (string (code-char 10)))
894 (defun concat (&rest strs)
895 (!reduce #'concat-two strs :initial-value ""))
897 (eval-when (:compile-toplevel :load-toplevel :execute)
898 (defun concat (&rest strs)
899 (apply #'concatenate 'string strs)))
901 (defmacro concatf (variable &body form)
902 `(setq ,variable (concat ,variable (progn ,@form))))
904 ;;; Concatenate a list of strings, with a separator
905 (defun join (list &optional (separator ""))
914 (join (cdr list) separator)))))
916 (defun join-trailing (list &optional (separator ""))
919 (concat (car list) separator (join-trailing (cdr list) separator))))
921 (defun mapconcat (func list)
922 (join (mapcar func list)))
924 (defun vector-to-list (vector)
926 (size (length vector)))
927 (dotimes (i size (reverse list))
928 (push (aref vector i) list))))
930 (defun list-to-vector (list)
931 (let ((v (make-array (length list)))
937 (defmacro awhen (condition &body body)
938 `(let ((it ,condition))
943 (defun values-list (list)
944 (values-array (list-to-vector list)))
946 (defun values (&rest args)
949 (defun integer-to-string (x)
954 (concat "-" (integer-to-string (- 0 x))))
957 (while (not (zerop x))
958 (push (mod x 10) digits)
959 (setq x (truncate x 10)))
960 (mapconcat (lambda (x) (string (digit-char x)))
968 (defun prin1-to-string (form)
971 (multiple-value-bind (symbol foundp)
972 (find-symbol (symbol-name form) *package*)
973 (if (and foundp (eq symbol form))
975 (let ((package (symbol-package form))
976 (name (symbol-name form)))
979 ((eq package (find-package "KEYWORD")) "")
980 (t (package-name package)))
982 ((integerp form) (integer-to-string form))
983 ((stringp form) (concat "\"" (escape-string form) "\""))
985 (let ((name (oget form "fname")))
987 (concat "#<FUNCTION " name ">")
988 (concat "#<FUNCTION>"))))
991 (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
992 (let ((last (last form)))
993 (if (null (cdr last))
994 (prin1-to-string (car last))
995 (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
998 (concat "#" (if (zerop (length form))
1000 (prin1-to-string (vector-to-list form)))))
1002 (concat "#<PACKAGE " (package-name form) ">"))
1004 (concat "#<javascript object>"))))
1006 (defun write-line (x)
1008 (write-string *newline*)
1011 (defun warn (string)
1012 (write-string "WARNING: ")
1013 (write-line string))
1016 (write-line (prin1-to-string x))
1023 ;;; The Lisp reader, parse strings and return Lisp objects. The main
1024 ;;; entry points are `ls-read' and `ls-read-from-string'.
1026 (defun make-string-stream (string)
1029 (defun %peek-char (stream)
1030 (and (< (cdr stream) (length (car stream)))
1031 (char (car stream) (cdr stream))))
1033 (defun %read-char (stream)
1034 (and (< (cdr stream) (length (car stream)))
1035 (prog1 (char (car stream) (cdr stream))
1036 (rplacd stream (1+ (cdr stream))))))
1038 (defun whitespacep (ch)
1039 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
1041 (defun skip-whitespaces (stream)
1043 (setq ch (%peek-char stream))
1044 (while (and ch (whitespacep ch))
1046 (setq ch (%peek-char stream)))))
1048 (defun terminalp (ch)
1049 (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
1051 (defun read-until (stream func)
1054 (setq ch (%peek-char stream))
1055 (while (and ch (not (funcall func ch)))
1056 (setq string (concat string (string ch)))
1058 (setq ch (%peek-char stream)))
1061 (defun skip-whitespaces-and-comments (stream)
1063 (skip-whitespaces stream)
1064 (setq ch (%peek-char stream))
1065 (while (and ch (char= ch #\;))
1066 (read-until stream (lambda (x) (char= x #\newline)))
1067 (skip-whitespaces stream)
1068 (setq ch (%peek-char stream)))))
1070 (defun %read-list (stream)
1071 (skip-whitespaces-and-comments stream)
1072 (let ((ch (%peek-char stream)))
1075 (error "Unspected EOF"))
1081 (prog1 (ls-read stream)
1082 (skip-whitespaces-and-comments stream)
1083 (unless (char= (%read-char stream) #\))
1084 (error "')' was expected."))))
1086 (cons (ls-read stream) (%read-list stream))))))
1088 (defun read-string (stream)
1091 (setq ch (%read-char stream))
1092 (while (not (eql ch #\"))
1094 (error "Unexpected EOF"))
1096 (setq ch (%read-char stream)))
1097 (setq string (concat string (string ch)))
1098 (setq ch (%read-char stream)))
1101 (defun read-sharp (stream)
1103 (ecase (%read-char stream)
1105 (list 'function (ls-read stream)))
1106 (#\( (list-to-vector (%read-list stream)))
1107 (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
1110 (concat (string (%read-char stream))
1111 (read-until stream #'terminalp))))
1113 ((string= cname "space") (char-code #\space))
1114 ((string= cname "tab") (char-code #\tab))
1115 ((string= cname "newline") (char-code #\newline))
1116 (t (char-code (char cname 0))))))
1118 (let ((feature (read-until stream #'terminalp)))
1120 ((string= feature "common-lisp")
1121 (ls-read stream) ;ignore
1123 ((string= feature "ecmalisp")
1126 (error "Unknown reader form.")))))))
1128 ;;; Parse a string of the form NAME, PACKAGE:NAME or
1129 ;;; PACKAGE::NAME and return the name. If the string is of the
1130 ;;; form 1) or 3), but the symbol does not exist, it will be created
1131 ;;; and interned in that package.
1132 (defun read-symbol (string)
1133 (let ((size (length string))
1134 package name internalp index)
1136 (while (and (< index size)
1137 (not (char= (char string index) #\:)))
1140 ;; No package prefix
1143 (setq package *package*)
1148 (setq package "KEYWORD")
1149 (setq package (string-upcase (subseq string 0 index))))
1151 (when (char= (char string index) #\:)
1154 (setq name (subseq string index))))
1155 ;; Canonalize symbol name and package
1156 (when (not (eq package "JS"))
1157 (setq name (string-upcase name)))
1158 (setq package (find-package package))
1159 ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
1160 ;; external symbol from PACKAGE.
1162 (eq package (find-package "KEYWORD"))
1163 (eq package (find-package "JS")))
1164 (intern name package)
1165 (find-symbol name package))))
1168 (defun !parse-integer (string junk-allow)
1172 (size (length string))
1174 ;; Leading whitespace
1175 (while (and (< index size)
1176 (whitespacep (char string index)))
1178 (unless (< index size) (return (values nil 0)))
1180 (case (char string 0)
1185 (unless (and (< index size)
1186 (setq value (digit-char-p (char string index))))
1187 (return (values nil index)))
1190 (while (< index size)
1191 (let ((digit (digit-char-p (char string index))))
1192 (unless digit (return))
1193 (setq value (+ (* value 10) digit))
1195 ;; Trailing whitespace
1196 (do ((i index (1+ i)))
1197 ((or (= i size) (not (whitespacep (char string i))))
1198 (and (= i size) (setq index i))))
1201 (values (* sign value) index)
1202 (values nil index)))))
1205 (defun parse-integer (string &key junk-allowed)
1206 (multiple-value-bind (num index)
1207 (!parse-integer string junk-allowed)
1210 (error "junk detected."))))
1212 (defvar *eof* (gensym))
1213 (defun ls-read (stream)
1214 (skip-whitespaces-and-comments stream)
1215 (let ((ch (%peek-char stream)))
1217 ((or (null ch) (char= ch #\)))
1221 (%read-list stream))
1224 (list 'quote (ls-read stream)))
1227 (list 'backquote (ls-read stream)))
1230 (read-string stream))
1233 (if (eql (%peek-char stream) #\@)
1234 (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
1235 (list 'unquote (ls-read stream))))
1237 (read-sharp stream))
1239 (let ((string (read-until stream #'terminalp)))
1240 (or (values (!parse-integer string nil))
1241 (read-symbol string)))))))
1243 (defun ls-read-from-string (string)
1244 (ls-read (make-string-stream string)))
1249 ;;; Translate the Lisp code to Javascript. It will compile the special
1250 ;;; forms. Some primitive functions are compiled as special forms
1251 ;;; too. The respective real functions are defined in the target (see
1252 ;;; the beginning of this file) as well as some primitive functions.
1254 (defun code (&rest args)
1255 (mapconcat (lambda (arg)
1258 ((integerp arg) (integer-to-string arg))
1260 (t (error "Unknown argument."))))
1263 ;;; Wrap X with a Javascript code to convert the result from
1264 ;;; Javascript generalized booleans to T or NIL.
1266 (code "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
1268 ;;; Concatenate the arguments and wrap them with a self-calling
1269 ;;; Javascript anonymous function. It is used to make some Javascript
1270 ;;; statements valid expressions and provide a private scope as well.
1271 ;;; It could be defined as function, but we could do some
1272 ;;; preprocessing in the future.
1273 (defmacro js!selfcall (&body body)
1274 `(code "(function(){" *newline* (indent ,@body) "})()"))
1276 ;;; Like CODE, but prefix each line with four spaces. Two versions
1277 ;;; of this function are available, because the Ecmalisp version is
1278 ;;; very slow and bootstraping was annoying.
1281 (defun indent (&rest string)
1282 (let ((input (apply #'code string)))
1285 (size (length input)))
1286 (when (plusp (length input)) (concatf output " "))
1287 (while (< index size)
1289 (if (and (char= (char input index) #\newline)
1291 (not (char= (char input (1+ index)) #\newline)))
1292 (concat (string #\newline) " ")
1293 (string (char input index)))))
1294 (concatf output str))
1299 (defun indent (&rest string)
1300 (with-output-to-string (*standard-output*)
1301 (with-input-from-string (input (apply #'code string))
1303 for line = (read-line input nil)
1305 do (write-string " ")
1306 do (write-line line)))))
1309 ;;; A Form can return a multiple values object calling VALUES, like
1310 ;;; values(arg1, arg2, ...). It will work in any context, as well as
1311 ;;; returning an individual object. However, if the special variable
1312 ;;; `*multiple-value-p*' is NIL, is granted that only the primary
1313 ;;; value will be used, so we can optimize to avoid the VALUES
1315 (defvar *multiple-value-p* nil)
1317 ;; A very simple defstruct built on lists. It supports just slot with
1318 ;; an optional default initform, and it will create a constructor,
1319 ;; predicate and accessors for you.
1320 (defmacro def!struct (name &rest slots)
1321 (unless (symbolp name)
1322 (error "It is not a full defstruct implementation."))
1323 (let* ((name-string (symbol-name name))
1325 (mapcar (lambda (sd)
1329 ((and (listp sd) (car sd) (cddr sd))
1332 (error "Bad slot accessor."))))
1334 (predicate (intern (concat name-string "-P"))))
1337 (defun ,(intern (concat "MAKE-" name-string)) (&key ,@slot-descriptions)
1338 (list ',name ,@(mapcar #'car slot-descriptions)))
1340 (defun ,predicate (x)
1341 (and (consp x) (eq (car x) ',name)))
1343 (defun ,(intern (concat "COPY-" name-string)) (x)
1348 (dolist (slot slot-descriptions)
1349 (let* ((name (car slot))
1350 (accessor-name (intern (concat name-string "-" (string name)))))
1352 `(defun ,accessor-name (x)
1353 (unless (,predicate x)
1354 (error ,(concat "The object is not a type " name-string)))
1356 ;; TODO: Implement this with a higher level
1357 ;; abstraction like defsetf or (defun (setf ..))
1359 `(define-setf-expander ,accessor-name (x)
1360 (let ((object (gensym))
1361 (new-value (gensym)))
1362 (values (list object)
1366 (rplaca (nthcdr ,',index ,object) ,new-value)
1368 `(,',accessor-name ,object)))))
1380 ;; This slot is using during bootstrapping in order to speed up the
1381 ;; compilation time. The reason is we store the macro expanders as
1382 ;; lists, but we do not want to compile the definition multiple
1384 #+common-lisp cache)
1392 (defun lookup-in-lexenv (name lexenv namespace)
1393 (find name (ecase namespace
1394 (variable (lexenv-variable lexenv))
1395 (function (lexenv-function lexenv))
1396 (block (lexenv-block lexenv))
1397 (gotag (lexenv-gotag lexenv)))
1398 :key #'binding-name))
1400 (defun push-to-lexenv (binding lexenv namespace)
1402 (variable (push binding (lexenv-variable lexenv)))
1403 (function (push binding (lexenv-function lexenv)))
1404 (block (push binding (lexenv-block lexenv)))
1405 (gotag (push binding (lexenv-gotag lexenv)))))
1407 (defun extend-lexenv (bindings lexenv namespace)
1408 (let ((env (copy-lexenv lexenv)))
1409 (dolist (binding (reverse bindings) env)
1410 (push-to-lexenv binding env namespace))))
1413 (defvar *environment* (make-lexenv))
1415 (defvar *variable-counter* 0)
1417 (defun gvarname (symbol)
1418 (code "v" (incf *variable-counter*)))
1420 (defun translate-variable (symbol)
1421 (awhen (lookup-in-lexenv symbol *environment* 'variable)
1422 (binding-value it)))
1424 (defun extend-local-env (args)
1425 (let ((new (copy-lexenv *environment*)))
1426 (dolist (symbol args new)
1427 (let ((b (make-binding :name symbol :type 'variable :value (gvarname symbol))))
1428 (push-to-lexenv b new 'variable)))))
1430 ;;; Toplevel compilations
1431 (defvar *toplevel-compilations* nil)
1433 (defun toplevel-compilation (string)
1434 (push string *toplevel-compilations*))
1436 (defun null-or-empty-p (x)
1439 (defun get-toplevel-compilations ()
1440 (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
1442 (defun %compile-defmacro (name lambda)
1443 (toplevel-compilation (ls-compile `',name))
1444 (let ((binding (make-binding :name name :type 'macro :value lambda)))
1445 (push-to-lexenv binding *environment* 'function))
1448 (defun global-binding (name type namespace)
1449 (or (lookup-in-lexenv name *environment* namespace)
1450 (let ((b (make-binding :name name :type type :value nil)))
1451 (push-to-lexenv b *environment* namespace)
1454 (defun claimp (symbol namespace claim)
1455 (let ((b (lookup-in-lexenv symbol *environment* namespace)))
1456 (and b (member claim (binding-declarations b)))))
1458 (defun !proclaim (decl)
1461 (dolist (name (cdr decl))
1462 (let ((b (global-binding name 'variable 'variable)))
1463 (push 'special (binding-declarations b)))))
1465 (dolist (name (cdr decl))
1466 (let ((b (global-binding name 'function 'function)))
1467 (push 'notinline (binding-declarations b)))))
1469 (dolist (name (cdr decl))
1470 (let ((b (global-binding name 'variable 'variable)))
1471 (push 'constant (binding-declarations b)))))))
1474 (fset 'proclaim #'!proclaim)
1476 (defun %define-symbol-macro (name expansion)
1477 (let ((b (make-binding :name name :type 'macro :value expansion)))
1478 (push-to-lexenv b *environment* 'variable)
1482 (defmacro define-symbol-macro (name expansion)
1483 `(%define-symbol-macro ',name ',expansion))
1488 (defvar *compilations* nil)
1490 (defmacro define-compilation (name args &body body)
1491 ;; Creates a new primitive `name' with parameters args and
1492 ;; @body. The body can access to the local environment through the
1493 ;; variable *ENVIRONMENT*.
1494 `(push (list ',name (lambda ,args (block ,name ,@body)))
1497 (define-compilation if (condition true false)
1498 (code "(" (ls-compile condition) " !== " (ls-compile nil)
1499 " ? " (ls-compile true *multiple-value-p*)
1500 " : " (ls-compile false *multiple-value-p*)
1503 (defvar *ll-keywords* '(&optional &rest &key))
1505 (defun list-until-keyword (list)
1506 (if (or (null list) (member (car list) *ll-keywords*))
1508 (cons (car list) (list-until-keyword (cdr list)))))
1510 (defun ll-section (keyword ll)
1511 (list-until-keyword (cdr (member keyword ll))))
1513 (defun ll-required-arguments (ll)
1514 (list-until-keyword ll))
1516 (defun ll-optional-arguments-canonical (ll)
1517 (mapcar #'ensure-list (ll-section '&optional ll)))
1519 (defun ll-optional-arguments (ll)
1520 (mapcar #'car (ll-optional-arguments-canonical ll)))
1522 (defun ll-rest-argument (ll)
1523 (let ((rest (ll-section '&rest ll)))
1525 (error "Bad lambda-list"))
1528 (defun ll-keyword-arguments-canonical (ll)
1529 (flet ((canonicalize (keyarg)
1530 ;; Build a canonical keyword argument descriptor, filling
1531 ;; the optional fields. The result is a list of the form
1532 ;; ((keyword-name var) init-form).
1533 (let ((arg (ensure-list keyarg)))
1534 (cons (if (listp (car arg))
1536 (list (intern (symbol-name (car arg)) "KEYWORD") (car arg)))
1538 (mapcar #'canonicalize (ll-section '&key ll))))
1540 (defun ll-keyword-arguments (ll)
1541 (mapcar (lambda (keyarg) (second (first keyarg)))
1542 (ll-keyword-arguments-canonical ll)))
1544 (defun ll-svars (lambda-list)
1547 (ll-keyword-arguments-canonical lambda-list)
1548 (ll-optional-arguments-canonical lambda-list))))
1549 (remove nil (mapcar #'third args))))
1551 (defun lambda-docstring-wrapper (docstring &rest strs)
1554 "var func = " (join strs) ";" *newline*
1555 "func.docstring = '" docstring "';" *newline*
1556 "return func;" *newline*)
1557 (apply #'code strs)))
1559 (defun lambda-check-argument-count
1560 (n-required-arguments n-optional-arguments rest-p)
1561 ;; Note: Remember that we assume that the number of arguments of a
1562 ;; call is at least 1 (the values argument).
1563 (let ((min (1+ n-required-arguments))
1564 (max (if rest-p 'n/a (+ 1 n-required-arguments n-optional-arguments))))
1566 ;; Special case: a positive exact number of arguments.
1567 (when (and (< 1 min) (eql min max))
1568 (return (code "checkArgs(arguments, " min ");" *newline*)))
1572 (code "checkArgsAtLeast(arguments, " min ");" *newline*))
1574 (code "checkArgsAtMost(arguments, " max ");" *newline*))))))
1576 (defun compile-lambda-optional (ll)
1577 (let* ((optional-arguments (ll-optional-arguments-canonical ll))
1578 (n-required-arguments (length (ll-required-arguments ll)))
1579 (n-optional-arguments (length optional-arguments)))
1580 (when optional-arguments
1581 (code (mapconcat (lambda (arg)
1582 (code "var " (translate-variable (first arg)) "; " *newline*
1584 (code "var " (translate-variable (third arg))
1585 " = " (ls-compile t)
1588 "switch(arguments.length-1){" *newline*
1592 (while (< idx n-optional-arguments)
1593 (let ((arg (nth idx optional-arguments)))
1594 (push (code "case " (+ idx n-required-arguments) ":" *newline*
1595 (indent (translate-variable (car arg))
1597 (ls-compile (cadr arg)) ";" *newline*)
1599 (indent (translate-variable (third arg))
1605 (push (code "default: break;" *newline*) cases)
1606 (join (reverse cases))))
1609 (defun compile-lambda-rest (ll)
1610 (let ((n-required-arguments (length (ll-required-arguments ll)))
1611 (n-optional-arguments (length (ll-optional-arguments ll)))
1612 (rest-argument (ll-rest-argument ll)))
1614 (let ((js!rest (translate-variable rest-argument)))
1615 (code "var " js!rest "= " (ls-compile nil) ";" *newline*
1616 "for (var i = arguments.length-1; i>="
1617 (+ 1 n-required-arguments n-optional-arguments)
1619 (indent js!rest " = {car: arguments[i], cdr: ") js!rest "};"
1622 (defun compile-lambda-parse-keywords (ll)
1623 (let ((n-required-arguments
1624 (length (ll-required-arguments ll)))
1625 (n-optional-arguments
1626 (length (ll-optional-arguments ll)))
1628 (ll-keyword-arguments-canonical ll)))
1630 ;; Declare variables
1631 (mapconcat (lambda (arg)
1632 (let ((var (second (car arg))))
1633 (code "var " (translate-variable var) "; " *newline*
1635 (code "var " (translate-variable (third arg))
1636 " = " (ls-compile nil)
1640 (flet ((parse-keyword (keyarg)
1641 ;; ((keyword-name var) init-form)
1642 (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
1643 "; i<arguments.length; i+=2){" *newline*
1645 "if (arguments[i] === " (ls-compile (caar keyarg)) "){" *newline*
1646 (indent (translate-variable (cadr (car keyarg)))
1647 " = arguments[i+1];"
1649 (let ((svar (third keyarg)))
1651 (code (translate-variable svar) " = " (ls-compile t) ";" *newline*)))
1656 "if (i == arguments.length){" *newline*
1657 (indent (translate-variable (cadr (car keyarg))) " = " (ls-compile (cadr keyarg)) ";" *newline*)
1659 (when keyword-arguments
1660 (code "var i;" *newline*
1661 (mapconcat #'parse-keyword keyword-arguments))))
1662 ;; Check for unknown keywords
1663 (when keyword-arguments
1664 (code "for (i=" (+ 1 n-required-arguments n-optional-arguments)
1665 "; i<arguments.length; i+=2){" *newline*
1667 (join (mapcar (lambda (x)
1668 (concat "arguments[i] !== " (ls-compile (caar x))))
1673 "throw 'Unknown keyword argument ' + arguments[i].name;" *newline*))
1676 (defun compile-lambda (ll body)
1677 (let ((required-arguments (ll-required-arguments ll))
1678 (optional-arguments (ll-optional-arguments ll))
1679 (keyword-arguments (ll-keyword-arguments ll))
1680 (rest-argument (ll-rest-argument ll))
1682 ;; Get the documentation string for the lambda function
1683 (when (and (stringp (car body))
1684 (not (null (cdr body))))
1685 (setq documentation (car body))
1686 (setq body (cdr body)))
1687 (let ((n-required-arguments (length required-arguments))
1688 (n-optional-arguments (length optional-arguments))
1689 (*environment* (extend-local-env
1690 (append (ensure-list rest-argument)
1695 (lambda-docstring-wrapper
1698 (join (cons "values"
1699 (mapcar #'translate-variable
1700 (append required-arguments optional-arguments)))
1704 ;; Check number of arguments
1705 (lambda-check-argument-count n-required-arguments
1706 n-optional-arguments
1707 (or rest-argument keyword-arguments))
1708 (compile-lambda-optional ll)
1709 (compile-lambda-rest ll)
1710 (compile-lambda-parse-keywords ll)
1711 (let ((*multiple-value-p* t))
1712 (ls-compile-block body t)))
1716 (defun setq-pair (var val)
1717 (let ((b (lookup-in-lexenv var *environment* 'variable)))
1720 (eq (binding-type b) 'variable)
1721 (not (member 'special (binding-declarations b)))
1722 (not (member 'constant (binding-declarations b))))
1723 (code (binding-value b) " = " (ls-compile val)))
1724 ((and b (eq (binding-type b) 'macro))
1725 (ls-compile `(setf ,var ,val)))
1727 (ls-compile `(set ',var ,val))))))
1730 (define-compilation setq (&rest pairs)
1734 ((null pairs) (return))
1736 (error "Odd paris in SETQ"))
1739 (concat (setq-pair (car pairs) (cadr pairs))
1740 (if (null (cddr pairs)) "" ", ")))
1741 (setq pairs (cddr pairs)))))
1742 (code "(" result ")")))
1746 (defun escape-string (string)
1749 (size (length string)))
1750 (while (< index size)
1751 (let ((ch (char string index)))
1752 (when (or (char= ch #\") (char= ch #\\))
1753 (setq output (concat output "\\")))
1754 (when (or (char= ch #\newline))
1755 (setq output (concat output "\\"))
1757 (setq output (concat output (string ch))))
1762 (defvar *literal-symbols* nil)
1763 (defvar *literal-counter* 0)
1766 (code "l" (incf *literal-counter*)))
1768 (defun literal (sexp &optional recursive)
1770 ((integerp sexp) (integer-to-string sexp))
1771 ((stringp sexp) (code "\"" (escape-string sexp) "\""))
1773 (or (cdr (assoc sexp *literal-symbols*))
1776 (let ((package (symbol-package sexp)))
1777 (if (eq package (find-package "KEYWORD"))
1778 (code "{name: \"" (escape-string (symbol-name sexp))
1779 "\", 'package': '" (package-name package) "'}")
1780 (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")))
1782 (let ((package (symbol-package sexp)))
1784 (code "{name: \"" (escape-string (symbol-name sexp)) "\"}")
1785 (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
1786 (push (cons sexp v) *literal-symbols*)
1787 (toplevel-compilation (code "var " v " = " s))
1790 (let* ((head (butlast sexp))
1793 (join-trailing (mapcar (lambda (x) (literal x t)) head) ",")
1794 (literal (car tail) t)
1796 (literal (cdr tail) t)
1801 (toplevel-compilation (code "var " v " = " c))
1804 (let ((elements (vector-to-list sexp)))
1805 (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
1809 (toplevel-compilation (code "var " v " = " c))
1812 (define-compilation quote (sexp)
1815 (define-compilation %while (pred &rest body)
1817 "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
1818 (indent (ls-compile-block body))
1820 "return " (ls-compile nil) ";" *newline*))
1822 (define-compilation function (x)
1824 ((and (listp x) (eq (car x) 'lambda))
1825 (compile-lambda (cadr x) (cddr x)))
1827 (let ((b (lookup-in-lexenv x *environment* 'function)))
1830 (ls-compile `(symbol-function ',x)))))))
1833 (defun make-function-binding (fname)
1834 (make-binding :name fname :type 'function :value (gvarname fname)))
1836 (defun compile-function-definition (list)
1837 (compile-lambda (car list) (cdr list)))
1839 (defun translate-function (name)
1840 (let ((b (lookup-in-lexenv name *environment* 'function)))
1841 (and b (binding-value b))))
1843 (define-compilation flet (definitions &rest body)
1844 (let* ((fnames (mapcar #'car definitions))
1845 (fbody (mapcar #'cdr definitions))
1846 (cfuncs (mapcar #'compile-function-definition fbody))
1848 (extend-lexenv (mapcar #'make-function-binding fnames)
1852 (join (mapcar #'translate-function fnames) ",")
1854 (let ((body (ls-compile-block body t)))
1856 "})(" (join cfuncs ",") ")")))
1858 (define-compilation labels (definitions &rest body)
1859 (let* ((fnames (mapcar #'car definitions))
1861 (extend-lexenv (mapcar #'make-function-binding fnames)
1865 (mapconcat (lambda (func)
1866 (code "var " (translate-function (car func))
1867 " = " (compile-lambda (cadr func) (cddr func))
1870 (ls-compile-block body t))))
1873 (defvar *compiling-file* nil)
1874 (define-compilation eval-when-compile (&rest body)
1875 (if *compiling-file*
1877 (eval (cons 'progn body))
1879 (ls-compile `(progn ,@body))))
1881 (defmacro define-transformation (name args form)
1882 `(define-compilation ,name ,args
1883 (ls-compile ,form)))
1885 (define-compilation progn (&rest body)
1886 (if (null (cdr body))
1887 (ls-compile (car body) *multiple-value-p*)
1888 (js!selfcall (ls-compile-block body t))))
1890 (defun special-variable-p (x)
1891 (and (claimp x 'variable 'special) t))
1893 ;;; Wrap CODE to restore the symbol values of the dynamic
1894 ;;; bindings. BINDINGS is a list of pairs of the form
1895 ;;; (SYMBOL . PLACE), where PLACE is a Javascript variable
1896 ;;; name to initialize the symbol value and where to stored
1898 (defun let-binding-wrapper (bindings body)
1899 (when (null bindings)
1900 (return-from let-binding-wrapper body))
1903 (indent "var tmp;" *newline*
1906 (let ((s (ls-compile `(quote ,(car b)))))
1907 (code "tmp = " s ".value;" *newline*
1908 s ".value = " (cdr b) ";" *newline*
1909 (cdr b) " = tmp;" *newline*)))
1913 "finally {" *newline*
1915 (mapconcat (lambda (b)
1916 (let ((s (ls-compile `(quote ,(car b)))))
1917 (code s ".value" " = " (cdr b) ";" *newline*)))
1921 (define-compilation let (bindings &rest body)
1922 (let* ((bindings (mapcar #'ensure-list bindings))
1923 (variables (mapcar #'first bindings))
1924 (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
1925 (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
1928 (join (mapcar (lambda (x)
1929 (if (special-variable-p x)
1930 (let ((v (gvarname x)))
1931 (push (cons x v) dynamic-bindings)
1933 (translate-variable x)))
1937 (let ((body (ls-compile-block body t)))
1938 (indent (let-binding-wrapper dynamic-bindings body)))
1939 "})(" (join cvalues ",") ")")))
1942 ;;; Return the code to initialize BINDING, and push it extending the
1943 ;;; current lexical environment if the variable is not special.
1944 (defun let*-initialize-value (binding)
1945 (let ((var (first binding))
1946 (value (second binding)))
1947 (if (special-variable-p var)
1948 (code (ls-compile `(setq ,var ,value)) ";" *newline*)
1949 (let* ((v (gvarname var))
1950 (b (make-binding :name var :type 'variable :value v)))
1951 (prog1 (code "var " v " = " (ls-compile value) ";" *newline*)
1952 (push-to-lexenv b *environment* 'variable))))))
1954 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
1955 ;;; DOES NOT generate code to initialize the value of the symbols,
1956 ;;; unlike let-binding-wrapper.
1957 (defun let*-binding-wrapper (symbols body)
1958 (when (null symbols)
1959 (return-from let*-binding-wrapper body))
1960 (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
1961 (remove-if-not #'special-variable-p symbols))))
1965 (mapconcat (lambda (b)
1966 (let ((s (ls-compile `(quote ,(car b)))))
1967 (code "var " (cdr b) " = " s ".value;" *newline*)))
1971 "finally {" *newline*
1973 (mapconcat (lambda (b)
1974 (let ((s (ls-compile `(quote ,(car b)))))
1975 (code s ".value" " = " (cdr b) ";" *newline*)))
1979 (define-compilation let* (bindings &rest body)
1980 (let ((bindings (mapcar #'ensure-list bindings))
1981 (*environment* (copy-lexenv *environment*)))
1983 (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
1984 (body (concat (mapconcat #'let*-initialize-value bindings)
1985 (ls-compile-block body t))))
1986 (let*-binding-wrapper specials body)))))
1989 (defvar *block-counter* 0)
1991 (define-compilation block (name &rest body)
1992 (let* ((tr (incf *block-counter*))
1993 (b (make-binding :name name :type 'block :value tr)))
1994 (when *multiple-value-p*
1995 (push 'multiple-value (binding-declarations b)))
1996 (let* ((*environment* (extend-lexenv (list b) *environment* 'block))
1997 (cbody (ls-compile-block body t)))
1998 (if (member 'used (binding-declarations b))
2003 "catch (cf){" *newline*
2004 " if (cf.type == 'block' && cf.id == " tr ")" *newline*
2005 (if *multiple-value-p*
2006 " return values.apply(this, forcemv(cf.values));"
2007 " return cf.values;")
2010 " throw cf;" *newline*
2012 (js!selfcall cbody)))))
2014 (define-compilation return-from (name &optional value)
2015 (let* ((b (lookup-in-lexenv name *environment* 'block))
2016 (multiple-value-p (member 'multiple-value (binding-declarations b))))
2018 (error (concat "Unknown block `" (symbol-name name) "'.")))
2019 (push 'used (binding-declarations b))
2021 (when multiple-value-p (code "var values = mv;" *newline*))
2024 "id: " (binding-value b) ", "
2025 "values: " (ls-compile value multiple-value-p) ", "
2026 "message: 'Return from unknown block " (symbol-name name) ".'"
2029 (define-compilation catch (id &rest body)
2031 "var id = " (ls-compile id) ";" *newline*
2033 (indent (ls-compile-block body t)) *newline*
2035 "catch (cf){" *newline*
2036 " if (cf.type == 'catch' && cf.id == id)" *newline*
2037 (if *multiple-value-p*
2038 " return values.apply(this, forcemv(cf.values));"
2039 " return pv.apply(this, forcemv(cf.values));")
2042 " throw cf;" *newline*
2045 (define-compilation throw (id value)
2047 "var values = mv;" *newline*
2050 "id: " (ls-compile id) ", "
2051 "values: " (ls-compile value t) ", "
2052 "message: 'Throw uncatched.'"
2056 (defvar *tagbody-counter* 0)
2057 (defvar *go-tag-counter* 0)
2060 (or (integerp x) (symbolp x)))
2062 (defun declare-tagbody-tags (tbidx body)
2064 (mapcar (lambda (label)
2065 (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
2066 (make-binding :name label :type 'gotag :value (list tbidx tagidx))))
2067 (remove-if-not #'go-tag-p body))))
2068 (extend-lexenv bindings *environment* 'gotag)))
2070 (define-compilation tagbody (&rest body)
2071 ;; Ignore the tagbody if it does not contain any go-tag. We do this
2072 ;; because 1) it is easy and 2) many built-in forms expand to a
2073 ;; implicit tagbody, so we save some space.
2074 (unless (some #'go-tag-p body)
2075 (return-from tagbody (ls-compile `(progn ,@body nil))))
2076 ;; The translation assumes the first form in BODY is a label
2077 (unless (go-tag-p (car body))
2078 (push (gensym "START") body))
2079 ;; Tagbody compilation
2080 (let ((tbidx *tagbody-counter*))
2081 (let ((*environment* (declare-tagbody-tags tbidx body))
2083 (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
2084 (setq initag (second (binding-value b))))
2086 "var tagbody_" tbidx " = " initag ";" *newline*
2088 "while (true) {" *newline*
2089 (indent "try {" *newline*
2090 (indent (let ((content ""))
2091 (code "switch(tagbody_" tbidx "){" *newline*
2092 "case " initag ":" *newline*
2093 (dolist (form (cdr body) content)
2095 (if (not (go-tag-p form))
2096 (indent (ls-compile form) ";" *newline*)
2097 (let ((b (lookup-in-lexenv form *environment* 'gotag)))
2098 (code "case " (second (binding-value b)) ":" *newline*)))))
2099 "default:" *newline*
2100 " break tbloop;" *newline*
2103 "catch (jump) {" *newline*
2104 " if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
2105 " tagbody_" tbidx " = jump.label;" *newline*
2107 " throw(jump);" *newline*
2110 "return " (ls-compile nil) ";" *newline*))))
2112 (define-compilation go (label)
2113 (let ((b (lookup-in-lexenv label *environment* 'gotag))
2115 ((symbolp label) (symbol-name label))
2116 ((integerp label) (integer-to-string label)))))
2118 (error (concat "Unknown tag `" n "'.")))
2122 "id: " (first (binding-value b)) ", "
2123 "label: " (second (binding-value b)) ", "
2124 "message: 'Attempt to GO to non-existing tag " n "'"
2127 (define-compilation unwind-protect (form &rest clean-up)
2129 "var ret = " (ls-compile nil) ";" *newline*
2131 (indent "ret = " (ls-compile form) ";" *newline*)
2132 "} finally {" *newline*
2133 (indent (ls-compile-block clean-up))
2135 "return ret;" *newline*))
2137 (define-compilation multiple-value-call (func-form &rest forms)
2139 "var func = " (ls-compile func-form) ";" *newline*
2140 "var args = [" (if *multiple-value-p* "values" "pv") "];" *newline*
2143 "var values = mv;" *newline*
2145 (mapconcat (lambda (form)
2146 (code "vs = " (ls-compile form t) ";" *newline*
2147 "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
2148 (indent "args = args.concat(vs);" *newline*)
2150 (indent "args.push(vs);" *newline*)))
2152 "return func.apply(window, args);" *newline*) ";" *newline*))
2154 (define-compilation multiple-value-prog1 (first-form &rest forms)
2156 "var args = " (ls-compile first-form *multiple-value-p*) ";" *newline*
2157 (ls-compile-block forms)
2158 "return args;" *newline*))
2163 (define-compilation %js-vref (var) var)
2165 (define-compilation %js-vset (var val)
2166 (code "(" var " = " (ls-compile val) ")"))
2168 (define-setf-expander %js-vref (var)
2169 (let ((new-value (gensym)))
2170 (unless (stringp var)
2171 (error "a string was expected"))
2175 `(%js-vset ,var ,new-value)
2179 ;;; Backquote implementation.
2181 ;;; Author: Guy L. Steele Jr. Date: 27 December 1985
2182 ;;; Tested under Symbolics Common Lisp and Lucid Common Lisp.
2183 ;;; This software is in the public domain.
2185 ;;; The following are unique tokens used during processing.
2186 ;;; They need not be symbols; they need not even be atoms.
2187 (defvar *comma* 'unquote)
2188 (defvar *comma-atsign* 'unquote-splicing)
2190 (defvar *bq-list* (make-symbol "BQ-LIST"))
2191 (defvar *bq-append* (make-symbol "BQ-APPEND"))
2192 (defvar *bq-list** (make-symbol "BQ-LIST*"))
2193 (defvar *bq-nconc* (make-symbol "BQ-NCONC"))
2194 (defvar *bq-clobberable* (make-symbol "BQ-CLOBBERABLE"))
2195 (defvar *bq-quote* (make-symbol "BQ-QUOTE"))
2196 (defvar *bq-quote-nil* (list *bq-quote* nil))
2198 ;;; BACKQUOTE is an ordinary macro (not a read-macro) that processes
2199 ;;; the expression foo, looking for occurrences of #:COMMA,
2200 ;;; #:COMMA-ATSIGN, and #:COMMA-DOT. It constructs code in strict
2201 ;;; accordance with the rules on pages 349-350 of the first edition
2202 ;;; (pages 528-529 of this second edition). It then optionally
2203 ;;; applies a code simplifier.
2205 ;;; If the value of *BQ-SIMPLIFY* is non-NIL, then BACKQUOTE
2206 ;;; processing applies the code simplifier. If the value is NIL,
2207 ;;; then the code resulting from BACKQUOTE is exactly that
2208 ;;; specified by the official rules.
2209 (defparameter *bq-simplify* t)
2211 (defmacro backquote (x)
2212 (bq-completely-process x))
2214 ;;; Backquote processing proceeds in three stages:
2216 ;;; (1) BQ-PROCESS applies the rules to remove occurrences of
2217 ;;; #:COMMA, #:COMMA-ATSIGN, and #:COMMA-DOT corresponding to
2218 ;;; this level of BACKQUOTE. (It also causes embedded calls to
2219 ;;; BACKQUOTE to be expanded so that nesting is properly handled.)
2220 ;;; Code is produced that is expressed in terms of functions
2221 ;;; #:BQ-LIST, #:BQ-APPEND, and #:BQ-CLOBBERABLE. This is done
2222 ;;; so that the simplifier will simplify only list construction
2223 ;;; functions actually generated by BACKQUOTE and will not involve
2224 ;;; any user code in the simplification. #:BQ-LIST means LIST,
2225 ;;; #:BQ-APPEND means APPEND, and #:BQ-CLOBBERABLE means IDENTITY
2226 ;;; but indicates places where "%." was used and where NCONC may
2227 ;;; therefore be introduced by the simplifier for efficiency.
2229 ;;; (2) BQ-SIMPLIFY, if used, rewrites the code produced by
2230 ;;; BQ-PROCESS to produce equivalent but faster code. The
2231 ;;; additional functions #:BQ-LIST* and #:BQ-NCONC may be
2232 ;;; introduced into the code.
2234 ;;; (3) BQ-REMOVE-TOKENS goes through the code and replaces
2235 ;;; #:BQ-LIST with LIST, #:BQ-APPEND with APPEND, and so on.
2236 ;;; #:BQ-CLOBBERABLE is simply eliminated (a call to it being
2237 ;;; replaced by its argument). #:BQ-LIST* is replaced by either
2238 ;;; LIST* or CONS (the latter is used in the two-argument case,
2239 ;;; purely to make the resulting code a tad more readable).
2241 (defun bq-completely-process (x)
2242 (let ((raw-result (bq-process x)))
2243 (bq-remove-tokens (if *bq-simplify*
2244 (bq-simplify raw-result)
2247 (defun bq-process (x)
2249 (list *bq-quote* x))
2250 ((eq (car x) 'backquote)
2251 (bq-process (bq-completely-process (cadr x))))
2252 ((eq (car x) *comma*) (cadr x))
2253 ((eq (car x) *comma-atsign*)
2254 ;; (error ",@~S after `" (cadr x))
2255 (error "ill-formed"))
2256 ;; ((eq (car x) *comma-dot*)
2257 ;; ;; (error ",.~S after `" (cadr x))
2258 ;; (error "ill-formed"))
2259 (t (do ((p x (cdr p))
2260 (q '() (cons (bracket (car p)) q)))
2263 (nreconc q (list (list *bq-quote* p)))))
2264 (when (eq (car p) *comma*)
2265 (unless (null (cddr p))
2266 ;; (error "Malformed ,~S" p)
2267 (error "Malformed"))
2268 (return (cons *bq-append*
2269 (nreconc q (list (cadr p))))))
2270 (when (eq (car p) *comma-atsign*)
2271 ;; (error "Dotted ,@~S" p)
2273 ;; (when (eq (car p) *comma-dot*)
2274 ;; ;; (error "Dotted ,.~S" p)
2275 ;; (error "Dotted"))
2278 ;;; This implements the bracket operator of the formal rules.
2281 (list *bq-list* (bq-process x)))
2282 ((eq (car x) *comma*)
2283 (list *bq-list* (cadr x)))
2284 ((eq (car x) *comma-atsign*)
2286 ;; ((eq (car x) *comma-dot*)
2287 ;; (list *bq-clobberable* (cadr x)))
2288 (t (list *bq-list* (bq-process x)))))
2290 ;;; This auxiliary function is like MAPCAR but has two extra
2291 ;;; purposes: (1) it handles dotted lists; (2) it tries to make
2292 ;;; the result share with the argument x as much as possible.
2293 (defun maptree (fn x)
2296 (let ((a (funcall fn (car x)))
2297 (d (maptree fn (cdr x))))
2298 (if (and (eql a (car x)) (eql d (cdr x)))
2302 ;;; This predicate is true of a form that when read looked
2303 ;;; like %@foo or %.foo.
2304 (defun bq-splicing-frob (x)
2306 (or (eq (car x) *comma-atsign*)
2307 ;; (eq (car x) *comma-dot*)
2310 ;;; This predicate is true of a form that when read
2311 ;;; looked like %@foo or %.foo or just plain %foo.
2314 (or (eq (car x) *comma*)
2315 (eq (car x) *comma-atsign*)
2316 ;; (eq (car x) *comma-dot*)
2319 ;;; The simplifier essentially looks for calls to #:BQ-APPEND and
2320 ;;; tries to simplify them. The arguments to #:BQ-APPEND are
2321 ;;; processed from right to left, building up a replacement form.
2322 ;;; At each step a number of special cases are handled that,
2323 ;;; loosely speaking, look like this:
2325 ;;; (APPEND (LIST a b c) foo) => (LIST* a b c foo)
2326 ;;; provided a, b, c are not splicing frobs
2327 ;;; (APPEND (LIST* a b c) foo) => (LIST* a b (APPEND c foo))
2328 ;;; provided a, b, c are not splicing frobs
2329 ;;; (APPEND (QUOTE (x)) foo) => (LIST* (QUOTE x) foo)
2330 ;;; (APPEND (CLOBBERABLE x) foo) => (NCONC x foo)
2331 (defun bq-simplify (x)
2334 (let ((x (if (eq (car x) *bq-quote*)
2336 (maptree #'bq-simplify x))))
2337 (if (not (eq (car x) *bq-append*))
2339 (bq-simplify-args x)))))
2341 (defun bq-simplify-args (x)
2342 (do ((args (reverse (cdr x)) (cdr args))
2345 (cond ((atom (car args))
2346 (bq-attach-append *bq-append* (car args) result))
2347 ((and (eq (caar args) *bq-list*)
2348 (notany #'bq-splicing-frob (cdar args)))
2349 (bq-attach-conses (cdar args) result))
2350 ((and (eq (caar args) *bq-list**)
2351 (notany #'bq-splicing-frob (cdar args)))
2353 (reverse (cdr (reverse (cdar args))))
2354 (bq-attach-append *bq-append*
2355 (car (last (car args)))
2357 ((and (eq (caar args) *bq-quote*)
2358 (consp (cadar args))
2359 (not (bq-frob (cadar args)))
2360 (null (cddar args)))
2361 (bq-attach-conses (list (list *bq-quote*
2364 ((eq (caar args) *bq-clobberable*)
2365 (bq-attach-append *bq-nconc* (cadar args) result))
2366 (t (bq-attach-append *bq-append*
2369 ((null args) result)))
2371 (defun null-or-quoted (x)
2372 (or (null x) (and (consp x) (eq (car x) *bq-quote*))))
2374 ;;; When BQ-ATTACH-APPEND is called, the OP should be #:BQ-APPEND
2375 ;;; or #:BQ-NCONC. This produces a form (op item result) but
2376 ;;; some simplifications are done on the fly:
2378 ;;; (op '(a b c) '(d e f g)) => '(a b c d e f g)
2379 ;;; (op item 'nil) => item, provided item is not a splicable frob
2380 ;;; (op item 'nil) => (op item), if item is a splicable frob
2381 ;;; (op item (op a b c)) => (op item a b c)
2382 (defun bq-attach-append (op item result)
2383 (cond ((and (null-or-quoted item) (null-or-quoted result))
2384 (list *bq-quote* (append (cadr item) (cadr result))))
2385 ((or (null result) (equal result *bq-quote-nil*))
2386 (if (bq-splicing-frob item) (list op item) item))
2387 ((and (consp result) (eq (car result) op))
2388 (list* (car result) item (cdr result)))
2389 (t (list op item result))))
2391 ;;; The effect of BQ-ATTACH-CONSES is to produce a form as if by
2392 ;;; `(LIST* ,@items ,result) but some simplifications are done
2395 ;;; (LIST* 'a 'b 'c 'd) => '(a b c . d)
2396 ;;; (LIST* a b c 'nil) => (LIST a b c)
2397 ;;; (LIST* a b c (LIST* d e f g)) => (LIST* a b c d e f g)
2398 ;;; (LIST* a b c (LIST d e f g)) => (LIST a b c d e f g)
2399 (defun bq-attach-conses (items result)
2400 (cond ((and (every #'null-or-quoted items)
2401 (null-or-quoted result))
2403 (append (mapcar #'cadr items) (cadr result))))
2404 ((or (null result) (equal result *bq-quote-nil*))
2405 (cons *bq-list* items))
2406 ((and (consp result)
2407 (or (eq (car result) *bq-list*)
2408 (eq (car result) *bq-list**)))
2409 (cons (car result) (append items (cdr result))))
2410 (t (cons *bq-list** (append items (list result))))))
2412 ;;; Removes funny tokens and changes (#:BQ-LIST* a b) into
2413 ;;; (CONS a b) instead of (LIST* a b), purely for readability.
2414 (defun bq-remove-tokens (x)
2415 (cond ((eq x *bq-list*) 'list)
2416 ((eq x *bq-append*) 'append)
2417 ((eq x *bq-nconc*) 'nconc)
2418 ((eq x *bq-list**) 'list*)
2419 ((eq x *bq-quote*) 'quote)
2421 ((eq (car x) *bq-clobberable*)
2422 (bq-remove-tokens (cadr x)))
2423 ((and (eq (car x) *bq-list**)
2426 (cons 'cons (maptree #'bq-remove-tokens (cdr x))))
2427 (t (maptree #'bq-remove-tokens x))))
2429 (define-transformation backquote (form)
2430 (bq-completely-process form))
2435 (defvar *builtins* nil)
2437 (defmacro define-raw-builtin (name args &body body)
2438 ;; Creates a new primitive function `name' with parameters args and
2439 ;; @body. The body can access to the local environment through the
2440 ;; variable *ENVIRONMENT*.
2441 `(push (list ',name (lambda ,args (block ,name ,@body)))
2444 (defmacro define-builtin (name args &body body)
2445 `(define-raw-builtin ,name ,args
2446 (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
2449 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
2450 (defmacro type-check (decls &body body)
2452 ,@(mapcar (lambda (decl)
2453 `(code "var " ,(first decl) " = " ,(third decl) ";" *newline*))
2455 ,@(mapcar (lambda (decl)
2456 `(code "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
2457 (indent "throw 'The value ' + "
2459 " + ' is not a type "
2464 (code "return " (progn ,@body) ";" *newline*)))
2466 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
2467 ;;; a variable which holds a list of forms. It will compile them and
2468 ;;; store the result in some Javascript variables. BODY is evaluated
2469 ;;; with ARGS bound to the list of these variables to generate the
2470 ;;; code which performs the transformation on these variables.
2472 (defun variable-arity-call (args function)
2473 (unless (consp args)
2474 (error "ARGS must be a non-empty list"))
2480 (push (integer-to-string x) fargs)
2481 (let ((v (code "x" (incf counter))))
2484 (code "var " v " = " (ls-compile x) ";" *newline*
2485 "if (typeof " v " !== 'number') throw 'Not a number!';"
2487 (js!selfcall prelude (funcall function (reverse fargs)))))
2490 (defmacro variable-arity (args &body body)
2491 (unless (symbolp args)
2492 (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
2493 `(variable-arity-call ,args
2495 (code "return " ,@body ";" *newline*))))
2497 (defun num-op-num (x op y)
2498 (type-check (("x" "number" x) ("y" "number" y))
2501 (define-raw-builtin + (&rest numbers)
2504 (variable-arity numbers
2505 (join numbers "+"))))
2507 (define-raw-builtin - (x &rest others)
2508 (let ((args (cons x others)))
2509 (variable-arity args
2511 (concat "-" (car args))
2514 (define-raw-builtin * (&rest numbers)
2517 (variable-arity numbers
2518 (join numbers "*"))))
2520 (define-raw-builtin / (x &rest others)
2521 (let ((args (cons x others)))
2522 (variable-arity args
2524 (concat "1 /" (car args))
2527 (define-builtin mod (x y) (num-op-num x "%" y))
2530 (defun comparison-conjuntion (vars op)
2535 (concat (car vars) op (cadr vars)))
2537 (concat (car vars) op (cadr vars)
2539 (comparison-conjuntion (cdr vars) op)))))
2541 (defmacro define-builtin-comparison (op sym)
2542 `(define-raw-builtin ,op (x &rest args)
2543 (let ((args (cons x args)))
2544 (variable-arity args
2545 (js!bool (comparison-conjuntion args ,sym))))))
2547 (define-builtin-comparison > ">")
2548 (define-builtin-comparison < "<")
2549 (define-builtin-comparison >= ">=")
2550 (define-builtin-comparison <= "<=")
2551 (define-builtin-comparison = "==")
2553 (define-builtin numberp (x)
2554 (js!bool (code "(typeof (" x ") == \"number\")")))
2556 (define-builtin floor (x)
2557 (type-check (("x" "number" x))
2560 (define-builtin cons (x y)
2561 (code "({car: " x ", cdr: " y "})"))
2563 (define-builtin consp (x)
2566 "var tmp = " x ";" *newline*
2567 "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
2569 (define-builtin car (x)
2571 "var tmp = " x ";" *newline*
2572 "return tmp === " (ls-compile nil)
2573 "? " (ls-compile nil)
2574 ": tmp.car;" *newline*))
2576 (define-builtin cdr (x)
2578 "var tmp = " x ";" *newline*
2579 "return tmp === " (ls-compile nil) "? "
2581 ": tmp.cdr;" *newline*))
2583 (define-builtin rplaca (x new)
2584 (type-check (("x" "object" x))
2585 (code "(x.car = " new ", x)")))
2587 (define-builtin rplacd (x new)
2588 (type-check (("x" "object" x))
2589 (code "(x.cdr = " new ", x)")))
2591 (define-builtin symbolp (x)
2594 "var tmp = " x ";" *newline*
2595 "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
2597 (define-builtin make-symbol (name)
2598 (type-check (("name" "string" name))
2601 (define-builtin symbol-name (x)
2602 (code "(" x ").name"))
2604 (define-builtin set (symbol value)
2605 (code "(" symbol ").value = " value))
2607 (define-builtin fset (symbol value)
2608 (code "(" symbol ").fvalue = " value))
2610 (define-builtin boundp (x)
2611 (js!bool (code "(" x ".value !== undefined)")))
2613 (define-builtin symbol-value (x)
2615 "var symbol = " x ";" *newline*
2616 "var value = symbol.value;" *newline*
2617 "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
2618 "return value;" *newline*))
2620 (define-builtin symbol-function (x)
2622 "var symbol = " x ";" *newline*
2623 "var func = symbol.fvalue;" *newline*
2624 "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
2625 "return func;" *newline*))
2627 (define-builtin symbol-plist (x)
2628 (code "((" x ").plist || " (ls-compile nil) ")"))
2630 (define-builtin lambda-code (x)
2631 (code "(" x ").toString()"))
2633 (define-builtin eq (x y) (js!bool (code "(" x " === " y ")")))
2634 (define-builtin equal (x y) (js!bool (code "(" x " == " y ")")))
2636 (define-builtin char-to-string (x)
2637 (type-check (("x" "number" x))
2638 "String.fromCharCode(x)"))
2640 (define-builtin stringp (x)
2641 (js!bool (code "(typeof(" x ") == \"string\")")))
2643 (define-builtin string-upcase (x)
2644 (type-check (("x" "string" x))
2647 (define-builtin string-length (x)
2648 (type-check (("x" "string" x))
2651 (define-raw-builtin slice (string a &optional b)
2653 "var str = " (ls-compile string) ";" *newline*
2654 "var a = " (ls-compile a) ";" *newline*
2656 (when b (code "b = " (ls-compile b) ";" *newline*))
2657 "return str.slice(a,b);" *newline*))
2659 (define-builtin char (string index)
2660 (type-check (("string" "string" string)
2661 ("index" "number" index))
2662 "string.charCodeAt(index)"))
2664 (define-builtin concat-two (string1 string2)
2665 (type-check (("string1" "string" string1)
2666 ("string2" "string" string2))
2667 "string1.concat(string2)"))
2669 (define-raw-builtin funcall (func &rest args)
2671 "var f = " (ls-compile func) ";" *newline*
2672 "return (typeof f === 'function'? f: f.fvalue)("
2673 (join (cons (if *multiple-value-p* "values" "pv")
2674 (mapcar #'ls-compile args))
2678 (define-raw-builtin apply (func &rest args)
2680 (code "(" (ls-compile func) ")()")
2681 (let ((args (butlast args))
2682 (last (car (last args))))
2684 "var f = " (ls-compile func) ";" *newline*
2685 "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
2686 (mapcar #'ls-compile args))
2689 "var tail = (" (ls-compile last) ");" *newline*
2690 "while (tail != " (ls-compile nil) "){" *newline*
2691 " args.push(tail.car);" *newline*
2692 " tail = tail.cdr;" *newline*
2694 "return (typeof f === 'function'? f : f.fvalue).apply(this, args);" *newline*))))
2696 (define-builtin js-eval (string)
2697 (type-check (("string" "string" string))
2698 (if *multiple-value-p*
2700 "var v = eval.apply(window, [string]);" *newline*
2701 "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
2702 (indent "v = [v];" *newline*
2703 "v['multiple-value'] = true;" *newline*)
2705 "return values.apply(this, v);" *newline*)
2706 "eval.apply(window, [string])")))
2708 (define-builtin error (string)
2709 (js!selfcall "throw " string ";" *newline*))
2711 (define-builtin new () "{}")
2713 (define-builtin objectp (x)
2714 (js!bool (code "(typeof (" x ") === 'object')")))
2716 (define-builtin oget (object key)
2718 "var tmp = " "(" object ")[" key "];" *newline*
2719 "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
2721 (define-builtin oset (object key value)
2722 (code "((" object ")[" key "] = " value ")"))
2724 (define-builtin in (key object)
2725 (js!bool (code "((" key ") in (" object "))")))
2727 (define-builtin functionp (x)
2728 (js!bool (code "(typeof " x " == 'function')")))
2730 (define-builtin write-string (x)
2731 (type-check (("x" "string" x))
2734 (define-builtin make-array (n)
2736 "var r = [];" *newline*
2737 "for (var i = 0; i < " n "; i++)" *newline*
2738 (indent "r.push(" (ls-compile nil) ");" *newline*)
2739 "return r;" *newline*))
2741 (define-builtin arrayp (x)
2744 "var x = " x ";" *newline*
2745 "return typeof x === 'object' && 'length' in x;")))
2747 (define-builtin aref (array n)
2749 "var x = " "(" array ")[" n "];" *newline*
2750 "if (x === undefined) throw 'Out of range';" *newline*
2751 "return x;" *newline*))
2753 (define-builtin aset (array n value)
2755 "var x = " array ";" *newline*
2756 "var i = " n ";" *newline*
2757 "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
2758 "return x[i] = " value ";" *newline*))
2760 (define-builtin get-unix-time ()
2761 (code "(Math.round(new Date() / 1000))"))
2763 (define-builtin values-array (array)
2764 (if *multiple-value-p*
2765 (code "values.apply(this, " array ")")
2766 (code "pv.apply(this, " array ")")))
2768 (define-raw-builtin values (&rest args)
2769 (if *multiple-value-p*
2770 (code "values(" (join (mapcar #'ls-compile args) ", ") ")")
2771 (code "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
2773 ;; Receives the JS function as first argument as a literal string. The
2774 ;; second argument is compiled and should evaluate to a vector of
2775 ;; values to apply to the the function. The result returned.
2776 (define-builtin %js-call (fun args)
2777 (code fun ".apply(this, " args ")"))
2781 (let ((b (lookup-in-lexenv x *environment* 'function)))
2782 (if (and b (eq (binding-type b) 'macro))
2786 (defun ls-macroexpand-1 (form)
2789 (let ((b (lookup-in-lexenv form *environment* 'variable)))
2790 (if (and b (eq (binding-type b) 'macro))
2791 (values (binding-value b) t)
2792 (values form nil))))
2794 (let ((macro-binding (macro (car form))))
2796 (let ((expander (binding-value macro-binding)))
2799 ((binding-cache macro-binding)
2800 (setq expander (binding-cache macro-binding)))
2802 (let ((compiled (eval expander)))
2803 ;; The list representation are useful while
2804 ;; bootstrapping, as we can dump the definition of the
2805 ;; macros easily, but they are slow because we have to
2806 ;; evaluate them and compile them now and again. So, let
2807 ;; us replace the list representation version of the
2808 ;; function with the compiled one.
2810 #+ecmalisp (setf (binding-value macro-binding) compiled)
2811 #+common-lisp (setf (binding-cache macro-binding) compiled)
2812 (setq expander compiled))))
2813 (values (apply expander (cdr form)) t))
2814 (values form nil))))
2816 (values form nil))))
2818 (defun compile-funcall (function args)
2819 (let* ((values-funcs (if *multiple-value-p* "values" "pv"))
2820 (arglist (concat "(" (join (cons values-funcs (mapcar #'ls-compile args)) ", ") ")")))
2822 ((translate-function function)
2823 (concat (translate-function function) arglist))
2824 ((and (symbolp function)
2825 #+ecmalisp (eq (symbol-package function) (find-package "COMMON-LISP"))
2827 (code (ls-compile `',function) ".fvalue" arglist))
2829 (code (ls-compile `#',function) arglist)))))
2831 (defun ls-compile-block (sexps &optional return-last-p)
2833 (code (ls-compile-block (butlast sexps))
2834 "return " (ls-compile (car (last sexps)) *multiple-value-p*) ";")
2836 (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
2837 (concat ";" *newline*))))
2839 (defun ls-compile (sexp &optional multiple-value-p)
2840 (multiple-value-bind (sexp expandedp) (ls-macroexpand-1 sexp)
2842 (return-from ls-compile (ls-compile sexp multiple-value-p)))
2843 ;; The expression has been macroexpanded. Now compile it!
2844 (let ((*multiple-value-p* multiple-value-p))
2847 (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
2849 ((and b (not (member 'special (binding-declarations b))))
2851 ((or (keywordp sexp)
2852 (and b (member 'constant (binding-declarations b))))
2853 (code (ls-compile `',sexp) ".value"))
2855 (ls-compile `(symbol-value ',sexp))))))
2856 ((integerp sexp) (integer-to-string sexp))
2857 ((stringp sexp) (code "\"" (escape-string sexp) "\""))
2858 ((arrayp sexp) (literal sexp))
2860 (let ((name (car sexp))
2864 ((assoc name *compilations*)
2865 (let ((comp (second (assoc name *compilations*))))
2867 ;; Built-in functions
2868 ((and (assoc name *builtins*)
2869 (not (claimp name 'function 'notinline)))
2870 (let ((comp (second (assoc name *builtins*))))
2873 (compile-funcall name args)))))
2875 (error (concat "How should I compile " (prin1-to-string sexp) "?")))))))
2878 (defvar *compile-print-toplevels* nil)
2880 (defun truncate-string (string &optional (width 60))
2881 (let ((n (or (position #\newline string)
2882 (min width (length string)))))
2883 (subseq string 0 n)))
2885 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
2886 (let ((*toplevel-compilations* nil))
2888 ((and (consp sexp) (eq (car sexp) 'progn))
2889 (let ((subs (mapcar (lambda (s)
2890 (ls-compile-toplevel s t))
2892 (join (remove-if #'null-or-empty-p subs))))
2894 (when *compile-print-toplevels*
2895 (let ((form-string (prin1-to-string sexp)))
2896 (write-string "Compiling ")
2897 (write-string (truncate-string form-string))
2898 (write-line "...")))
2900 (let ((code (ls-compile sexp multiple-value-p)))
2901 (code (join-trailing (get-toplevel-compilations)
2902 (code ";" *newline*))
2904 (code code ";" *newline*))))))))
2907 ;;; Once we have the compiler, we define the runtime environment and
2908 ;;; interactive development (eval), which works calling the compiler
2909 ;;; and evaluating the Javascript result globally.
2914 (js-eval (ls-compile-toplevel x t)))
2916 (export '(&body &key &optional &rest * *gensym-counter* *package* + - / 1+ 1- <
2917 <= = = > >= and append apply aref arrayp assoc atom block
2918 boundp boundp butlast caar cadddr caddr cadr car car case
2919 catch cdar cdddr cddr cdr cdr char char-code char=
2920 code-char cond cons consp constantly copy-list decf
2921 declaim defconstant define-setf-expander
2922 define-symbol-macro defmacro defparameter defun defvar
2923 digit-char digit-char-p disassemble do do* documentation
2924 dolist dotimes ecase eq eql equal error eval every export
2925 fdefinition find-package find-symbol first flet fourth
2926 fset funcall function functionp gensym get-setf-expansion
2927 get-universal-time go identity if in-package incf integerp
2928 integerp intern keywordp labels lambda last length let
2929 let* list list* list-all-packages listp loop make-array
2930 make-package make-symbol mapcar member minusp mod
2931 multiple-value-bind multiple-value-call
2932 multiple-value-list multiple-value-prog1 nconc nil not
2933 nreconc nth nthcdr null numberp or package-name
2934 package-use-list packagep parse-integer plusp
2935 prin1-to-string print proclaim prog1 prog2 progn psetq
2936 push quote remove remove-if remove-if-not return
2937 return-from revappend reverse rplaca rplacd second set
2938 setf setq some string string-upcase string= stringp subseq
2939 symbol-function symbol-name symbol-package symbol-plist
2940 symbol-value symbolp t tagbody third throw truncate unless
2941 unwind-protect values values-list variable warn when
2942 write-line write-string zerop))
2944 (setq *package* *user-package*)
2946 (js-eval "var lisp")
2947 (%js-vset "lisp" (new))
2948 (%js-vset "lisp.read" #'ls-read-from-string)
2949 (%js-vset "lisp.print" #'prin1-to-string)
2950 (%js-vset "lisp.eval" #'eval)
2951 (%js-vset "lisp.compile" (lambda (s) (ls-compile-toplevel s t)))
2952 (%js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
2953 (%js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str) t)))
2955 ;; Set the initial global environment to be equal to the host global
2956 ;; environment at this point of the compilation.
2958 (toplevel-compilation
2959 (ls-compile `(setq *environment* ',*environment*))))
2962 (toplevel-compilation
2965 ,@(mapcar (lambda (s) `(%intern-symbol (%js-vref ,(cdr s))))
2967 (setq *literal-symbols* ',*literal-symbols*)
2968 (setq *variable-counter* ,*variable-counter*)
2969 (setq *gensym-counter* ,*gensym-counter*)
2970 (setq *block-counter* ,*block-counter*)))))
2973 (toplevel-compilation
2975 `(setq *literal-counter* ,*literal-counter*)))))
2978 ;;; Finally, we provide a couple of functions to easily bootstrap
2979 ;;; this. It just calls the compiler with this file as input.
2983 (defun read-whole-file (filename)
2984 (with-open-file (in filename)
2985 (let ((seq (make-array (file-length in) :element-type 'character)))
2986 (read-sequence seq in)
2989 (defun ls-compile-file (filename output &key print)
2990 (let ((*compiling-file* t)
2991 (*compile-print-toplevels* print))
2992 (with-open-file (out output :direction :output :if-exists :supersede)
2993 (write-string (read-whole-file "prelude.js") out)
2994 (let* ((source (read-whole-file filename))
2995 (in (make-string-stream source)))
2997 for x = (ls-read in)
2999 for compilation = (ls-compile-toplevel x)
3000 when (plusp (length compilation))
3001 do (write-string compilation out))))))
3004 (setq *environment* (make-lexenv))
3005 (setq *literal-symbols* nil)
3006 (setq *variable-counter* 0
3010 (ls-compile-file "ecmalisp.lisp" "ecmalisp.js" :print t)))