4 (%compile-defmacro 'defmacro
5 (lambda (name args &rest body)
7 (%compile-defmacro ',name (lambda ,args ,@body))))))
9 (defmacro defvar (name value)
12 (%compile-defvar ',name))
15 (defmacro defun (name args &rest body)
18 (%compile-defun ',name))
19 (fsetq ,name (lambda ,args ,@body))))
21 (defvar *package* (new))
24 (let ((s (get *package* name)))
25 (if s s (set *package* name (make-symbol name)))))
27 (defun find-symbol (name)
33 (defmacro when (condition &rest body)
34 `(if ,condition (progn ,@body) nil))
36 (defmacro unless (condition &rest body)
37 `(if ,condition nil (progn ,@body)))
39 (defun = (x y) (= x y))
40 (defun + (x y) (+ x y))
41 (defun - (x y) (- x y))
42 (defun * (x y) (* x y))
43 (defun / (x y) (/ x y))
44 (defun 1+ (x) (+ x 1))
45 (defun 1- (x) (- x 1))
46 (defun zerop (x) (= x 0))
47 (defun not (x) (if x nil t))
49 (defun truncate (x y) (floor (/ x y)))
51 (defun cons (x y ) (cons x y))
52 (defun car (x) (car x))
53 (defun caar (x) (car (car x)))
54 (defun cadr (x) (car (cdr x)))
55 (defun caddr (x) (car (cdr x)))
56 (defun cadddr (x) (car (cdr x)))
57 (defun cdr (x) (cdr x))
58 (defun cdar (x) (cdr (car x)))
59 (defun cddr (x) (cdr (cdr x)))
60 (defun cdddr (x) (cdr (cdr x)))
62 (defun first (x) (car x))
63 (defun second (x) (cadr x))
64 (defun third (x) (caddr x))
65 (defun fourth (x) (cadddr x))
67 (defun list (&rest args)
73 (defun ensure-list (x)
78 (defun append (list1 list2)
82 (append (cdr list1) list2))))
84 (defun reverse-aux (list acc)
87 (reverse-aux (cdr list) (cons (car list) acc))))
90 (reverse-aux list '()))
98 (defun list-length (list)
100 (while (not (null list))
102 (setq list (cdr list)))
110 (defun mapcar (func list)
113 (cons (funcall func (car list))
114 (mapcar func (cdr list)))))
116 (defmacro push (x place)
117 `(setq ,place (cons ,x ,place)))
119 (defmacro cond (&rest clausules)
122 (if (eq (caar clausules) t)
123 `(progn ,@(cdar clausules))
124 `(if ,(caar clausules)
125 (progn ,@(cdar clausules))
126 (cond ,@(cdr clausules))))))
129 (defmacro case (form &rest clausules)
130 (let ((!form (make-symbol "FORM")))
131 `(let ((,!form ,form))
133 ,@(mapcar (lambda (clausule)
134 (if (eq (car clausule) t)
136 `((eql ,!form ,(car clausule))
140 (defmacro ecase (form &rest clausules)
145 (error "ECASE expression failed."))))))
147 (defun !reduce (func list initial)
152 (funcall func initial (car list)))))
155 (defun code-char (x) x)
156 (defun char-code (x) x)
157 (defvar *newline* (string (code-char 10)))
159 (defun concat (&rest strs)
160 (!reduce (lambda (s1 s2) (concat-two s1 s2))
164 ;;; Concatenate a list of strings, with a separator
165 (defun join (list separator)
174 (join (cdr list) separator)))))
176 (defun join-trailing (list separator)
179 (concat (car list) separator (join-trailing (cdr list) separator))))
181 (defun integer-to-string (x)
185 (while (not (zerop x 0))
186 (push (mod x 10) digits)
187 (setq x (truncate x 10)))
188 (join (mapcar (lambda (d) (string (char "0123456789" d)))
192 (defmacro and (&rest forms)
204 (defmacro or (&rest forms)
213 (or ,@(cdr forms))))))
216 (defmacro prog1 (form &rest body)
217 (let ((value (make-symbol "VALUE")))
218 `(let ((,value ,form))
223 (defun char= (x y) (= x y))
225 (defun <= (x y) (or (< x y) (= x y)))
226 (defun >= (x y) (not (< x y)))
229 (or (consp x) (null x)))
232 (and (numberp x) (= (floor x) x)))
242 (cons (car x) (butlast (cdr x)))))
244 (defun member (x list)
251 (member x (cdr list)))))
253 (defun remove (x list)
258 (remove x (cdr list)))
260 (cons (car list) (remove x (cdr list))))))
262 (defun digit-char-p (x)
263 (if (and (<= #\0 x) (<= x #\9))
267 (defun parse-integer (string)
270 (size (length string)))
271 (while (< index size)
272 (setq value (+ (* value 10) (digit-char-p (char string index))))
276 (defun every (function seq)
281 (while (and ret (< index size))
282 (unless (funcall function (char seq index))
290 (defun assoc (x alist)
294 ((eql x (caar alist))
297 (assoc x (cdr alist)))))
299 (defun string= (s1 s2)
304 ;;; It is a basic Lisp reader. It does not use advanced stuff
305 ;;; intentionally, because we want to use it to bootstrap a simple
306 ;;; Lisp. The main entry point is the function `ls-read', which
307 ;;; accepts a strings as argument and return the Lisp expression.
308 (defun make-string-stream (string)
311 (defun %peek-char (stream)
312 (and (< (cdr stream) (length (car stream)))
313 (char (car stream) (cdr stream))))
315 (defun %read-char (stream)
316 (and (< (cdr stream) (length (car stream)))
317 (prog1 (char (car stream) (cdr stream))
318 (setcdr stream (1+ (cdr stream))))))
320 (defun whitespacep (ch)
321 (or (char= ch #\space) (char= ch #\newline) (char= ch #\tab)))
323 (defun skip-whitespaces (stream)
325 (setq ch (%peek-char stream))
326 (while (and ch (whitespacep ch))
328 (setq ch (%peek-char stream)))))
330 (defun terminalp (ch)
331 (or (null ch) (whitespacep ch) (char= #\) ch) (char= #\( ch)))
333 (defun read-until (stream func)
336 (setq ch (%peek-char stream))
337 (while (not (funcall func ch))
338 (setq string (concat string (string ch)))
340 (setq ch (%peek-char stream)))
343 (defun skip-whitespaces-and-comments (stream)
345 (skip-whitespaces stream)
346 (setq ch (%peek-char stream))
347 (while (and ch (char= ch #\;))
348 (read-until stream (lambda (x) (char= x #\newline)))
349 (skip-whitespaces stream)
350 (setq ch (%peek-char stream)))))
352 (defun %read-list (stream)
353 (skip-whitespaces-and-comments stream)
354 (let ((ch (%peek-char stream)))
361 (skip-whitespaces-and-comments stream)
362 (prog1 (ls-read stream)
363 (unless (char= (%read-char stream) #\))
364 (error "')' was expected."))))
366 (cons (ls-read stream) (%read-list stream))))))
368 (defun read-string (stream)
371 (setq ch (%read-char stream))
372 (while (not (char= ch #\"))
374 (setq ch (%read-char stream)))
375 (setq string (concat string (string ch)))
376 (setq ch (%read-char stream)))
379 (defvar *eof* (make-symbol "EOF"))
380 (defun ls-read (stream)
381 (skip-whitespaces-and-comments stream)
382 (let ((ch (%peek-char stream)))
391 (list 'quote (ls-read stream)))
394 (list 'backquote (ls-read stream)))
397 (read-string stream))
400 (if (eql (%peek-char stream) #\@)
401 (progn (%read-char stream) (list 'unquote-splicing (ls-read stream)))
402 (list 'unquote (ls-read stream))))
405 (ecase (%read-char stream)
407 (list 'function (ls-read stream)))
410 (concat (string (%read-char stream))
411 (read-until stream #'terminalp))))
413 ((string= cname "space") (char-code #\space))
414 ((string= cname "newline") (char-code #\newline))
415 (t (char-code (char cname 0))))))
417 (let ((feature (read-until stream #'terminalp)))
419 ((string= feature "common-lisp")
420 (ls-read stream) ;ignore
422 ((string= feature "lispstrack")
425 (error "Unknown reader form.")))))))
427 (let ((string (read-until stream #'terminalp)))
428 (if (every #'digit-char-p string)
429 (parse-integer string)
430 (intern (string-upcase string))))))))
432 (defun ls-read-from-string (string)
433 (ls-read (make-string-stream string)))
438 (defvar *compilation-unit-checks* '())
443 (defun make-binding (name type js declared)
444 (list name type js declared))
446 (defun binding-name (b) (first b))
447 (defun binding-type (b) (second b))
448 (defun binding-translation (b) (third b))
449 (defun binding-declared (b)
451 (defun mark-binding-as-declared (b)
452 (setcar (cdddr b) t))
455 (defun gvarname (symbol)
456 (concat "v" (integer-to-string (incf counter))))
458 (defun lookup-variable (symbol env)
459 (or (assoc symbol env)
461 (let ((name (symbol-name symbol))
462 (binding (make-binding symbol 'variable (gvarname symbol) nil)))
465 (unless (binding-declared (assoc symbol *env*))
466 (error (concat "Undefined variable `" name "'"))))
467 *compilation-unit-checks*)
470 (defun lookup-variable-translation (symbol env)
471 (binding-translation (lookup-variable symbol env)))
473 (defun extend-local-env (args env)
474 (append (mapcar (lambda (symbol)
475 (make-binding symbol 'variable (gvarname symbol) t))
480 (defun lookup-function (symbol env)
481 (or (assoc symbol env)
482 (assoc symbol *fenv*)
483 (let ((name (symbol-name symbol))
487 (concat "f" (integer-to-string (incf counter)))
489 (push binding *fenv*)
491 (unless (binding-declared (assoc symbol *fenv*))
492 (error (concat "Undefined function `" name "'"))))
493 *compilation-unit-checks*)
496 (defun lookup-function-translation (symbol env)
497 (binding-translation (lookup-function symbol env))))
500 (defvar *toplevel-compilations* nil)
502 (defun %compile-defvar (name)
503 (let ((b (lookup-variable name *env*)))
504 (mark-binding-as-declared b)
505 (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
507 (defun %compile-defun (name)
508 (let ((b (lookup-function name *env*)))
509 (mark-binding-as-declared b)
510 (push (concat "var " (binding-translation b)) *toplevel-compilations*)))
512 (defun %compile-defmacro (name lambda)
513 (push (make-binding name 'macro lambda t) *fenv*))
516 (defvar *compilations* nil)
518 (defun ls-compile-block (sexps env fenv)
520 (remove nil (mapcar (lambda (x)
521 (ls-compile x env fenv))
525 (defmacro define-compilation (name args &rest body)
526 ;; Creates a new primitive `name' with parameters args and
527 ;; @body. The body can access to the local environment through the
529 `(push (list ',name (lambda (env fenv ,@args) ,@body))
532 (define-compilation if (condition true false)
534 (ls-compile condition env fenv)
536 (ls-compile true env fenv)
538 (ls-compile false env fenv)
541 ;;; Return the required args of a lambda list
542 (defun lambda-list-required-argument (lambda-list)
543 (if (or (null lambda-list) (eq (car lambda-list) '&rest))
545 (cons (car lambda-list) (lambda-list-required-argument (cdr lambda-list)))))
547 (defun lambda-list-rest-argument (lambda-list)
548 (second (member '&rest lambda-list)))
550 (define-compilation lambda (lambda-list &rest body)
551 (let ((required-arguments (lambda-list-required-argument lambda-list))
552 (rest-argument (lambda-list-rest-argument lambda-list)))
553 (let ((new-env (extend-local-env
554 (append (and rest-argument (list rest-argument))
557 (concat "(function ("
558 (join (mapcar (lambda (x)
559 (lookup-variable-translation x new-env))
565 (let ((js!rest (lookup-variable-translation rest-argument new-env)))
566 (concat "var " js!rest "= false;" *newline*
567 "for (var i = arguments.length-1; i>="
568 (integer-to-string (length required-arguments))
571 "{car: arguments[i], cdr: " js!rest "};"
574 (concat (ls-compile-block (butlast body) new-env fenv)
575 "return " (ls-compile (car (last body)) new-env fenv) ";")
579 (define-compilation fsetq (var val)
580 (concat (lookup-function-translation var fenv)
582 (ls-compile val env fenv)))
584 (define-compilation setq (var val)
585 (concat (lookup-variable-translation var env)
587 (ls-compile val env fenv)))
591 (defun escape-string (string)
594 (size (length string)))
595 (while (< index size)
596 (let ((ch (char string index)))
597 (when (or (char= ch #\") (char= ch #\\))
598 (setq output (concat output "\\")))
599 (when (or (char= ch #\newline))
600 (setq output (concat output "\\"))
602 (setq output (concat output (string ch))))
606 (defun literal->js (sexp)
608 ((null sexp) "false")
609 ((integerp sexp) (integer-to-string sexp))
610 ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
611 ((symbolp sexp) (ls-compile `(intern ,(escape-string (symbol-name sexp))) *env* *fenv*))
612 ((consp sexp) (concat "{car: "
613 (literal->js (car sexp))
615 (literal->js (cdr sexp)) "}"))))
618 (defun literal (form)
623 (let ((var (concat "l" (integer-to-string (incf counter)))))
624 (push (concat "var " var " = " (literal->js form)) *toplevel-compilations*)
627 (define-compilation quote (sexp)
630 (define-compilation debug (form)
631 (concat "console.log(" (ls-compile form env fenv) ")"))
633 (define-compilation while (pred &rest body)
634 (concat "(function(){ while("
635 (ls-compile pred env fenv)
637 (ls-compile-block body env fenv)
640 (define-compilation function (x)
642 ((and (listp x) (eq (car x) 'lambda))
643 (ls-compile x env fenv))
645 (lookup-function-translation x fenv))))
648 (defmacro eval-when-compile (&body body)
649 `(eval-when (:compile-toplevel :load-toplevel :execute)
652 (define-compilation eval-when-compile (&rest body)
653 (eval (cons 'progn body))
656 (defmacro define-transformation (name args form)
657 `(define-compilation ,name ,args
658 (ls-compile ,form env fenv)))
660 (define-transformation progn (&rest body)
661 `((lambda () ,@body)))
663 (define-transformation let (bindings &rest body)
664 (let ((bindings (mapcar #'ensure-list bindings)))
665 `((lambda ,(mapcar 'car bindings) ,@body)
666 ,@(mapcar 'cadr bindings))))
668 ;;; A little backquote implementation without optimizations of any
669 ;;; kind for lispstrack.
670 (defun backquote-expand-1 (form)
676 ((eq (car form) 'unquote)
678 ((eq (car form) 'backquote)
679 (backquote-expand-1 (backquote-expand-1 (cadr form))))
684 ((and (listp s) (eq (car s) 'unquote))
685 (list 'list (cadr s)))
686 ((and (listp s) (eq (car s) 'unquote-splicing))
689 (list 'list (backquote-expand-1 s)))))
692 (defun backquote-expand (form)
693 (if (and (listp form) (eq (car form) 'backquote))
694 (backquote-expand-1 (cadr form))
697 (defmacro backquote (form)
698 (backquote-expand-1 form))
700 (define-transformation backquote (form)
701 (backquote-expand-1 form))
705 (define-compilation + (x y)
706 (concat "((" (ls-compile x env fenv) ") + (" (ls-compile y env fenv) "))"))
708 (define-compilation - (x y)
709 (concat "((" (ls-compile x env fenv) ") - (" (ls-compile y env fenv) "))"))
711 (define-compilation * (x y)
712 (concat "((" (ls-compile x env fenv) ") * (" (ls-compile y env fenv) "))"))
714 (define-compilation / (x y)
715 (concat "((" (ls-compile x env fenv) ") / (" (ls-compile y env fenv) "))"))
717 (define-compilation < (x y)
718 (concat "((" (ls-compile x env fenv) ") < (" (ls-compile y env fenv) "))"))
720 (define-compilation = (x y)
721 (concat "((" (ls-compile x env fenv) ") == (" (ls-compile y env fenv) "))"))
723 (define-compilation numberp (x)
724 (concat "(typeof (" (ls-compile x env fenv) ") == \"number\")"))
727 (define-compilation mod (x y)
728 (concat "((" (ls-compile x env fenv) ") % (" (ls-compile y env fenv) "))"))
730 (define-compilation floor (x)
731 (concat "(Math.floor(" (ls-compile x env fenv) "))"))
733 (define-compilation null (x)
734 (concat "(" (ls-compile x env fenv) "== false)"))
736 (define-compilation cons (x y)
737 (concat "{car: " (ls-compile x env fenv) ", cdr: " (ls-compile y env fenv) "}"))
739 (define-compilation consp (x)
740 (concat "(function(){ var tmp = "
741 (ls-compile x env fenv)
742 "; return (typeof tmp == 'object' && 'car' in tmp);})()"))
744 (define-compilation car (x)
745 (concat "(" (ls-compile x env fenv) ").car"))
747 (define-compilation cdr (x)
748 (concat "(" (ls-compile x env fenv) ").cdr"))
750 (define-compilation setcar (x new)
751 (concat "((" (ls-compile x env fenv) ").car = " (ls-compile new env fenv) ")"))
753 (define-compilation setcdr (x new)
754 (concat "((" (ls-compile x env fenv) ").cdr = " (ls-compile new env fenv) ")"))
756 (define-compilation symbolp (x)
757 (concat "(function(){ var tmp = "
758 (ls-compile x env fenv)
759 "; return (typeof tmp == 'object' && 'name' in tmp); })()"))
761 (define-compilation make-symbol (name)
762 (concat "{name: " (ls-compile name env fenv) "}"))
764 (define-compilation symbol-name (x)
765 (concat "(" (ls-compile x env fenv) ").name"))
767 (define-compilation eq (x y)
768 (concat "(" (ls-compile x env fenv) " === " (ls-compile y env fenv) ")"))
770 (define-compilation equal (x y)
771 (concat "(" (ls-compile x env fenv) " == " (ls-compile y env fenv) ")"))
773 (define-compilation string (x)
774 (concat "String.fromCharCode(" (ls-compile x env fenv) ")"))
776 (define-compilation stringp (x)
777 (concat "(typeof(" (ls-compile x env fenv) ") == \"string\")"))
779 (define-compilation string-upcase (x)
780 (concat "(" (ls-compile x env fenv) ").toUpperCase()"))
782 (define-compilation string-length (x)
783 (concat "(" (ls-compile x env fenv) ").length"))
785 (define-compilation char (string index)
787 (ls-compile string env fenv)
789 (ls-compile index env fenv)
792 (define-compilation concat-two (string1 string2)
794 (ls-compile string1 env fenv)
796 (ls-compile string2 env fenv)
799 (define-compilation funcall (func &rest args)
801 (ls-compile func env fenv)
803 (join (mapcar (lambda (x)
804 (ls-compile x env fenv))
809 (define-compilation apply (func &rest args)
811 (concat "(" (ls-compile func env fenv) ")()")
812 (let ((args (butlast args))
813 (last (car (last args))))
814 (concat "function(){" *newline*
815 "var f = " (ls-compile func env fenv) ";" *newline*
816 "var args = [" (join (mapcar (lambda (x)
817 (ls-compile x env fenv))
821 "var tail = (" (ls-compile last env fenv) ");" *newline*
822 "while (tail != false){" *newline*
823 " args.push(tail[0]);" *newline*
824 " args = args.slice(1);" *newline*
826 "return f.apply(this, args);" *newline*
829 (define-compilation js-eval (string)
830 (concat "eval(" (ls-compile string env fenv) ")"))
833 (define-compilation error (string)
834 (concat "(function (){ throw " (ls-compile string env fenv) ";" "return 0;})()"))
836 (define-compilation new ()
839 (define-compilation get (object key)
840 (concat "(" (ls-compile object env fenv) ")[" (ls-compile key env fenv) "]"))
842 (define-compilation set (object key value)
844 (ls-compile object env fenv)
846 (ls-compile key env fenv) "]"
847 " = " (ls-compile value env fenv) ")"))
850 (and (symbolp x) (eq (binding-type (lookup-function x *fenv*)) 'macro)))
852 (defun ls-macroexpand-1 (form env fenv)
853 (when (macrop (car form))
854 (let ((binding (lookup-function (car form) *env*)))
855 (if (eq (binding-type binding) 'macro)
856 (apply (eval (binding-translation binding)) (cdr form))
859 (defun compile-funcall (function args env fenv)
862 (concat (lookup-function-translation function fenv)
864 (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
867 ((and (listp function) (eq (car function) 'lambda))
868 (concat "(" (ls-compile function env fenv) ")("
869 (join (mapcar (lambda (x) (ls-compile x env fenv)) args)
873 (error (concat "Invalid function designator " (symbol-name function))))))
875 (defun ls-compile (sexp env fenv)
877 ((symbolp sexp) (lookup-variable-translation sexp env))
878 ((integerp sexp) (integer-to-string sexp))
879 ((stringp sexp) (concat "\"" (escape-string sexp) "\""))
881 (if (assoc (car sexp) *compilations*)
882 (let ((comp (second (assoc (car sexp) *compilations*))))
883 (apply comp env fenv (cdr sexp)))
884 (if (macrop (car sexp))
885 (ls-compile (ls-macroexpand-1 sexp env fenv) env fenv)
886 (compile-funcall (car sexp) (cdr sexp) env fenv))))))
888 (defun ls-compile-toplevel (sexp)
889 (setq *toplevel-compilations* nil)
890 (let ((code (ls-compile sexp nil nil)))
892 (join (mapcar (lambda (x) (concat x ";" *newline*))
893 *toplevel-compilations*)
896 (setq *toplevel-compilations* nil))))
900 (defun read-whole-file (filename)
901 (with-open-file (in filename)
902 (let ((seq (make-array (file-length in) :element-type 'character)))
903 (read-sequence seq in)
906 (defun ls-compile-file (filename output)
907 (setq *env* nil *fenv* nil)
908 (setq *compilation-unit-checks* nil)
909 (with-open-file (out output :direction :output :if-exists :supersede)
910 (let* ((source (read-whole-file filename))
911 (in (make-string-stream source)))
915 for compilation = (ls-compile-toplevel x)
916 when (plusp (length compilation))
917 do (write-line (concat compilation "; ") out))
918 (dolist (check *compilation-unit-checks*)
920 (setq *compilation-unit-checks* nil))))
923 (ls-compile-file "lispstrack.lisp" "lispstrack.js")))
928 (js-eval (ls-compile x nil nil)))
931 (debug (ls-compile 'x nil nil))