1 ;;; lispstrack.lisp ---
3 ;; Copyright (C) 2012 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 lispstrack 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.
27 (%compile-defmacro 'defmacro
28 '(lambda (name args &rest body)
30 (%compile-defmacro ',name '(lambda ,args ,@body))))))
32 (defmacro %defvar (name value)
35 (%compile-defvar ',name))
38 (defmacro defvar (name value)
39 `(%defvar ,name ,value))
41 (defmacro %defun (name args &rest body)
44 (%compile-defun ',name))
45 (fsetq ,name (lambda ,args ,@body))))
47 (defmacro defun (name args &rest body)
48 `(%defun ,name ,args ,@body))
50 (defvar *package* (new))
52 (defvar nil (make-symbol "NIL"))
53 (set *package* "NIL" nil)
55 (defvar t (make-symbol "T"))
64 (set *package* name (make-symbol name))))
66 (defun find-symbol (name)
69 (defmacro when (condition &rest body)
70 `(if ,condition (progn ,@body) nil))
72 (defmacro unless (condition &rest body)
73 `(if ,condition nil (progn ,@body)))
75 (defmacro dolist (iter &rest body)
76 (let ((var (first iter))
77 (g!list (make-symbol "LIST")))
78 `(let ((,g!list ,(second iter))
81 (setq ,var (car ,g!list))
83 (setq ,g!list (cdr ,g!list))))))
85 (defun = (x y) (= x y))
86 (defun + (x y) (+ x y))
87 (defun - (x y) (- x y))
88 (defun * (x y) (* x y))
89 (defun / (x y) (/ x y))
90 (defun 1+ (x) (+ x 1))
91 (defun 1- (x) (- x 1))
92 (defun zerop (x) (= x 0))
93 (defun not (x) (if x nil t))
95 (defun truncate (x y) (floor (/ x y)))
97 (defun cons (x y ) (cons x y))
98 (defun consp (x) (consp x))
100 (defun car (x) (car x))
101 (defun cdr (x) (cdr x))
103 (defun caar (x) (car (car x)))
104 (defun cadr (x) (car (cdr x)))
105 (defun cdar (x) (cdr (car x)))
106 (defun cddr (x) (cdr (cdr x)))
107 (defun caddr (x) (car (cdr (cdr x))))
108 (defun cdddr (x) (cdr (cdr (cdr x))))
109 (defun cadddr (x) (car (cdr (cdr (cdr x)))))
111 (defun first (x) (car x))
112 (defun second (x) (cadr x))
113 (defun third (x) (caddr x))
114 (defun fourth (x) (cadddr x))
116 (defun list (&rest args)
122 (defun ensure-list (x)
127 (defun !reduce (func list initial)
132 (funcall func initial (car list)))))
136 (defmacro defun (name args &rest body)
138 (%defun ,name ,args ,@body)
141 (defmacro defvar (name value)
143 (%defvar ,name ,value)
146 (defun append-two (list1 list2)
150 (append (cdr list1) list2))))
152 (defun append (&rest lists)
153 (!reduce #'append-two lists '()))
155 (defun reverse-aux (list acc)
158 (reverse-aux (cdr list) (cons (car list) acc))))
160 (defun reverse (list)
161 (reverse-aux list '()))
169 (defun list-length (list)
171 (while (not (null list))
173 (setq list (cdr list)))
181 (defun mapcar (func list)
184 (cons (funcall func (car list))
185 (mapcar func (cdr list)))))
187 (defmacro push (x place)
188 `(setq ,place (cons ,x ,place)))
190 (defmacro cond (&rest clausules)
193 (if (eq (caar clausules) t)
194 `(progn ,@(cdar clausules))
195 `(if ,(caar clausules)
196 (progn ,@(cdar clausules))
197 (cond ,@(cdr clausules))))))
199 (defmacro case (form &rest clausules)
200 (let ((!form (make-symbol "FORM")))
201 `(let ((,!form ,form))
203 ,@(mapcar (lambda (clausule)
204 (if (eq (car clausule) t)
206 `((eql ,!form ,(car clausule))
210 (defmacro ecase (form &rest clausules)
215 (error "ECASE expression failed."))))))
217 (defun code-char (x) x)
218 (defun char-code (x) x)
219 (defun char= (x y) (= x y))
221 (defmacro and (&rest forms)
232 (defmacro or (&rest forms)
239 (let ((g (make-symbol "VAR")))
240 `(let ((,g ,(car forms)))
241 (if ,g ,g (or ,@(cdr forms))))))))
243 (defmacro prog1 (form &rest body)
244 (let ((value (make-symbol "VALUE")))
245 `(let ((,value ,form))
249 (defun <= (x y) (or (< x y) (= x y)))
250 (defun >= (x y) (not (< x y)))
253 (or (consp x) (null x)))
256 (and (numberp x) (= (floor x) x)))
266 (cons (car x) (butlast (cdr x)))))
268 (defun member (x list)
275 (member x (cdr list)))))
277 (defun remove (x list)
282 (remove x (cdr list)))
284 (cons (car list) (remove x (cdr list))))))
286 (defun remove-if (func list)
290 ((funcall func (car list))
291 (remove-if func (cdr list)))
293 (cons (car list) (remove-if func (cdr list))))))
295 (defun remove-if-not (func list)
299 ((funcall func (car list))
300 (cons (car list) (remove-if-not func (cdr list))))
302 (remove-if-not func (cdr list)))))
304 (defun digit-char-p (x)
305 (if (and (<= #\0 x) (<= x #\9))
309 (defun parse-integer (string)
312 (size (length string)))
313 (while (< index size)
314 (setq value (+ (* value 10) (digit-char-p (char string index))))
318 (defun every (function seq)
323 (while (and ret (< index size))
324 (unless (funcall function (char seq index))
332 (defun assoc (x alist)
336 ((eql x (caar alist))
339 (assoc x (cdr alist)))))
341 (defun string= (s1 s2)
345 ;;; The compiler offers some primitives and special forms which are
346 ;;; not found in Common Lisp, for instance, while. So, we grow Common
347 ;;; Lisp a bit to it can execute the rest of the file.
350 (defmacro while (condition &body body)
355 (defmacro eval-when-compile (&body body)
356 `(eval-when (:compile-toplevel :load-toplevel :execute)
359 (defun concat-two (s1 s2)
360 (concatenate 'string s1 s2))
362 (defun setcar (cons new)
363 (setf (car cons) new))
364 (defun setcdr (cons new)
365 (setf (cdr cons) new)))
368 ;;; At this point, no matter if Common Lisp or lispstrack is compiling
369 ;;; from here, this code will compile on both. We define some helper
370 ;;; functions now for string manipulation and so on. They will be
371 ;;; useful in the compiler, mostly.
373 (defvar *newline* (string (code-char 10)))
375 (defun concat (&rest strs)
376 (!reduce (lambda (s1 s2) (concat-two s1 s2))
380 ;;; Concatenate a list of strings, with a separator
381 (defun join (list separator)
390 (join (cdr list) separator)))))
392 (defun join-trailing (list separator)
395 (concat (car list) separator (join-trailing (cdr list) separator))))
397 (defun integer-to-string (x)
401 (while (not (zerop x))
402 (push (mod x 10) digits)
403 (setq x (truncate x 10)))
404 (join (mapcar (lambda (d) (string (char "0123456789" d)))
410 ;;; The Lisp reader, parse strings and return Lisp objects. The main
411 ;;; entry points are `ls-read' and `ls-read-from-string'.
413 (defun make-string-stream (string)
416 (defun %peek-char (stream)
417 (and (< (cdr stream) (length (car stream)))
418 (char (car stream) (cdr stream))))
420 (defun %read-char (stream)
421 (and (< (cdr stream) (length (car stream)))
422 (prog1 (char (car stream) (cdr stream))
423 (setcdr stream (1+ (cdr stream))))))
425 (defun whitespacep (ch)
426 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
428 (defun skip-whitespaces (stream)
430 (setq ch (%peek-char stream))
431 (while (and ch (whitespacep ch))
433 (setq ch (%peek-char stream)))))
435 (defun terminalp (ch)
436 (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
438 (defun read-until (stream func)
441 (setq ch (%peek-char stream))
442 (while (not (funcall func ch))
443 (setq string (concat string (string ch)))
445 (setq ch (%peek-char stream)))
448 (defun skip-whitespaces-and-comments (stream)
450 (skip-whitespaces stream)
451 (setq ch (%peek-char stream))
452 (while (and ch (char= ch #\;))
453 (read-until stream (lambda (x) (char= x #\newline)))
454 (skip-whitespaces stream)
455 (setq ch (%peek-char stream)))))
457 (defun %read-list (stream)
458 (skip-whitespaces-and-comments stream)
459 (let ((ch (%peek-char stream)))
462 (error "Unspected EOF"))
468 (prog1 (ls-read stream)
469 (skip-whitespaces-and-comments stream)
470 (unless (char= (%read-char stream) #\))
471 (error "')' was expected."))))
473 (cons (ls-read stream) (%read-list stream))))))
475 (defun read-string (stream)
478 (setq ch (%read-char stream))
479 (while (not (eql ch #\"))
481 (error "Unexpected EOF"))
483 (setq ch (%read-char stream)))
484 (setq string (concat string (string ch)))
485 (setq ch (%read-char stream)))
488 (defvar *eof* (make-symbol "EOF"))
489 (defun ls-read (stream)
490 (skip-whitespaces-and-comments stream)
491 (let ((ch (%peek-char stream)))
500 (list 'quote (ls-read stream)))
503 (list 'backquote (ls-read stream)))
506 (read-string stream))
509 (if (eql (%peek-char stream) #\@)
510 (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
511 (list 'unquote (ls-read stream))))
514 (ecase (%read-char stream)
516 (list 'function (ls-read stream)))
519 (concat (string (%read-char stream))
520 (read-until stream #'terminalp))))
522 ((string= cname "space") (char-code #\space))
523 ((string= cname "tab") (char-code #\tab))
524 ((string= cname "newline") (char-code #\newline))
525 (t (char-code (char cname 0))))))
527 (let ((feature (read-until stream #'terminalp)))
529 ((string= feature "common-lisp")
530 (ls-read stream) ;ignore
532 ((string= feature "lispstrack")
535 (error "Unknown reader form.")))))))
537 (let ((string (read-until stream #'terminalp)))
538 (if (every #'digit-char-p string)
539 (parse-integer string)
540 (intern (string-upcase string))))))))
542 (defun ls-read-from-string (string)
543 (ls-read (make-string-stream string)))
548 ;;; Translate the Lisp code to Javascript. It will compile the special
549 ;;; forms. Some primitive functions are compiled as special forms
550 ;;; too. The respective real functions are defined in the target (see
551 ;;; the beginning of this file) as well as some primitive functions.
553 (defvar *compilation-unit-checks* '())
558 (defun make-binding (name type js declared)
559 (list name type js declared))
561 (defun binding-name (b) (first b))
562 (defun binding-type (b) (second b))
563 (defun binding-translation (b) (third b))
564 (defun binding-declared (b)
566 (defun mark-binding-as-declared (b)
567 (setcar (cdddr b) t))
569 (defvar *variable-counter* 0)
570 (defun gvarname (symbol)
571 (concat "v" (integer-to-string (incf *variable-counter*))))
573 (defun lookup-variable (symbol env)
574 (or (assoc symbol env)
576 (let ((name (symbol-name symbol))
577 (binding (make-binding symbol 'variable (gvarname symbol) nil)))
580 (unless (binding-declared (assoc symbol *env*))
581 (error (concat "Undefined variable `" name "'"))))
582 *compilation-unit-checks*)
585 (defun lookup-variable-translation (symbol env)
586 (binding-translation (lookup-variable symbol env)))
588 (defun extend-local-env (args env)
589 (append (mapcar (lambda (symbol)
590 (make-binding symbol 'variable (gvarname symbol) t))
594 (defvar *function-counter* 0)
595 (defun lookup-function (symbol env)
596 (or (assoc symbol env)
597 (assoc symbol *fenv*)
598 (let ((name (symbol-name symbol))
602 (concat "f" (integer-to-string (incf *function-counter*)))
604 (push binding *fenv*)
606 (unless (binding-declared (assoc symbol *fenv*))
607 (error (concat "Undefined function `" name "'"))))
608 *compilation-unit-checks*)
611 (defun lookup-function-translation (symbol env)
612 (binding-translation (lookup-function symbol env)))
614 (defvar *toplevel-compilations* nil)
616 (defun %compile-defvar (name)
617 (let ((b (lookup-variable name *env*)))
618 (mark-binding-as-declared b)
619 (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
621 (defun %compile-defun (name)
622 (let ((b (lookup-function name *env*)))
623 (mark-binding-as-declared b)
624 (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
626 (defun %compile-defmacro (name lambda)
627 (push (make-binding name 'macro lambda t) *fenv*))
629 (defvar *compilations* nil)
631 (defun ls-compile-block (sexps env fenv)
633 (remove nil (mapcar (lambda (x)
634 (ls-compile x env fenv))
638 (defmacro define-compilation (name args &rest body)
639 ;; Creates a new primitive `name' with parameters args and
640 ;; @body. The body can access to the local environment through the
642 `(push (list ',name (lambda (env fenv ,@args) ,@body))
645 (define-compilation if (condition true false)
647 (ls-compile condition env fenv) " !== " (ls-compile nil nil nil)
649 (ls-compile true env fenv)
651 (ls-compile false env fenv)
654 ;;; Return the required args of a lambda list
655 (defun lambda-list-required-argument (lambda-list)
656 (if (or (null lambda-list) (eq (car lambda-list) '&rest))
658 (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
660 (defun lambda-list-rest-argument (lambda-list)
661 (second (member '&rest lambda-list)))
663 (define-compilation lambda (lambda-list &rest body)
664 (let ((required-arguments (lambda-list-required-argument lambda-list))
665 (rest-argument (lambda-list-rest-argument lambda-list)))
666 (let ((new-env (extend-local-env
667 (append (and rest-argument (list rest-argument))
670 (concat "(function ("
671 (join (mapcar (lambda (x)
672 (lookup-variable-translation x new-env))
678 (let ((js!rest (lookup-variable-translation rest-argument new-env)))
679 (concat "var " js!rest "= " (ls-compile nil env fenv) ";" *newline*
680 "for (var i = arguments.length-1; i>="
681 (integer-to-string (length required-arguments))
684 "{car: arguments[i], cdr: " js!rest "};"
687 (concat (ls-compile-block (butlast body) new-env fenv)
688 "return " (ls-compile (car (last body)) new-env fenv) ";")
692 (define-compilation fsetq (var val)
693 (concat (lookup-function-translation var fenv)
695 (ls-compile val env fenv)))
697 (define-compilation setq (var val)
698 (concat (lookup-variable-translation var env)
700 (ls-compile val env fenv)))
703 (defun escape-string (string)
706 (size (length string)))
707 (while (< index size)
708 (let ((ch (char string index)))
709 (when (or (char= ch #\") (char= ch #\\))
710 (setq output (concat output "\\")))
711 (when (or (char= ch #\newline))
712 (setq output (concat output "\\"))
714 (setq output (concat output (string ch))))
718 (defun literal->js (sexp)
720 ((integerp sexp) (integer-to-string sexp))
721 ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
722 ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
723 ((consp sexp) (concat "{car: "
724 (literal->js (car sexp))
726 (literal->js (cdr sexp)) "}"))))
728 (defvar *literal-counter* 0)
729 (defun literal (form)
730 (let ((var (concat "l" (integer-to-string (incf *literal-counter*)))))
731 (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
734 (define-compilation quote (sexp)
737 (define-compilation debug (form)
738 (concat "console.log(" (ls-compile form env fenv) ")"))
740 (define-compilation while (pred &rest body)
741 (concat "(function(){ while("
742 (ls-compile pred env fenv) " !== " (ls-compile nil nil nil)
744 (ls-compile-block body env fenv)
747 (define-compilation function (x)
749 ((and (listp x) (eq (car x) 'lambda))
750 (ls-compile x env fenv))
752 (lookup-function-translation x fenv))))
754 (define-compilation eval-when-compile (&rest body)
755 (eval (cons 'progn body))
758 (defmacro define-transformation (name args form)
759 `(define-compilation ,name ,args
760 (ls-compile ,form env fenv)))
762 (define-transformation progn (&rest body)
763 `((lambda () ,@body)))
765 (define-transformation let (bindings &rest body)
766 (let ((bindings (mapcar #'ensure-list bindings)))
767 `((lambda ,(mapcar #'car bindings) ,@body)
768 ,@(mapcar #'cadr bindings))))
770 ;;; A little backquote implementation without optimizations of any
771 ;;; kind for lispstrack.
772 (defun backquote-expand-1 (form)
778 ((eq (car form) 'unquote)
780 ((eq (car form) 'backquote)
781 (backquote-expand-1 (backquote-expand-1 (cadr form))))
786 ((and (listp s) (eq (car s) 'unquote))
787 (list 'list (cadr s)))
788 ((and (listp s) (eq (car s) 'unquote-splicing))
791 (list 'list (backquote-expand-1 s)))))
794 (defun backquote-expand (form)
795 (if (and (listp form) (eq (car form) 'backquote))
796 (backquote-expand-1 (cadr form))
799 (defmacro backquote (form)
800 (backquote-expand-1 form))
802 (define-transformation backquote (form)
803 (backquote-expand-1 form))
807 (defun compile-bool (x)
808 (concat "(" x "?" (ls-compile t nil nil) ": " (ls-compile nil nil nil) ")"))
810 (define-compilation + (x y)
811 (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
813 (define-compilation - (x y)
814 (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
816 (define-compilation * (x y)
817 (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
819 (define-compilation / (x y)
820 (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
822 (define-compilation < (x y)
823 (compile-bool (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))")))
825 (define-compilation = (x y)
826 (compile-bool (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))")))
828 (define-compilation numberp (x)
829 (compile-bool (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")")))
832 (define-compilation mod (x y)
833 (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
835 (define-compilation floor (x)
836 (concat "(Math.floor(" (ls-compile x env fenv) "))"))
838 (define-compilation null (x)
839 (compile-bool (concat "(" (ls-compile x env fenv) "===" (ls-compile nil env fenv) ")")))
841 (define-compilation cons (x y)
842 (concat "({car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "})"))
844 (define-compilation consp (x)
846 (concat "(function(){ var tmp = "
847 (ls-compile x env fenv)
848 "; return (typeof tmp == 'object' && 'car' in tmp);})()")))
850 (define-compilation car (x)
851 (concat "(function () { var tmp = " (ls-compile x env fenv)
852 "; return tmp === " (ls-compile nil nil nil) "? "
853 (ls-compile nil nil nil)
856 (define-compilation cdr (x)
857 (concat "(function () { var tmp = " (ls-compile x env fenv)
858 "; return tmp === " (ls-compile nil nil nil) "? "
859 (ls-compile nil nil nil)
862 (define-compilation setcar (x new)
863 (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
865 (define-compilation setcdr (x new)
866 (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
868 (define-compilation symbolp (x)
870 (concat "(function(){ var tmp = "
871 (ls-compile x env fenv)
872 "; return (typeof tmp == 'object' && 'name' in tmp); })()")))
874 (define-compilation make-symbol (name)
875 (concat "{name: " (ls-compile name env fenv) "}"))
877 (define-compilation symbol-name (x)
878 (concat "(" (ls-compile x env fenv) ").name"))
880 (define-compilation eq (x y)
882 (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")")))
884 (define-compilation equal (x y)
886 (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")")))
888 (define-compilation string (x)
889 (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
891 (define-compilation stringp (x)
893 (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")")))
895 (define-compilation string-upcase (x)
896 (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
898 (define-compilation string-length (x)
899 (concat "(" (ls-compile x env fenv) ").length"))
901 (define-compilation char (string index)
903 (ls-compile string env fenv)
905 (ls-compile index env fenv)
908 (define-compilation concat-two (string1 string2)
910 (ls-compile string1 env fenv)
912 (ls-compile string2 env fenv)
915 (define-compilation funcall (func &rest args)
917 (ls-compile func env fenv)
919 (join (mapcar (lambda (x)
920 (ls-compile x env fenv))
925 (define-compilation apply (func &rest args)
927 (concat "(" (ls-compile func env fenv) ")()")
928 (let ((args (butlast args))
929 (last (car (last args))))
930 (concat "(function(){" *newline*
931 "var f = " (ls-compile func env fenv) ";" *newline*
932 "var args = [" (join (mapcar (lambda (x)
933 (ls-compile x env fenv))
937 "var tail = (" (ls-compile last env fenv) ");" *newline*
938 "while (tail != " (ls-compile nil env fenv) "){" *newline*
939 " args.push(tail.car);" *newline*
940 " tail = tail.cdr;" *newline*
942 "return f.apply(this, args);" *newline*
945 (define-compilation js-eval (string)
946 (concat "eval.apply(window, [" (ls-compile string env fenv) "])"))
949 (define-compilation error (string)
950 (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
952 (define-compilation new ()
955 (define-compilation get (object key)
956 (concat "(function(){ var tmp = "
957 "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"
959 "return tmp == undefined? " (ls-compile nil nil nil) ": tmp ;"
962 (define-compilation set (object key value)
964 (ls-compile object env fenv)
966 (ls-compile key env fenv) "]"
967 " = " (ls-compile value env fenv) ")"))
969 (define-compilation in (key object)
971 (concat "(" (ls-compile key env fenv) " in " (ls-compile object env fenv) ")")))
973 (define-compilation functionp (x)
975 (concat "(typeof " (ls-compile x env fenv) " == 'function')")))
979 (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
981 (defun ls-macroexpand-1 (form env fenv)
982 (if (macrop (car form))
983 (let ((binding (lookup-function (car form) *env*)))
984 (if (eq (binding-type binding) 'macro)
985 (apply (eval (binding-translation binding)) (cdr form))
989 (defun compile-funcall (function args env fenv)
992 (concat (lookup-function-translation function fenv)
994 (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
997 ((and (listp function) (eq (car function) 'lambda))
998 (concat "(" (ls-compile function env fenv) ")("
999 (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
1003 (error (concat "Invalid function designator " (symbol-name function))))))
1005 (defun ls-compile (sexp env fenv)
1007 ((symbolp sexp) (lookup-variable-translation sexp env))
1008 ((integerp sexp) (integer-to-string sexp))
1009 ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
1011 (if (assoc (car sexp) *compilations*)
1012 (let ((comp (second (assoc (car sexp) *compilations*))))
1013 (apply comp env fenv (cdr sexp)))
1014 (if (macrop (car sexp))
1015 (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
1016 (compile-funcall (car sexp) (cdr sexp) env fenv))))))
1018 (defun ls-compile-toplevel (sexp)
1019 (setq *toplevel-compilations* nil)
1020 (let ((code (ls-compile sexp nil nil)))
1022 (concat #+common-lisp (concat "/* " (princ-to-string sexp) " */")
1023 (join (mapcar (lambda (x) (concat x ";" *newline*))
1024 *toplevel-compilations*)
1027 (setq *toplevel-compilations* nil))))
1030 ;;; Once we have the compiler, we define the runtime environment and
1031 ;;; interactive development (eval), which works calling the compiler
1032 ;;; and evaluating the Javascript result globally.
1034 (defun print-to-string (form)
1036 ((symbolp form) (symbol-name form))
1037 ((integerp form) (integer-to-string form))
1038 ((stringp form) (concat "\"" (escape-string form) "\""))
1039 ((functionp form) (concat "#<FUNCTION>"))
1042 (join (mapcar #'print-to-string form)
1048 (defmacro with-compilation-unit (&rest body)
1051 (setq *compilation-unit-checks* nil)
1052 (setq *env* (remove-if-not #'binding-declared *env*))
1053 (setq *fenv* (remove-if-not #'binding-declared *fenv*))
1055 (dolist (check *compilation-unit-checks*)
1060 (with-compilation-unit
1061 (ls-compile-toplevel x nil nil))))
1064 ;; Set the initial global environment to be equal to the host global
1065 ;; environment at this point of the compilation.
1067 (let ((c1 (ls-compile `(setq *fenv* ',*fenv*) nil nil))
1068 (c2 (ls-compile `(setq *env* ',*env*) nil nil))
1069 (c3 (ls-compile `(setq *variable-counter* ',*variable-counter*) nil nil))
1070 (c4 (ls-compile `(setq *function-counter* ',*function-counter*) nil nil))
1071 (c5 (ls-compile `(setq *literal-counter* ',*literal-counter*) nil nil)))
1072 (setq *toplevel-compilations*
1073 (append *toplevel-compilations* (list c1 c2 c3 c4 c5)))))
1076 (concat "var lisp = {};"
1077 "lisp.read = " (lookup-function-translation 'ls-read-from-string nil) ";" *newline*
1078 "lisp.print = " (lookup-function-translation 'print-to-string nil) ";" *newline*
1079 "lisp.eval = " (lookup-function-translation 'eval nil) ";" *newline*
1080 "lisp.compile = " (lookup-function-translation 'ls-compile-toplevel nil) ";" *newline*
1081 "lisp.evalString = function(str){" *newline*
1082 " return lisp.eval(lisp.read(str));" *newline*
1084 "lisp.compileString = function(str){" *newline*
1085 " return lisp.compile(lisp.read(str));" *newline*
1089 ;;; Finally, we provide a couple of functions to easily bootstrap
1090 ;;; this. It just calls the compiler with this file as input.
1094 (defun read-whole-file (filename)
1095 (with-open-file (in filename)
1096 (let ((seq (make-array (file-length in) :element-type 'character)))
1097 (read-sequence seq in)
1100 (defun ls-compile-file (filename output)
1101 (setq *env* nil *fenv* nil)
1102 (setq *compilation-unit-checks* nil)
1103 (with-open-file (out output :direction :output :if-exists :supersede)
1104 (let* ((source (read-whole-file filename))
1105 (in (make-string-stream source)))
1107 for x = (ls-read in)
1109 for compilation = (ls-compile-toplevel x)
1110 when (plusp (length compilation))
1111 do (write-line (concat compilation "; ") out))
1112 (dolist (check *compilation-unit-checks*)
1114 (setq *compilation-unit-checks* nil))))
1117 (ls-compile-file "lispstrack.lisp" "lispstrack.js")))