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.
26 (js-eval "function pv (x) { return x; }")
29 (js-eval "function mv(){ var r = []; r['multiple-value'] = true; for (var i=0; i<arguments.length; i++) r.push(arguments[i]); return r; }")
31 ;;; NOTE: Define VALUES to be MV for toplevel forms. It is because
32 ;;; `eval' compiles the forms and execute the Javascript code at
33 ;;; toplevel with `js-eval', so it is necessary to return multiple
34 ;;; values from the eval function.
36 (js-eval "var values = mv;")
41 (%compile-defmacro 'defmacro
42 '(lambda (name args &rest body)
44 (%compile-defmacro ',name
45 '(lambda ,(mapcar (lambda (x)
52 (defmacro declaim (&rest decls)
54 ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
56 (declaim (constant nil t) (special t nil))
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)
87 (declaim (non-overridable ,name))
89 (named-lambda ,(symbol-name name) ,args
90 ,@(if (and (stringp (car body)) (not (null (cdr body))))
91 `(,(car body) (block ,name ,@(cdr body)))
92 `((block ,name ,@body)))))
98 (defmacro return (&optional value)
99 `(return-from nil ,value))
101 (defmacro while (condition &body body)
102 `(block nil (%while ,condition ,@body)))
104 (defvar *gensym-counter* 0)
105 (defun gensym (&optional (prefix "G"))
106 (setq *gensym-counter* (+ *gensym-counter* 1))
107 (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
113 (defun = (x y) (= x y))
114 (defun * (x y) (* x y))
115 (defun / (x y) (/ x y))
116 (defun 1+ (x) (+ x 1))
117 (defun 1- (x) (- x 1))
118 (defun zerop (x) (= x 0))
119 (defun truncate (x y) (floor (/ x y)))
121 (defun eql (x y) (eq x y))
123 (defun not (x) (if x nil t))
125 (defun cons (x y ) (cons x y))
126 (defun consp (x) (consp x))
129 "Return the CAR part of a cons, or NIL if X is null."
132 (defun cdr (x) (cdr x))
133 (defun caar (x) (car (car x)))
134 (defun cadr (x) (car (cdr x)))
135 (defun cdar (x) (cdr (car x)))
136 (defun cddr (x) (cdr (cdr x)))
137 (defun caddr (x) (car (cdr (cdr x))))
138 (defun cdddr (x) (cdr (cdr (cdr x))))
139 (defun cadddr (x) (car (cdr (cdr (cdr x)))))
140 (defun first (x) (car x))
141 (defun second (x) (cadr x))
142 (defun third (x) (caddr x))
143 (defun fourth (x) (cadddr x))
145 (defun list (&rest args) args)
151 (defmacro incf (x &optional (delta 1))
152 `(setq ,x (+ ,x ,delta)))
154 (defmacro decf (x &optional (delta 1))
155 `(setq ,x (- ,x ,delta)))
157 (defmacro push (x place)
158 `(setq ,place (cons ,x ,place)))
160 (defmacro dolist (iter &body body)
161 (let ((var (first iter))
164 (let ((,g!list ,(second iter))
167 (setq ,var (car ,g!list))
169 (setq ,g!list (cdr ,g!list)))
172 (defmacro dotimes (iter &body body)
173 (let ((g!to (gensym))
176 (result (third iter)))
180 (%while (< ,var ,g!to)
185 (defmacro cond (&rest clausules)
188 (if (eq (caar clausules) t)
189 `(progn ,@(cdar clausules))
190 `(if ,(caar clausules)
191 (progn ,@(cdar clausules))
192 (cond ,@(cdr clausules))))))
194 (defmacro case (form &rest clausules)
195 (let ((!form (gensym)))
196 `(let ((,!form ,form))
198 ,@(mapcar (lambda (clausule)
199 (if (eq (car clausule) t)
201 `((eql ,!form ',(car clausule))
205 (defmacro ecase (form &rest clausules)
210 (error "ECASE expression failed."))))))
212 (defmacro and (&rest forms)
223 (defmacro or (&rest forms)
231 `(let ((,g ,(car forms)))
232 (if ,g ,g (or ,@(cdr forms))))))))
234 (defmacro prog1 (form &body body)
235 (let ((value (gensym)))
236 `(let ((,value ,form))
240 (defmacro prog2 (form1 result &body body)
241 `(prog1 (progn ,form1 ,result) ,@body)))
244 ;;; This couple of helper functions will be defined in both Common
245 ;;; Lisp and in Ecmalisp.
246 (defun ensure-list (x)
251 (defun !reduce (func list initial)
256 (funcall func initial (car list)))))
258 ;;; Go on growing the Lisp language in Ecmalisp, with more high
259 ;;; level utilities as well as correct versions of other
263 (defun + (&rest args)
268 (defun - (x &rest others)
275 (defun append-two (list1 list2)
279 (append (cdr list1) list2))))
281 (defun append (&rest lists)
282 (!reduce #'append-two lists '()))
284 (defun revappend (list1 list2)
286 (push (car list1) list2)
287 (setq list1 (cdr list1)))
290 (defun reverse (list)
291 (revappend list '()))
293 (defmacro psetq (&rest pairs)
294 (let ( ;; For each pair, we store here a list of the form
295 ;; (VARIABLE GENSYM VALUE).
299 ((null pairs) (return))
301 (error "Odd paris in PSETQ"))
303 (let ((variable (car pairs))
304 (value (cadr pairs)))
305 (push `(,variable ,(gensym) ,value) assignments)
306 (setq pairs (cddr pairs))))))
307 (setq assignments (reverse assignments))
309 `(let ,(mapcar #'cdr assignments)
310 (setq ,@(!reduce #'append (mapcar #'butlast assignments) '())))))
312 (defun list-length (list)
314 (while (not (null list))
316 (setq list (cdr list)))
328 (defun concat-two (s1 s2)
331 (defun mapcar (func list)
334 (cons (funcall func (car list))
335 (mapcar func (cdr list)))))
337 (defun identity (x) x)
340 (mapcar #'identity x))
342 (defun code-char (x) x)
343 (defun char-code (x) x)
344 (defun char= (x y) (= x y))
347 (and (numberp x) (= (floor x) x)))
349 (defun plusp (x) (< 0 x))
350 (defun minusp (x) (< x 0))
353 (or (consp x) (null x)))
355 (defun nthcdr (n list)
356 (while (and (plusp n) list)
358 (setq list (cdr list)))
362 (car (nthcdr n list)))
365 (while (consp (cdr x))
371 (cons (car x) (butlast (cdr x)))))
373 (defun member (x list)
375 (when (eql x (car list))
377 (setq list (cdr list))))
379 (defun remove (x list)
384 (remove x (cdr list)))
386 (cons (car list) (remove x (cdr list))))))
388 (defun remove-if (func list)
392 ((funcall func (car list))
393 (remove-if func (cdr list)))
395 (cons (car list) (remove-if func (cdr list))))))
397 (defun remove-if-not (func list)
401 ((funcall func (car list))
402 (cons (car list) (remove-if-not func (cdr list))))
404 (remove-if-not func (cdr list)))))
406 (defun digit-char-p (x)
407 (if (and (<= #\0 x) (<= x #\9))
411 (defun subseq (seq a &optional b)
418 (error "Unsupported argument."))))
420 (defun parse-integer (string)
423 (size (length string)))
424 (while (< index size)
425 (setq value (+ (* value 10) (digit-char-p (char string index))))
429 (defun some (function seq)
434 (while (< index size)
435 (when (funcall function (char seq index))
436 (return-from some t))
441 (when (funcall function x)
444 (error "Unknown sequence."))))
446 (defun every (function seq)
451 (while (< index size)
452 (unless (funcall function (char seq index))
453 (return-from every nil))
458 (unless (funcall function x)
461 (error "Unknown sequence."))))
463 (defun assoc (x alist)
465 (if (eql x (caar alist))
467 (setq alist (cdr alist))))
471 (cond ((stringp x) x)
472 ((symbolp x) (symbol-name x))
473 (t (char-to-string x))))
475 (defun string= (s1 s2)
478 (defun fdefinition (x)
485 (error "Invalid function"))))
487 (defun disassemble (function)
488 (write-line (lambda-code (fdefinition function)))
491 (defun documentation (x type)
492 "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
495 (let ((func (fdefinition x)))
496 (oget func "docstring")))
499 (error "Wrong argument type! it should be a symbol"))
504 (defvar *package-list* nil)
506 (defun list-all-packages ()
509 (defun make-package (name &optional use)
510 (let ((package (new))
511 (use (mapcar #'find-package-or-fail use)))
512 (oset package "packageName" name)
513 (oset package "symbols" (new))
514 (oset package "exports" (new))
515 (oset package "use" use)
516 (push package *package-list*)
520 (and (objectp x) (in "symbols" x)))
522 (defun find-package (package-designator)
523 (when (packagep package-designator)
524 (return-from find-package package-designator))
525 (let ((name (string package-designator)))
526 (dolist (package *package-list*)
527 (when (string= (package-name package) name)
530 (defun find-package-or-fail (package-designator)
531 (or (find-package package-designator)
532 (error "Package unknown.")))
534 (defun package-name (package-designator)
535 (let ((package (find-package-or-fail package-designator)))
536 (oget package "packageName")))
538 (defun %package-symbols (package-designator)
539 (let ((package (find-package-or-fail package-designator)))
540 (oget package "symbols")))
542 (defun package-use-list (package-designator)
543 (let ((package (find-package-or-fail package-designator)))
544 (oget package "use")))
546 (defun %package-external-symbols (package-designator)
547 (let ((package (find-package-or-fail package-designator)))
548 (oget package "exports")))
550 (defvar *common-lisp-package*
553 (defvar *user-package*
554 (make-package "CL-USER" (list *common-lisp-package*)))
556 (defvar *keyword-package*
557 (make-package "KEYWORD"))
560 (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
562 (defvar *package* *common-lisp-package*)
564 (defmacro in-package (package-designator)
566 (setq *package* (find-package-or-fail ,package-designator))))
568 ;; This function is used internally to initialize the CL package
569 ;; with the symbols built during bootstrap.
570 (defun %intern-symbol (symbol)
571 (let ((symbols (%package-symbols *common-lisp-package*)))
572 (oset symbol "package" *common-lisp-package*)
573 (oset symbols (symbol-name symbol) symbol)))
575 (defun %find-symbol (name package)
576 (let ((package (find-package-or-fail package)))
577 (let ((symbols (%package-symbols package)))
578 (if (in name symbols)
579 (cons (oget symbols name) t)
580 (dolist (used (package-use-list package) (cons nil nil))
581 (let ((exports (%package-external-symbols used)))
582 (when (in name exports)
583 (return-from %find-symbol
584 (cons (oget exports name) t)))))))))
586 (defun find-symbol (name &optional (package *package*))
587 (car (%find-symbol name package)))
589 (defun intern (name &optional (package *package*))
590 (let ((package (find-package-or-fail package)))
591 (let ((result (%find-symbol name package)))
594 (let ((symbols (%package-symbols package)))
596 (let ((symbol (make-symbol name)))
597 (oset symbol "package" package)
598 (when (eq package *keyword-package*)
599 (oset symbol "value" symbol)
600 (export (list symbol) package))
601 (oset symbols name symbol)))))))
603 (defun symbol-package (symbol)
604 (unless (symbolp symbol)
605 (error "it is not a symbol"))
606 (oget symbol "package"))
608 (defun export (symbols &optional (package *package*))
609 (let ((exports (%package-external-symbols package)))
610 (dolist (symb symbols t)
611 (oset exports (symbol-name symb) symb))))
613 (defun get-universal-time ()
614 (+ (get-unix-time) 2208988800)))
617 ;;; The compiler offers some primitives and special forms which are
618 ;;; not found in Common Lisp, for instance, while. So, we grow Common
619 ;;; Lisp a bit to it can execute the rest of the file.
622 (defmacro while (condition &body body)
627 (defmacro eval-when-compile (&body body)
628 `(eval-when (:compile-toplevel :load-toplevel :execute)
631 (defun concat-two (s1 s2)
632 (concatenate 'string s1 s2))
634 (defun setcar (cons new)
635 (setf (car cons) new))
636 (defun setcdr (cons new)
637 (setf (cdr cons) new))
639 (defun aset (array idx value)
640 (setf (aref array idx) value)))
642 ;;; At this point, no matter if Common Lisp or ecmalisp is compiling
643 ;;; from here, this code will compile on both. We define some helper
644 ;;; functions now for string manipulation and so on. They will be
645 ;;; useful in the compiler, mostly.
647 (defvar *newline* (string (code-char 10)))
649 (defun concat (&rest strs)
650 (!reduce #'concat-two strs ""))
652 (defmacro concatf (variable &body form)
653 `(setq ,variable (concat ,variable (progn ,@form))))
655 ;;; Concatenate a list of strings, with a separator
656 (defun join (list &optional (separator ""))
665 (join (cdr list) separator)))))
667 (defun join-trailing (list &optional (separator ""))
670 (concat (car list) separator (join-trailing (cdr list) separator))))
672 (defun mapconcat (func list)
673 (join (mapcar func list)))
675 (defun vector-to-list (vector)
677 (size (length vector)))
678 (dotimes (i size (reverse list))
679 (push (aref vector i) list))))
681 (defun list-to-vector (list)
682 (let ((v (make-array (length list)))
690 (defun values-list (list)
691 (values-array (list-to-vector list)))
693 (defun values (&rest args)
697 ;;; Like CONCAT, but prefix each line with four spaces. Two versions
698 ;;; of this function are available, because the Ecmalisp version is
699 ;;; very slow and bootstraping was annoying.
702 (defun indent (&rest string)
703 (let ((input (join string)))
706 (size (length input)))
707 (when (plusp (length input)) (concatf output " "))
708 (while (< index size)
710 (if (and (char= (char input index) #\newline)
712 (not (char= (char input (1+ index)) #\newline)))
713 (concat (string #\newline) " ")
714 (string (char input index)))))
715 (concatf output str))
720 (defun indent (&rest string)
721 (with-output-to-string (*standard-output*)
722 (with-input-from-string (input (join string))
724 for line = (read-line input nil)
726 do (write-string " ")
727 do (write-line line)))))
730 (defun integer-to-string (x)
735 (concat "-" (integer-to-string (- 0 x))))
738 (while (not (zerop x))
739 (push (mod x 10) digits)
740 (setq x (truncate x 10)))
741 (join (mapcar (lambda (d) (string (char "0123456789" d)))
745 ;;; Wrap X with a Javascript code to convert the result from
746 ;;; Javascript generalized booleans to T or NIL.
748 (concat "(" x "?" (ls-compile t) ": " (ls-compile nil) ")"))
750 ;;; Concatenate the arguments and wrap them with a self-calling
751 ;;; Javascript anonymous function. It is used to make some Javascript
752 ;;; statements valid expressions and provide a private scope as well.
753 ;;; It could be defined as function, but we could do some
754 ;;; preprocessing in the future.
755 (defmacro js!selfcall (&body body)
756 `(concat "(function(){" *newline* (indent ,@body) "})()"))
763 (defun prin1-to-string (form)
766 (if (cdr (%find-symbol (symbol-name form) *package*))
768 (let ((package (symbol-package form))
769 (name (symbol-name form)))
772 ((eq package (find-package "KEYWORD")) "")
773 (t (package-name package)))
775 ((integerp form) (integer-to-string form))
776 ((stringp form) (concat "\"" (escape-string form) "\""))
778 (let ((name (oget form "fname")))
780 (concat "#<FUNCTION " name ">")
781 (concat "#<FUNCTION>"))))
784 (join-trailing (mapcar #'prin1-to-string (butlast form)) " ")
785 (let ((last (last form)))
786 (if (null (cdr last))
787 (prin1-to-string (car last))
788 (concat (prin1-to-string (car last)) " . " (prin1-to-string (cdr last)))))
791 (concat "#" (prin1-to-string (vector-to-list form))))
793 (concat "#<PACKAGE " (package-name form) ">"))))
795 (defun write-line (x)
797 (write-string *newline*)
801 (write-string "WARNING: ")
805 (write-line (prin1-to-string x))
811 ;;; The Lisp reader, parse strings and return Lisp objects. The main
812 ;;; entry points are `ls-read' and `ls-read-from-string'.
814 (defun make-string-stream (string)
817 (defun %peek-char (stream)
818 (and (< (cdr stream) (length (car stream)))
819 (char (car stream) (cdr stream))))
821 (defun %read-char (stream)
822 (and (< (cdr stream) (length (car stream)))
823 (prog1 (char (car stream) (cdr stream))
824 (setcdr stream (1+ (cdr stream))))))
826 (defun whitespacep (ch)
827 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
829 (defun skip-whitespaces (stream)
831 (setq ch (%peek-char stream))
832 (while (and ch (whitespacep ch))
834 (setq ch (%peek-char stream)))))
836 (defun terminalp (ch)
837 (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
839 (defun read-until (stream func)
842 (setq ch (%peek-char stream))
843 (while (and ch (not (funcall func ch)))
844 (setq string (concat string (string ch)))
846 (setq ch (%peek-char stream)))
849 (defun skip-whitespaces-and-comments (stream)
851 (skip-whitespaces stream)
852 (setq ch (%peek-char stream))
853 (while (and ch (char= ch #\;))
854 (read-until stream (lambda (x) (char= x #\newline)))
855 (skip-whitespaces stream)
856 (setq ch (%peek-char stream)))))
858 (defun %read-list (stream)
859 (skip-whitespaces-and-comments stream)
860 (let ((ch (%peek-char stream)))
863 (error "Unspected EOF"))
869 (prog1 (ls-read stream)
870 (skip-whitespaces-and-comments stream)
871 (unless (char= (%read-char stream) #\))
872 (error "')' was expected."))))
874 (cons (ls-read stream) (%read-list stream))))))
876 (defun read-string (stream)
879 (setq ch (%read-char stream))
880 (while (not (eql ch #\"))
882 (error "Unexpected EOF"))
884 (setq ch (%read-char stream)))
885 (setq string (concat string (string ch)))
886 (setq ch (%read-char stream)))
889 (defun read-sharp (stream)
891 (ecase (%read-char stream)
893 (list 'function (ls-read stream)))
894 (#\( (list-to-vector (%read-list stream)))
895 (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
898 (concat (string (%read-char stream))
899 (read-until stream #'terminalp))))
901 ((string= cname "space") (char-code #\space))
902 ((string= cname "tab") (char-code #\tab))
903 ((string= cname "newline") (char-code #\newline))
904 (t (char-code (char cname 0))))))
906 (let ((feature (read-until stream #'terminalp)))
908 ((string= feature "common-lisp")
909 (ls-read stream) ;ignore
911 ((string= feature "ecmalisp")
914 (error "Unknown reader form.")))))))
916 ;;; Parse a string of the form NAME, PACKAGE:NAME or
917 ;;; PACKAGE::NAME and return the name. If the string is of the
918 ;;; form 1) or 3), but the symbol does not exist, it will be created
919 ;;; and interned in that package.
920 (defun read-symbol (string)
921 (let ((size (length string))
922 package name internalp index)
924 (while (and (< index size)
925 (not (char= (char string index) #\:)))
931 (setq package *package*)
936 (setq package "KEYWORD")
937 (setq package (string-upcase (subseq string 0 index))))
939 (when (char= (char string index) #\:)
942 (setq name (subseq string index))))
943 ;; Canonalize symbol name and package
944 (setq name (string-upcase name))
945 (setq package (find-package package))
946 ;; TODO: PACKAGE:SYMBOL should signal error if SYMBOL is not an
947 ;; external symbol from PACKAGE.
948 (if (or internalp (eq package (find-package "KEYWORD")))
949 (intern name package)
950 (find-symbol name package))))
952 (defvar *eof* (gensym))
953 (defun ls-read (stream)
954 (skip-whitespaces-and-comments stream)
955 (let ((ch (%peek-char stream)))
957 ((or (null ch) (char= ch #\)))
964 (list 'quote (ls-read stream)))
967 (list 'backquote (ls-read stream)))
970 (read-string stream))
973 (if (eql (%peek-char stream) #\@)
974 (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
975 (list 'unquote (ls-read stream))))
979 (let ((string (read-until stream #'terminalp)))
980 (if (every #'digit-char-p string)
981 (parse-integer string)
982 (read-symbol string)))))))
984 (defun ls-read-from-string (string)
985 (ls-read (make-string-stream string)))
990 ;;; Translate the Lisp code to Javascript. It will compile the special
991 ;;; forms. Some primitive functions are compiled as special forms
992 ;;; too. The respective real functions are defined in the target (see
993 ;;; the beginning of this file) as well as some primitive functions.
995 ;;; If the special variable `*multiple-value-p*' is NON-NIL, then the
996 ;;; compilation of the current form is allowed to return multiple
997 ;;; values, using the VALUES variable.
998 (defvar *multiple-value-p* nil)
1000 (defvar *compilation-unit-checks* '())
1002 (defun make-binding (name type value &optional declarations)
1003 (list name type value declarations))
1005 (defun binding-name (b) (first b))
1006 (defun binding-type (b) (second b))
1007 (defun binding-value (b) (third b))
1008 (defun binding-declarations (b) (fourth b))
1010 (defun set-binding-value (b value)
1011 (setcar (cddr b) value))
1013 (defun set-binding-declarations (b value)
1014 (setcar (cdddr b) value))
1016 (defun push-binding-declaration (decl b)
1017 (set-binding-declarations b (cons decl (binding-declarations b))))
1020 (defun make-lexenv ()
1021 (list nil nil nil nil))
1023 (defun copy-lexenv (lexenv)
1026 (defun push-to-lexenv (binding lexenv namespace)
1028 (variable (setcar lexenv (cons binding (car lexenv))))
1029 (function (setcar (cdr lexenv) (cons binding (cadr lexenv))))
1030 (block (setcar (cddr lexenv) (cons binding (caddr lexenv))))
1031 (gotag (setcar (cdddr lexenv) (cons binding (cadddr lexenv))))))
1033 (defun extend-lexenv (bindings lexenv namespace)
1034 (let ((env (copy-lexenv lexenv)))
1035 (dolist (binding (reverse bindings) env)
1036 (push-to-lexenv binding env namespace))))
1038 (defun lookup-in-lexenv (name lexenv namespace)
1039 (assoc name (ecase namespace
1040 (variable (first lexenv))
1041 (function (second lexenv))
1042 (block (third lexenv))
1043 (gotag (fourth lexenv)))))
1045 (defvar *environment* (make-lexenv))
1047 (defvar *variable-counter* 0)
1048 (defun gvarname (symbol)
1049 (concat "v" (integer-to-string (incf *variable-counter*))))
1051 (defun translate-variable (symbol)
1052 (binding-value (lookup-in-lexenv symbol *environment* 'variable)))
1054 (defun extend-local-env (args)
1055 (let ((new (copy-lexenv *environment*)))
1056 (dolist (symbol args new)
1057 (let ((b (make-binding symbol 'lexical-variable (gvarname symbol))))
1058 (push-to-lexenv b new 'variable)))))
1060 ;;; Toplevel compilations
1061 (defvar *toplevel-compilations* nil)
1063 (defun toplevel-compilation (string)
1064 (push string *toplevel-compilations*))
1066 (defun null-or-empty-p (x)
1069 (defun get-toplevel-compilations ()
1070 (reverse (remove-if #'null-or-empty-p *toplevel-compilations*)))
1072 (defun %compile-defmacro (name lambda)
1073 (toplevel-compilation (ls-compile `',name))
1074 (push-to-lexenv (make-binding name 'macro lambda) *environment* 'function))
1076 (defun global-binding (name type namespace)
1077 (or (lookup-in-lexenv name *environment* namespace)
1078 (let ((b (make-binding name type nil)))
1079 (push-to-lexenv b *environment* namespace)
1082 (defun claimp (symbol namespace claim)
1083 (let ((b (lookup-in-lexenv symbol *environment* namespace)))
1084 (and b (member claim (binding-declarations b)))))
1086 (defun !proclaim (decl)
1089 (dolist (name (cdr decl))
1090 (let ((b (global-binding name 'variable 'variable)))
1091 (push-binding-declaration 'special b))))
1093 (dolist (name (cdr decl))
1094 (let ((b (global-binding name 'function 'function)))
1095 (push-binding-declaration 'notinline b))))
1097 (dolist (name (cdr decl))
1098 (let ((b (global-binding name 'variable 'variable)))
1099 (push-binding-declaration 'constant b))))
1101 (dolist (name (cdr decl))
1102 (let ((b (global-binding name 'function 'function)))
1103 (push-binding-declaration 'non-overridable b))))))
1106 (fset 'proclaim #'!proclaim)
1110 (defvar *compilations* nil)
1112 (defmacro define-compilation (name args &body body)
1113 ;; Creates a new primitive `name' with parameters args and
1114 ;; @body. The body can access to the local environment through the
1115 ;; variable *ENVIRONMENT*.
1116 `(push (list ',name (lambda ,args (block ,name ,@body)))
1119 (define-compilation if (condition true false)
1120 (concat "(" (ls-compile condition) " !== " (ls-compile nil)
1121 " ? " (ls-compile true *multiple-value-p*)
1122 " : " (ls-compile false *multiple-value-p*)
1125 (defvar *lambda-list-keywords* '(&optional &rest))
1127 (defun list-until-keyword (list)
1128 (if (or (null list) (member (car list) *lambda-list-keywords*))
1130 (cons (car list) (list-until-keyword (cdr list)))))
1132 (defun lambda-list-required-arguments (lambda-list)
1133 (list-until-keyword lambda-list))
1135 (defun lambda-list-optional-arguments-with-default (lambda-list)
1136 (mapcar #'ensure-list (list-until-keyword (cdr (member '&optional lambda-list)))))
1138 (defun lambda-list-optional-arguments (lambda-list)
1139 (mapcar #'car (lambda-list-optional-arguments-with-default lambda-list)))
1141 (defun lambda-list-rest-argument (lambda-list)
1142 (let ((rest (list-until-keyword (cdr (member '&rest lambda-list)))))
1144 (error "Bad lambda-list"))
1147 (defun lambda-docstring-wrapper (docstring &rest strs)
1150 "var func = " (join strs) ";" *newline*
1151 "func.docstring = '" docstring "';" *newline*
1152 "return func;" *newline*)
1155 (define-compilation lambda (lambda-list &rest body)
1156 (let ((required-arguments (lambda-list-required-arguments lambda-list))
1157 (optional-arguments (lambda-list-optional-arguments lambda-list))
1158 (rest-argument (lambda-list-rest-argument lambda-list))
1160 ;; Get the documentation string for the lambda function
1161 (when (and (stringp (car body))
1162 (not (null (cdr body))))
1163 (setq documentation (car body))
1164 (setq body (cdr body)))
1165 (let ((n-required-arguments (length required-arguments))
1166 (n-optional-arguments (length optional-arguments))
1167 (*environment* (extend-local-env
1168 (append (ensure-list rest-argument)
1170 optional-arguments))))
1171 (lambda-docstring-wrapper
1174 (join (cons "values"
1175 (mapcar #'translate-variable
1176 (append required-arguments optional-arguments)))
1179 ;; Check number of arguments
1181 (if required-arguments
1182 (concat "if (arguments.length < " (integer-to-string (1+ n-required-arguments))
1183 ") throw 'too few arguments';" *newline*)
1185 (if (not rest-argument)
1186 (concat "if (arguments.length > "
1187 (integer-to-string (+ 1 n-required-arguments n-optional-arguments))
1188 ") throw 'too many arguments';" *newline*)
1190 ;; Optional arguments
1191 (if optional-arguments
1192 (concat "switch(arguments.length-1){" *newline*
1193 (let ((optional-and-defaults
1194 (lambda-list-optional-arguments-with-default lambda-list))
1198 (while (< idx n-optional-arguments)
1199 (let ((arg (nth idx optional-and-defaults)))
1200 (push (concat "case "
1201 (integer-to-string (+ idx n-required-arguments)) ":" *newline*
1202 (translate-variable (car arg))
1204 (ls-compile (cadr arg))
1208 (push (concat "default: break;" *newline*) cases)
1209 (join (reverse cases))))
1212 ;; &rest/&body argument
1214 (let ((js!rest (translate-variable rest-argument)))
1215 (concat "var " js!rest "= " (ls-compile nil) ";" *newline*
1216 "for (var i = arguments.length-1; i>="
1217 (integer-to-string (+ 1 n-required-arguments n-optional-arguments))
1219 (indent js!rest " = "
1220 "{car: arguments[i], cdr: ") js!rest "};"
1224 (let ((*multiple-value-p* t)) (ls-compile-block body t)))
1229 (defun setq-pair (var val)
1230 (let ((b (lookup-in-lexenv var *environment* 'variable)))
1231 (if (eq (binding-type b) 'lexical-variable)
1232 (concat (binding-value b) " = " (ls-compile val))
1233 (ls-compile `(set ',var ,val)))))
1235 (define-compilation setq (&rest pairs)
1239 ((null pairs) (return))
1241 (error "Odd paris in SETQ"))
1244 (concat (setq-pair (car pairs) (cadr pairs))
1245 (if (null (cddr pairs)) "" ", ")))
1246 (setq pairs (cddr pairs)))))
1247 (concat "(" result ")")))
1249 ;;; FFI Variable accessors
1250 (define-compilation js-vref (var)
1253 (define-compilation js-vset (var val)
1254 (concat "(" var " = " (ls-compile val) ")"))
1259 (defun escape-string (string)
1262 (size (length string)))
1263 (while (< index size)
1264 (let ((ch (char string index)))
1265 (when (or (char= ch #\") (char= ch #\\))
1266 (setq output (concat output "\\")))
1267 (when (or (char= ch #\newline))
1268 (setq output (concat output "\\"))
1270 (setq output (concat output (string ch))))
1275 (defvar *literal-symbols* nil)
1276 (defvar *literal-counter* 0)
1279 (concat "l" (integer-to-string (incf *literal-counter*))))
1281 (defun literal (sexp &optional recursive)
1283 ((integerp sexp) (integer-to-string sexp))
1284 ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1286 (or (cdr (assoc sexp *literal-symbols*))
1288 (s #+common-lisp (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
1290 (let ((package (symbol-package sexp)))
1292 (concat "{name: \"" (escape-string (symbol-name sexp)) "\"}")
1293 (ls-compile `(intern ,(symbol-name sexp) ,(package-name package)))))))
1294 (push (cons sexp v) *literal-symbols*)
1295 (toplevel-compilation (concat "var " v " = " s))
1298 (let ((c (concat "{car: " (literal (car sexp) t) ", "
1299 "cdr: " (literal (cdr sexp) t) "}")))
1303 (toplevel-compilation (concat "var " v " = " c))
1306 (let ((elements (vector-to-list sexp)))
1307 (let ((c (concat "[" (join (mapcar #'literal elements) ", ") "]")))
1311 (toplevel-compilation (concat "var " v " = " c))
1314 (define-compilation quote (sexp)
1317 (define-compilation %while (pred &rest body)
1319 "while(" (ls-compile pred) " !== " (ls-compile nil) "){" *newline*
1320 (indent (ls-compile-block body))
1322 "return " (ls-compile nil) ";" *newline*))
1324 (define-compilation function (x)
1326 ((and (listp x) (eq (car x) 'lambda))
1329 (ls-compile `(symbol-function ',x)))))
1331 (define-compilation eval-when-compile (&rest body)
1332 (eval (cons 'progn body))
1335 (defmacro define-transformation (name args form)
1336 `(define-compilation ,name ,args
1337 (ls-compile ,form)))
1339 (define-compilation progn (&rest body)
1340 (js!selfcall (ls-compile-block body t)))
1342 (defun special-variable-p (x)
1343 (and (claimp x 'variable 'special) t))
1345 ;;; Wrap CODE to restore the symbol values of the dynamic
1346 ;;; bindings. BINDINGS is a list of pairs of the form
1347 ;;; (SYMBOL . PLACE), where PLACE is a Javascript variable
1348 ;;; name to initialize the symbol value and where to stored
1350 (defun let-binding-wrapper (bindings body)
1351 (when (null bindings)
1352 (return-from let-binding-wrapper body))
1355 (indent "var tmp;" *newline*
1358 (let ((s (ls-compile `(quote ,(car b)))))
1359 (concat "tmp = " s ".value;" *newline*
1360 s ".value = " (cdr b) ";" *newline*
1361 (cdr b) " = tmp;" *newline*)))
1365 "finally {" *newline*
1367 (mapconcat (lambda (b)
1368 (let ((s (ls-compile `(quote ,(car b)))))
1369 (concat s ".value" " = " (cdr b) ";" *newline*)))
1373 (define-compilation let (bindings &rest body)
1374 (let* ((bindings (mapcar #'ensure-list bindings))
1375 (variables (mapcar #'first bindings))
1376 (cvalues (mapcar #'ls-compile (mapcar #'second bindings)))
1377 (*environment* (extend-local-env (remove-if #'special-variable-p variables)))
1379 (concat "(function("
1380 (join (mapcar (lambda (x)
1381 (if (special-variable-p x)
1382 (let ((v (gvarname x)))
1383 (push (cons x v) dynamic-bindings)
1385 (translate-variable x)))
1389 (let ((body (ls-compile-block body t)))
1390 (indent (let-binding-wrapper dynamic-bindings body)))
1391 "})(" (join cvalues ",") ")")))
1394 ;;; Return the code to initialize BINDING, and push it extending the
1395 ;;; current lexical environment if the variable is special.
1396 (defun let*-initialize-value (binding)
1397 (let ((var (first binding))
1398 (value (second binding)))
1399 (if (special-variable-p var)
1400 (concat (ls-compile `(setq ,var ,value)) ";" *newline*)
1401 (let* ((v (gvarname var))
1402 (b (make-binding var 'variable v)))
1403 (prog1 (concat "var " v " = " (ls-compile value) ";" *newline*)
1404 (push-to-lexenv b *environment* 'variable))))))
1406 ;;; Wrap BODY to restore the symbol values of SYMBOLS after body. It
1407 ;;; DOES NOT generate code to initialize the value of the symbols,
1408 ;;; unlike let-binding-wrapper.
1409 (defun let*-binding-wrapper (symbols body)
1410 (when (null symbols)
1411 (return-from let*-binding-wrapper body))
1412 (let ((store (mapcar (lambda (s) (cons s (gvarname s)))
1413 (remove-if-not #'special-variable-p symbols))))
1417 (mapconcat (lambda (b)
1418 (let ((s (ls-compile `(quote ,(car b)))))
1419 (concat "var " (cdr b) " = " s ".value;" *newline*)))
1423 "finally {" *newline*
1425 (mapconcat (lambda (b)
1426 (let ((s (ls-compile `(quote ,(car b)))))
1427 (concat s ".value" " = " (cdr b) ";" *newline*)))
1431 (define-compilation let* (bindings &rest body)
1432 (let ((bindings (mapcar #'ensure-list bindings))
1433 (*environment* (copy-lexenv *environment*)))
1435 (let ((specials (remove-if-not #'special-variable-p (mapcar #'first bindings)))
1436 (body (concat (mapconcat #'let*-initialize-value bindings)
1437 (ls-compile-block body t))))
1438 (let*-binding-wrapper specials body)))))
1441 (defvar *block-counter* 0)
1443 (define-compilation block (name &rest body)
1444 (let ((tr (integer-to-string (incf *block-counter*))))
1445 (let ((b (make-binding name 'block tr)))
1448 (let ((*environment* (extend-lexenv (list b) *environment* 'block)))
1449 (indent "return " (ls-compile `(progn ,@body) *multiple-value-p*) ";" *newline*))
1451 "catch (cf){" *newline*
1452 " if (cf.type == 'block' && cf.id == " tr ")" *newline*
1453 " return cf.value;" *newline*
1455 " throw cf;" *newline*
1458 (define-compilation return-from (name &optional value)
1459 (let ((b (lookup-in-lexenv name *environment* 'block)))
1464 "id: " (binding-value b) ", "
1465 "value: " (ls-compile value) ", "
1466 "message: 'Return from unknown block " (symbol-name name) ".'"
1468 (error (concat "Unknown block `" (symbol-name name) "'.")))))
1470 (define-compilation catch (id &rest body)
1472 "var id = " (ls-compile id) ";" *newline*
1474 (indent "return " (ls-compile `(progn ,@body))
1477 "catch (cf){" *newline*
1478 " if (cf.type == 'catch' && cf.id == id)" *newline*
1479 " return cf.value;" *newline*
1481 " throw cf;" *newline*
1484 (define-compilation throw (id value)
1488 "id: " (ls-compile id) ", "
1489 "value: " (ls-compile value) ", "
1490 "message: 'Throw uncatched.'"
1494 (defvar *tagbody-counter* 0)
1495 (defvar *go-tag-counter* 0)
1498 (or (integerp x) (symbolp x)))
1500 (defun declare-tagbody-tags (tbidx body)
1502 (mapcar (lambda (label)
1503 (let ((tagidx (integer-to-string (incf *go-tag-counter*))))
1504 (make-binding label 'gotag (list tbidx tagidx))))
1505 (remove-if-not #'go-tag-p body))))
1506 (extend-lexenv bindings *environment* 'gotag)))
1508 (define-compilation tagbody (&rest body)
1509 ;; Ignore the tagbody if it does not contain any go-tag. We do this
1510 ;; because 1) it is easy and 2) many built-in forms expand to a
1511 ;; implicit tagbody, so we save some space.
1512 (unless (some #'go-tag-p body)
1513 (return-from tagbody (ls-compile `(progn ,@body nil))))
1514 ;; The translation assumes the first form in BODY is a label
1515 (unless (go-tag-p (car body))
1516 (push (gensym "START") body))
1517 ;; Tagbody compilation
1518 (let ((tbidx (integer-to-string *tagbody-counter*)))
1519 (let ((*environment* (declare-tagbody-tags tbidx body))
1521 (let ((b (lookup-in-lexenv (first body) *environment* 'gotag)))
1522 (setq initag (second (binding-value b))))
1524 "var tagbody_" tbidx " = " initag ";" *newline*
1526 "while (true) {" *newline*
1527 (indent "try {" *newline*
1528 (indent (let ((content ""))
1529 (concat "switch(tagbody_" tbidx "){" *newline*
1530 "case " initag ":" *newline*
1531 (dolist (form (cdr body) content)
1533 (if (not (go-tag-p form))
1534 (indent (ls-compile form) ";" *newline*)
1535 (let ((b (lookup-in-lexenv form *environment* 'gotag)))
1536 (concat "case " (second (binding-value b)) ":" *newline*)))))
1537 "default:" *newline*
1538 " break tbloop;" *newline*
1541 "catch (jump) {" *newline*
1542 " if (jump.type == 'tagbody' && jump.id == " tbidx ")" *newline*
1543 " tagbody_" tbidx " = jump.label;" *newline*
1545 " throw(jump);" *newline*
1548 "return " (ls-compile nil) ";" *newline*))))
1550 (define-compilation go (label)
1551 (let ((b (lookup-in-lexenv label *environment* 'gotag))
1553 ((symbolp label) (symbol-name label))
1554 ((integerp label) (integer-to-string label)))))
1559 "id: " (first (binding-value b)) ", "
1560 "label: " (second (binding-value b)) ", "
1561 "message: 'Attempt to GO to non-existing tag " n "'"
1563 (error (concat "Unknown tag `" n "'.")))))
1565 (define-compilation unwind-protect (form &rest clean-up)
1567 "var ret = " (ls-compile nil) ";" *newline*
1569 (indent "ret = " (ls-compile form) ";" *newline*)
1570 "} finally {" *newline*
1571 (indent (ls-compile-block clean-up))
1573 "return ret;" *newline*))
1575 (define-compilation multiple-value-call (func-form &rest forms)
1576 (let ((func (ls-compile func-form)))
1578 "var args = [values];" *newline*
1579 "var values = mv;" *newline*
1581 (mapconcat (lambda (form)
1582 (concat "vs = " (ls-compile form t) ";" *newline*
1583 "if (typeof vs === 'object' && 'multiple-value' in vs)" *newline*
1584 (indent "args = args.concat(vs);" *newline*)
1586 (indent "args.push(vs);" *newline*)))
1588 "return (" func ").apply(window, args);" *newline*)))
1592 ;;; A little backquote implementation without optimizations of any
1593 ;;; kind for ecmalisp.
1594 (defun backquote-expand-1 (form)
1600 ((eq (car form) 'unquote)
1602 ((eq (car form) 'backquote)
1603 (backquote-expand-1 (backquote-expand-1 (cadr form))))
1608 ((and (listp s) (eq (car s) 'unquote))
1609 (list 'list (cadr s)))
1610 ((and (listp s) (eq (car s) 'unquote-splicing))
1613 (list 'list (backquote-expand-1 s)))))
1616 (defun backquote-expand (form)
1617 (if (and (listp form) (eq (car form) 'backquote))
1618 (backquote-expand-1 (cadr form))
1621 (defmacro backquote (form)
1622 (backquote-expand-1 form))
1624 (define-transformation backquote (form)
1625 (backquote-expand-1 form))
1629 (defvar *builtins* nil)
1631 (defmacro define-raw-builtin (name args &body body)
1632 ;; Creates a new primitive function `name' with parameters args and
1633 ;; @body. The body can access to the local environment through the
1634 ;; variable *ENVIRONMENT*.
1635 `(push (list ',name (lambda ,args (block ,name ,@body)))
1638 (defmacro define-builtin (name args &body body)
1640 (define-raw-builtin ,name ,args
1641 (let ,(mapcar (lambda (arg) `(,arg (ls-compile ,arg))) args)
1644 ;;; DECLS is a list of (JSVARNAME TYPE LISPFORM) declarations.
1645 (defmacro type-check (decls &body body)
1647 ,@(mapcar (lambda (decl)
1648 `(concat "var " ,(first decl) " = " ,(third decl) ";" *newline*))
1650 ,@(mapcar (lambda (decl)
1651 `(concat "if (typeof " ,(first decl) " != '" ,(second decl) "')" *newline*
1652 (indent "throw 'The value ' + "
1654 " + ' is not a type "
1659 (concat "return " (progn ,@body) ";" *newline*)))
1661 ;;; VARIABLE-ARITY compiles variable arity operations. ARGS stands for
1662 ;;; a variable which holds a list of forms. It will compile them and
1663 ;;; store the result in some Javascript variables. BODY is evaluated
1664 ;;; with ARGS bound to the list of these variables to generate the
1665 ;;; code which performs the transformation on these variables.
1667 (defun variable-arity-call (args function)
1668 (unless (consp args)
1669 (error "ARGS must be a non-empty list"))
1674 (let ((v (concat "x" (integer-to-string (incf counter)))))
1677 (concat "var " v " = " (ls-compile x) ";" *newline*
1678 "if (typeof " v " !== 'number') throw 'Not a number!';"
1680 (js!selfcall prelude (funcall function (reverse variables)))))
1683 (defmacro variable-arity (args &body body)
1684 (unless (symbolp args)
1685 (error "Bad usage of VARIABLE-ARITY, you must pass a symbol"))
1686 `(variable-arity-call ,args
1688 (concat "return " ,@body ";" *newline*))))
1690 (defun num-op-num (x op y)
1691 (type-check (("x" "number" x) ("y" "number" y))
1692 (concat "x" op "y")))
1694 (define-raw-builtin + (&rest numbers)
1697 (variable-arity numbers
1698 (join numbers "+"))))
1700 (define-raw-builtin - (x &rest others)
1701 (let ((args (cons x others)))
1702 (variable-arity args
1704 (concat "-" (car args))
1707 (define-raw-builtin * (&rest numbers)
1710 (variable-arity numbers
1711 (join numbers "*"))))
1713 (define-raw-builtin / (x &rest others)
1714 (let ((args (cons x others)))
1715 (variable-arity args
1717 (concat "1 /" (car args))
1720 (define-builtin mod (x y) (num-op-num x "%" y))
1723 (defun comparison-conjuntion (vars op)
1728 (concat (car vars) op (cadr vars)))
1730 (concat (car vars) op (cadr vars)
1732 (comparison-conjuntion (cdr vars) op)))))
1734 (defmacro define-builtin-comparison (op sym)
1735 `(define-raw-builtin ,op (x &rest args)
1736 (let ((args (cons x args)))
1737 (variable-arity args
1738 (js!bool (comparison-conjuntion args ,sym))))))
1740 (define-builtin-comparison > ">")
1741 (define-builtin-comparison < "<")
1742 (define-builtin-comparison >= ">=")
1743 (define-builtin-comparison <= "<=")
1744 (define-builtin-comparison = "==")
1746 (define-builtin numberp (x)
1747 (js!bool (concat "(typeof (" x ") == \"number\")")))
1749 (define-builtin floor (x)
1750 (type-check (("x" "number" x))
1753 (define-builtin cons (x y)
1754 (concat "({car: " x ", cdr: " y "})"))
1756 (define-builtin consp (x)
1759 "var tmp = " x ";" *newline*
1760 "return (typeof tmp == 'object' && 'car' in tmp);" *newline*)))
1762 (define-builtin car (x)
1764 "var tmp = " x ";" *newline*
1765 "return tmp === " (ls-compile nil)
1766 "? " (ls-compile nil)
1767 ": tmp.car;" *newline*))
1769 (define-builtin cdr (x)
1771 "var tmp = " x ";" *newline*
1772 "return tmp === " (ls-compile nil) "? "
1774 ": tmp.cdr;" *newline*))
1776 (define-builtin setcar (x new)
1777 (type-check (("x" "object" x))
1778 (concat "(x.car = " new ")")))
1780 (define-builtin setcdr (x new)
1781 (type-check (("x" "object" x))
1782 (concat "(x.cdr = " new ")")))
1784 (define-builtin symbolp (x)
1787 "var tmp = " x ";" *newline*
1788 "return (typeof tmp == 'object' && 'name' in tmp);" *newline*)))
1790 (define-builtin make-symbol (name)
1791 (type-check (("name" "string" name))
1794 (define-builtin symbol-name (x)
1795 (concat "(" x ").name"))
1797 (define-builtin set (symbol value)
1798 (concat "(" symbol ").value = " value))
1800 (define-builtin fset (symbol value)
1801 (concat "(" symbol ").fvalue = " value))
1803 (define-builtin boundp (x)
1804 (js!bool (concat "(" x ".value !== undefined)")))
1806 (define-builtin symbol-value (x)
1808 "var symbol = " x ";" *newline*
1809 "var value = symbol.value;" *newline*
1810 "if (value === undefined) throw \"Variable `\" + symbol.name + \"' is unbound.\";" *newline*
1811 "return value;" *newline*))
1813 (define-builtin symbol-function (x)
1815 "var symbol = " x ";" *newline*
1816 "var func = symbol.fvalue;" *newline*
1817 "if (func === undefined) throw \"Function `\" + symbol.name + \"' is undefined.\";" *newline*
1818 "return func;" *newline*))
1820 (define-builtin symbol-plist (x)
1821 (concat "((" x ").plist || " (ls-compile nil) ")"))
1823 (define-builtin lambda-code (x)
1824 (concat "(" x ").toString()"))
1826 (define-builtin eq (x y) (js!bool (concat "(" x " === " y ")")))
1827 (define-builtin equal (x y) (js!bool (concat "(" x " == " y ")")))
1829 (define-builtin char-to-string (x)
1830 (type-check (("x" "number" x))
1831 "String.fromCharCode(x)"))
1833 (define-builtin stringp (x)
1834 (js!bool (concat "(typeof(" x ") == \"string\")")))
1836 (define-builtin string-upcase (x)
1837 (type-check (("x" "string" x))
1840 (define-builtin string-length (x)
1841 (type-check (("x" "string" x))
1844 (define-raw-builtin slice (string a &optional b)
1846 "var str = " (ls-compile string) ";" *newline*
1847 "var a = " (ls-compile a) ";" *newline*
1850 (concat "b = " (ls-compile b) ";" *newline*)
1852 "return str.slice(a,b);" *newline*))
1854 (define-builtin char (string index)
1855 (type-check (("string" "string" string)
1856 ("index" "number" index))
1857 "string.charCodeAt(index)"))
1859 (define-builtin concat-two (string1 string2)
1860 (type-check (("string1" "string" string1)
1861 ("string2" "string" string2))
1862 "string1.concat(string2)"))
1864 (define-raw-builtin funcall (func &rest args)
1865 (concat "(" (ls-compile func) ")("
1866 (join (cons (if *multiple-value-p* "values" "pv")
1867 (mapcar #'ls-compile args))
1871 (define-raw-builtin apply (func &rest args)
1873 (concat "(" (ls-compile func) ")()")
1874 (let ((args (butlast args))
1875 (last (car (last args))))
1877 "var f = " (ls-compile func) ";" *newline*
1878 "var args = [" (join (cons (if *multiple-value-p* "values" "pv")
1879 (mapcar #'ls-compile args))
1882 "var tail = (" (ls-compile last) ");" *newline*
1883 "while (tail != " (ls-compile nil) "){" *newline*
1884 " args.push(tail.car);" *newline*
1885 " tail = tail.cdr;" *newline*
1887 "return f.apply(this, args);" *newline*))))
1889 (define-builtin js-eval (string)
1890 (type-check (("string" "string" string))
1891 (if *multiple-value-p*
1893 "var v = eval.apply(window, [string]);" *newline*
1894 "if (typeof v !== 'object' || !('multiple-value' in v)){" *newline*
1895 (indent "v = [v];" *newline*
1896 "v['multiple-value'] = true;" *newline*)
1898 "return values.apply(this, v);" *newline*)
1899 "eval.apply(window, [string])")))
1901 (define-builtin error (string)
1902 (js!selfcall "throw " string ";" *newline*))
1904 (define-builtin new () "{}")
1906 (define-builtin objectp (x)
1907 (js!bool (concat "(typeof (" x ") === 'object')")))
1909 (define-builtin oget (object key)
1911 "var tmp = " "(" object ")[" key "];" *newline*
1912 "return tmp == undefined? " (ls-compile nil) ": tmp ;" *newline*))
1914 (define-builtin oset (object key value)
1915 (concat "((" object ")[" key "] = " value ")"))
1917 (define-builtin in (key object)
1918 (js!bool (concat "((" key ") in (" object "))")))
1920 (define-builtin functionp (x)
1921 (js!bool (concat "(typeof " x " == 'function')")))
1923 (define-builtin write-string (x)
1924 (type-check (("x" "string" x))
1927 (define-builtin make-array (n)
1929 "var r = [];" *newline*
1930 "for (var i = 0; i < " n "; i++)" *newline*
1931 (indent "r.push(" (ls-compile nil) ");" *newline*)
1932 "return r;" *newline*))
1934 (define-builtin arrayp (x)
1937 "var x = " x ";" *newline*
1938 "return typeof x === 'object' && 'length' in x;")))
1940 (define-builtin aref (array n)
1942 "var x = " "(" array ")[" n "];" *newline*
1943 "if (x === undefined) throw 'Out of range';" *newline*
1944 "return x;" *newline*))
1946 (define-builtin aset (array n value)
1948 "var x = " array ";" *newline*
1949 "var i = " n ";" *newline*
1950 "if (i < 0 || i >= x.length) throw 'Out of range';" *newline*
1951 "return x[i] = " value ";" *newline*))
1953 (define-builtin get-unix-time ()
1954 (concat "(Math.round(new Date() / 1000))"))
1956 (define-builtin values-array (array)
1957 (if *multiple-value-p*
1958 (concat "values.apply(this, " array ")")
1959 (concat "pv.apply(this, " array ")")))
1961 (define-raw-builtin values (&rest args)
1962 (if *multiple-value-p*
1963 (concat "values(" (join (mapcar #'ls-compile args) ", ") ")")
1964 (concat "pv(" (join (mapcar #'ls-compile args) ", ") ")")))
1968 (let ((b (lookup-in-lexenv x *environment* 'function)))
1969 (and (eq (binding-type b) 'macro)
1972 (defun ls-macroexpand-1 (form)
1973 (let ((macro-binding (macro (car form))))
1975 (let ((expander (binding-value macro-binding)))
1976 (when (listp expander)
1977 (let ((compiled (eval expander)))
1978 ;; The list representation are useful while
1979 ;; bootstrapping, as we can dump the definition of the
1980 ;; macros easily, but they are slow because we have to
1981 ;; evaluate them and compile them now and again. So, let
1982 ;; us replace the list representation version of the
1983 ;; function with the compiled one.
1985 #+ecmalisp (set-binding-value macro-binding compiled)
1986 (setq expander compiled)))
1987 (apply expander (cdr form)))
1990 (defun compile-funcall (function args)
1991 (let ((values-funcs (if *multiple-value-p* "values" "pv")))
1992 (if (and (symbolp function)
1993 (claimp function 'function 'non-overridable))
1994 (concat (ls-compile `',function) ".fvalue("
1995 (join (cons values-funcs (mapcar #'ls-compile args))
1998 (concat (ls-compile `#',function) "("
1999 (join (cons values-funcs (mapcar #'ls-compile args))
2003 (defun ls-compile-block (sexps &optional return-last-p)
2005 (concat (ls-compile-block (butlast sexps))
2006 "return "(ls-compile (car (last sexps)) *multiple-value-p*) ";")
2008 (remove-if #'null-or-empty-p (mapcar #'ls-compile sexps))
2009 (concat ";" *newline*))))
2011 (defun ls-compile (sexp &optional multiple-value-p)
2012 (let ((*multiple-value-p* multiple-value-p))
2015 (let ((b (lookup-in-lexenv sexp *environment* 'variable)))
2017 ((and b (not (member 'special (binding-declarations b))))
2019 ((or (keywordp sexp)
2020 (member 'constant (binding-declarations b)))
2021 (concat (ls-compile `',sexp) ".value"))
2023 (ls-compile `(symbol-value ',sexp))))))
2024 ((integerp sexp) (integer-to-string sexp))
2025 ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
2026 ((arrayp sexp) (literal sexp))
2028 (let ((name (car sexp))
2032 ((assoc name *compilations*)
2033 (let ((comp (second (assoc name *compilations*))))
2035 ;; Built-in functions
2036 ((and (assoc name *builtins*)
2037 (not (claimp name 'function 'notinline)))
2038 (let ((comp (second (assoc name *builtins*))))
2042 (ls-compile (ls-macroexpand-1 sexp))
2043 (compile-funcall name args))))))
2045 (error "How should I compile this?")))))
2047 (defun ls-compile-toplevel (sexp &optional multiple-value-p)
2048 (let ((*toplevel-compilations* nil))
2050 ((and (consp sexp) (eq (car sexp) 'progn))
2051 (let ((subs (mapcar #'ls-compile-toplevel (cdr sexp))))
2052 (join (remove-if #'null-or-empty-p subs))))
2054 (let ((code (ls-compile sexp multiple-value-p)))
2055 (concat (join-trailing (get-toplevel-compilations)
2056 (concat ";" *newline*))
2058 (concat code ";" *newline*)
2062 ;;; Once we have the compiler, we define the runtime environment and
2063 ;;; interactive development (eval), which works calling the compiler
2064 ;;; and evaluating the Javascript result globally.
2069 (js-eval (ls-compile-toplevel x t)))
2071 (export '(&rest &optional &body * *gensym-counter* *package* + - / 1+ 1- < <= =
2072 = > >= and append apply aref arrayp aset assoc atom block boundp
2073 boundp butlast caar cadddr caddr cadr car car case catch cdar cdddr
2074 cddr cdr cdr char char-code char= code-char cond cons consp copy-list
2075 decf declaim defparameter defun defmacro defvar digit-char-p disassemble
2076 documentation dolist dotimes ecase eq eql equal error eval every
2077 export fdefinition find-package find-symbol first fourth fset funcall
2078 function functionp gensym get-universal-time go identity if in-package
2079 incf integerp integerp intern keywordp lambda last length let let*
2080 list-all-packages list listp make-array make-package make-symbol
2081 mapcar member minusp mod multiple-value-call nil not nth nthcdr null
2082 numberp or package-name package-use-list packagep plusp prin1-to-string
2083 print proclaim prog1 prog2 progn psetq push quote remove remove-if
2084 remove-if-not return return-from revappend reverse second set setq
2085 some string-upcase string string= stringp subseq symbol-function
2086 symbol-name symbol-package symbol-plist symbol-value symbolp t tagbody
2087 third throw truncate unless unwind-protect values values-list variable
2088 warn when write-line write-string zerop))
2090 (setq *package* *user-package*)
2092 (js-eval "var lisp")
2093 (js-vset "lisp" (new))
2094 (js-vset "lisp.read" #'ls-read-from-string)
2095 (js-vset "lisp.print" #'prin1-to-string)
2096 (js-vset "lisp.eval" #'eval)
2097 (js-vset "lisp.compile" #'ls-compile-toplevel)
2098 (js-vset "lisp.evalString" (lambda (str) (eval (ls-read-from-string str))))
2099 (js-vset "lisp.compileString" (lambda (str) (ls-compile-toplevel (ls-read-from-string str))))
2101 ;; Set the initial global environment to be equal to the host global
2102 ;; environment at this point of the compilation.
2104 (toplevel-compilation
2107 ,@(mapcar (lambda (s) `(%intern-symbol (js-vref ,(cdr s))))
2109 (setq *literal-symbols* ',*literal-symbols*)
2110 (setq *environment* ',*environment*)
2111 (setq *variable-counter* ,*variable-counter*)
2112 (setq *gensym-counter* ,*gensym-counter*)
2113 (setq *block-counter* ,*block-counter*)))))
2116 (toplevel-compilation
2118 `(setq *literal-counter* ,*literal-counter*)))))
2121 ;;; Finally, we provide a couple of functions to easily bootstrap
2122 ;;; this. It just calls the compiler with this file as input.
2126 (defun read-whole-file (filename)
2127 (with-open-file (in filename)
2128 (let ((seq (make-array (file-length in) :element-type 'character)))
2129 (read-sequence seq in)
2132 (defun ls-compile-file (filename output)
2133 (setq *compilation-unit-checks* nil)
2134 (with-open-file (out output :direction :output :if-exists :supersede)
2135 (let* ((source (read-whole-file filename))
2136 (in (make-string-stream source)))
2138 for x = (ls-read in)
2140 for compilation = (ls-compile-toplevel x)
2141 when (plusp (length compilation))
2142 do (write-string compilation out))
2143 (dolist (check *compilation-unit-checks*)
2145 (setq *compilation-unit-checks* nil))))
2148 (setq *environment* (make-lexenv))
2149 (setq *literal-symbols* nil)
2150 (setq *variable-counter* 0
2154 (ls-compile-file "ecmalisp.lisp" "ecmalisp.js")))