1 ;;; boot.lisp --- First forms to be cross compiled
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 (%compile-defmacro 'defmacro
28 (lambda (name args &rest body)
30 (%compile-defmacro ',name
32 (lambda ,(mapcar #'(lambda (x)
39 (defmacro declaim (&rest decls)
41 ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
43 (defmacro defconstant (name value &optional docstring)
45 (declaim (special ,name))
46 (declaim (constant ,name))
48 ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
52 (defconstant nil 'nil)
55 (defmacro lambda (args &body body)
56 `(function (lambda ,args ,@body)))
58 (defmacro when (condition &body body)
59 `(if ,condition (progn ,@body) nil))
61 (defmacro unless (condition &body body)
62 `(if ,condition nil (progn ,@body)))
64 (defmacro defvar (name value &optional docstring)
66 (declaim (special ,name))
67 (unless (boundp ',name) (setq ,name ,value))
68 ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
71 (defmacro defparameter (name value &optional docstring)
74 ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
77 (defmacro named-lambda (name args &rest body)
78 (let ((x (gensym "FN")))
79 `(let ((,x (lambda ,args ,@body)))
80 (oset ,x "fname" ,name)
83 (defmacro defun (name args &rest body)
86 (named-lambda ,(symbol-name name) ,args
87 ,@(if (and (stringp (car body)) (not (null (cdr body))))
88 `(,(car body) (block ,name ,@(cdr body)))
89 `((block ,name ,@body)))))
100 (error "type-error"))))
102 (defmacro return (&optional value)
103 `(return-from nil ,value))
105 (defmacro while (condition &body body)
106 `(block nil (%while ,condition ,@body)))
108 (defvar *gensym-counter* 0)
109 (defun gensym (&optional (prefix "G"))
110 (setq *gensym-counter* (+ *gensym-counter* 1))
111 (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
117 (defun = (x y) (= x y))
118 (defun * (x y) (* x y))
119 (defun / (x y) (/ x y))
120 (defun 1+ (x) (+ x 1))
121 (defun 1- (x) (- x 1))
122 (defun zerop (x) (= x 0))
123 (defun truncate (x y) (floor (/ x y)))
125 (defun eql (x y) (eq x y))
127 (defun not (x) (if x nil t))
129 (defun cons (x y ) (cons x y))
130 (defun consp (x) (consp x))
133 "Return the CAR part of a cons, or NIL if X is null."
136 (defun cdr (x) (cdr x))
137 (defun caar (x) (car (car x)))
138 (defun cadr (x) (car (cdr x)))
139 (defun cdar (x) (cdr (car x)))
140 (defun cddr (x) (cdr (cdr x)))
141 (defun cadar (x) (car (cdr (car x))))
142 (defun caddr (x) (car (cdr (cdr x))))
143 (defun cdddr (x) (cdr (cdr (cdr x))))
144 (defun cadddr (x) (car (cdr (cdr (cdr x)))))
145 (defun first (x) (car x))
146 (defun second (x) (cadr x))
147 (defun third (x) (caddr x))
148 (defun fourth (x) (cadddr x))
149 (defun rest (x) (cdr x))
151 (defun list (&rest args) args)
157 (defmacro incf (x &optional (delta 1))
158 `(setq ,x (+ ,x ,delta)))
160 (defmacro decf (x &optional (delta 1))
161 `(setq ,x (- ,x ,delta)))
163 (defmacro push (x place)
164 (multiple-value-bind (dummies vals newval setter getter)
165 (get-setf-expansion place)
168 ,@(mapcar #'list dummies vals)
169 (,(car newval) (cons ,g ,getter))
173 (defmacro dolist (iter &body body)
174 (let ((var (first iter))
177 (let ((,g!list ,(second iter))
180 (setq ,var (car ,g!list))
182 (setq ,g!list (cdr ,g!list)))
185 (defmacro dotimes (iter &body body)
186 (let ((g!to (gensym))
189 (result (third iter)))
193 (%while (< ,var ,g!to)
198 (defmacro cond (&rest clausules)
201 (if (eq (caar clausules) t)
202 `(progn ,@(cdar clausules))
203 `(if ,(caar clausules)
204 (progn ,@(cdar clausules))
205 (cond ,@(cdr clausules))))))
207 (defmacro case (form &rest clausules)
208 (let ((!form (gensym)))
209 `(let ((,!form ,form))
211 ,@(mapcar (lambda (clausule)
212 (if (eq (car clausule) t)
214 `((eql ,!form ',(car clausule))
218 (defmacro ecase (form &rest clausules)
223 (error "ECASE expression failed."))))))
225 (defmacro and (&rest forms)
236 (defmacro or (&rest forms)
244 `(let ((,g ,(car forms)))
245 (if ,g ,g (or ,@(cdr forms))))))))
247 (defmacro prog1 (form &body body)
248 (let ((value (gensym)))
249 `(let ((,value ,form))
253 (defmacro prog2 (form1 result &body body)
254 `(prog1 (progn ,form1 ,result) ,@body))
258 ;;; Go on growing the Lisp language in Ecmalisp, with more high level
259 ;;; utilities as well as correct versions of other constructions.
261 (defun + (&rest args)
266 (defun - (x &rest others)
273 (defun append-two (list1 list2)
277 (append (cdr list1) list2))))
279 (defun append (&rest lists)
280 (!reduce #'append-two lists))
282 (defun revappend (list1 list2)
284 (push (car list1) list2)
285 (setq list1 (cdr list1)))
288 (defun reverse (list)
289 (revappend list '()))
291 (defmacro psetq (&rest pairs)
292 (let (;; For each pair, we store here a list of the form
293 ;; (VARIABLE GENSYM VALUE).
297 ((null pairs) (return))
299 (error "Odd paris in PSETQ"))
301 (let ((variable (car pairs))
302 (value (cadr pairs)))
303 (push `(,variable ,(gensym) ,value) assignments)
304 (setq pairs (cddr pairs))))))
305 (setq assignments (reverse assignments))
307 `(let ,(mapcar #'cdr assignments)
308 (setq ,@(!reduce #'append (mapcar #'butlast assignments))))))
310 (defmacro do (varlist endlist &body body)
312 (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
315 (return (progn ,@(cdr endlist))))
320 (and (consp (cddr v))
321 (list (first v) (third v))))
324 (defmacro do* (varlist endlist &body body)
326 (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
329 (return (progn ,@(cdr endlist))))
334 (and (consp (cddr v))
335 (list (first v) (third v))))
338 (defun list-length (list)
340 (while (not (null list))
342 (setq list (cdr list)))
354 (defun concat-two (s1 s2)
357 (defmacro with-collect (&body body)
358 (let ((head (gensym))
360 `(let* ((,head (cons 'sentinel nil))
363 (rplacd ,tail (cons x nil))
364 (setq ,tail (cdr ,tail))
369 (defun map1 (func list)
372 (collect (funcall func (car list)))
373 (setq list (cdr list)))))
375 (defmacro loop (&body body)
378 (defun mapcar (func list &rest lists)
379 (let ((lists (cons list lists)))
383 (let ((elems (map1 #'car lists)))
384 (do ((tail lists (cdr tail)))
386 (when (null (car tail)) (return-from loop))
387 (rplaca tail (cdar tail)))
388 (collect (apply func elems))))))))
390 (defun identity (x) x)
392 (defun constantly (x)
397 (mapcar #'identity x))
399 (defun list* (arg &rest others)
400 (cond ((null others) arg)
401 ((null (cdr others)) (cons arg (car others)))
402 (t (do ((x others (cdr x)))
403 ((null (cddr x)) (rplacd x (cadr x))))
406 (defun code-char (x) x)
407 (defun char-code (x) x)
408 (defun char= (x y) (= x y))
411 (and (numberp x) (= (floor x) x)))
414 (and (numberp x) (not (integerp x))))
416 (defun plusp (x) (< 0 x))
417 (defun minusp (x) (< x 0))
420 (or (consp x) (null x)))
422 (defun nthcdr (n list)
423 (while (and (plusp n) list)
425 (setq list (cdr list)))
429 (car (nthcdr n list)))
432 (while (consp (cdr x))
438 (cons (car x) (butlast (cdr x)))))
440 (defun member (x list)
442 (when (eql x (car list))
444 (setq list (cdr list))))
446 (defun find (item list &key key (test #'eql))
448 (when (funcall test (funcall key x) item)
451 (defun remove (x list)
456 (remove x (cdr list)))
458 (cons (car list) (remove x (cdr list))))))
460 (defun remove-if (func list)
464 ((funcall func (car list))
465 (remove-if func (cdr list)))
468 (cons (car list) (remove-if func (cdr list))))))
470 (defun remove-if-not (func list)
474 ((funcall func (car list))
475 (cons (car list) (remove-if-not func (cdr list))))
477 (remove-if-not func (cdr list)))))
479 (defun digit-char-p (x)
480 (if (and (<= #\0 x) (<= x #\9))
484 (defun digit-char (weight)
486 (char "0123456789" weight)))
488 (defun subseq (seq a &optional b)
495 (error "Unsupported argument."))))
497 (defmacro do-sequence (iteration &body body)
500 `(let ((,seq ,(second iteration)))
505 (dotimes (,index (length ,seq))
506 (let ((,(first iteration)
511 (dolist (,(first iteration) ,seq)
514 (error "type-error!"))))))
516 (defun some (function seq)
517 (do-sequence (elt seq)
518 (when (funcall function elt)
519 (return-from some t))))
521 (defun every (function seq)
522 (do-sequence (elt seq)
523 (unless (funcall function elt)
524 (return-from every nil)))
527 (defun position (elt sequence)
535 (defun assoc (x alist)
537 (if (eql x (caar alist))
539 (setq alist (cdr alist))))
543 (cond ((stringp x) x)
544 ((symbolp x) (symbol-name x))
545 (t (char-to-string x))))
547 (defun string= (s1 s2)
550 (defun fdefinition (x)
557 (error "Invalid function"))))
559 (defun disassemble (function)
560 (write-line (lambda-code (fdefinition function)))
563 (defun documentation (x type)
564 "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
567 (let ((func (fdefinition x)))
568 (oget func "docstring")))
571 (error "Wrong argument type! it should be a symbol"))
574 (defmacro multiple-value-bind (variables value-from &body body)
575 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
579 (defmacro multiple-value-list (value-from)
580 `(multiple-value-call #'list ,value-from))
583 ;;; Generalized references (SETF)
585 (defvar *setf-expanders* nil)
587 (defun get-setf-expansion (place)
589 (let ((value (gensym)))
593 `(setq ,place ,value)
595 (let ((place (ls-macroexpand-1 place)))
596 (let* ((access-fn (car place))
597 (expander (cdr (assoc access-fn *setf-expanders*))))
598 (when (null expander)
599 (error "Unknown generalized reference."))
600 (apply expander (cdr place))))))
602 (defmacro define-setf-expander (access-fn lambda-list &body body)
603 (unless (symbolp access-fn)
604 (error "ACCESS-FN must be a symbol."))
605 `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
609 (defmacro setf (&rest pairs)
614 (error "Odd number of arguments to setf."))
616 (let ((place (ls-macroexpand-1 (first pairs)))
617 (value (second pairs)))
618 (multiple-value-bind (vars vals store-vars writer-form reader-form)
619 (get-setf-expansion place)
620 ;; TODO: Optimize the expansion a little bit to avoid let*
621 ;; or multiple-value-bind when unnecesary.
622 `(let* ,(mapcar #'list vars vals)
623 (multiple-value-bind ,store-vars
628 ,@(do ((pairs pairs (cddr pairs))
629 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
631 (reverse result)))))))
633 (define-setf-expander car (x)
634 (let ((cons (gensym))
635 (new-value (gensym)))
639 `(progn (rplaca ,cons ,new-value) ,new-value)
642 (define-setf-expander cdr (x)
643 (let ((cons (gensym))
644 (new-value (gensym)))
648 `(progn (rplacd ,cons ,new-value) ,new-value)
651 ;; Incorrect typecase, but used in NCONC.
652 (defmacro typecase (x &rest clausules)
653 (let ((value (gensym)))
656 ,@(mapcar (lambda (c)
670 ;; The NCONC function is based on the SBCL's one.
671 (defun nconc (&rest lists)
672 (flet ((fail (object)
673 (error "type-error in nconc")))
674 (do ((top lists (cdr top)))
676 (let ((top-of-top (car top)))
679 (let* ((result top-of-top)
681 (do ((elements (cdr top) (cdr elements)))
683 (let ((ele (car elements)))
685 (cons (rplacd (last splice) ele)
687 (null (rplacd (last splice) nil))
688 (atom (if (cdr elements)
690 (rplacd (last splice) ele))))))
696 (return top-of-top))))))))
699 (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))
700 (2nd x 1st) ; 2nd follows first down the list.
701 (3rd y 2nd)) ;3rd follows 2nd down the list.
705 (defun notany (fn seq)
711 (defvar *package-list* nil)
713 (defun list-all-packages ()
716 (defun make-package (name &key use)
717 (let ((package (new))
718 (use (mapcar #'find-package-or-fail use)))
719 (oset package "packageName" name)
720 (oset package "symbols" (new))
721 (oset package "exports" (new))
722 (oset package "use" use)
723 (push package *package-list*)
727 (and (objectp x) (in "symbols" x)))
729 (defun find-package (package-designator)
730 (when (packagep package-designator)
731 (return-from find-package package-designator))
732 (let ((name (string package-designator)))
733 (dolist (package *package-list*)
734 (when (string= (package-name package) name)
737 (defun find-package-or-fail (package-designator)
738 (or (find-package package-designator)
739 (error "Package unknown.")))
741 (defun package-name (package-designator)
742 (let ((package (find-package-or-fail package-designator)))
743 (oget package "packageName")))
745 (defun %package-symbols (package-designator)
746 (let ((package (find-package-or-fail package-designator)))
747 (oget package "symbols")))
749 (defun package-use-list (package-designator)
750 (let ((package (find-package-or-fail package-designator)))
751 (oget package "use")))
753 (defun %package-external-symbols (package-designator)
754 (let ((package (find-package-or-fail package-designator)))
755 (oget package "exports")))
757 (defvar *common-lisp-package*
763 (defvar *user-package*
764 (make-package "CL-USER" :use (list *common-lisp-package*)))
766 (defvar *keyword-package*
767 (make-package "KEYWORD"))
770 (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
772 (defvar *package* *common-lisp-package*)
774 (defmacro in-package (package-designator)
776 (setq *package* (find-package-or-fail ,package-designator))))
778 ;; This function is used internally to initialize the CL package
779 ;; with the symbols built during bootstrap.
780 (defun %intern-symbol (symbol)
782 (if (in "package" symbol)
783 (find-package-or-fail (oget symbol "package"))
784 *common-lisp-package*))
785 (symbols (%package-symbols package)))
786 (oset symbol "package" package)
787 (when (eq package *keyword-package*)
788 (oset symbol "value" symbol))
789 (oset symbols (symbol-name symbol) symbol)))
791 (defun find-symbol (name &optional (package *package*))
792 (let* ((package (find-package-or-fail package))
793 (externals (%package-external-symbols package))
794 (symbols (%package-symbols package)))
797 (values (oget externals name) :external))
799 (values (oget symbols name) :internal))
801 (dolist (used (package-use-list package) (values nil nil))
802 (let ((exports (%package-external-symbols used)))
803 (when (in name exports)
804 (return (values (oget exports name) :inherit)))))))))
806 (defun intern (name &optional (package *package*))
807 (let ((package (find-package-or-fail package)))
808 (multiple-value-bind (symbol foundp)
809 (find-symbol name package)
811 (values symbol foundp)
812 (let ((symbols (%package-symbols package)))
814 (let ((symbol (make-symbol name)))
815 (oset symbol "package" package)
816 (when (eq package *keyword-package*)
817 (oset symbol "value" symbol)
818 (export (list symbol) package))
819 (when (eq package *js-package*)
820 (let ((sym-name (symbol-name symbol))
822 ;; Generate a trampoline to call the JS function
823 ;; properly. This trampoline is very inefficient,
824 ;; but it still works. Ideas to optimize this are
825 ;; provide a special lambda keyword
826 ;; cl::&rest-vector to avoid list argument
827 ;; consing, as well as allow inline declarations.
829 (eval `(lambda (&rest ,args)
830 (let ((,args (list-to-vector ,args)))
831 (%js-call (%js-vref ,sym-name) ,args)))))
832 ;; Define it as a symbol macro to access to the
833 ;; Javascript variable literally.
834 (%define-symbol-macro symbol `(%js-vref ,(string symbol)))))
835 (oset symbols name symbol)
836 (values symbol nil)))))))
838 (defun symbol-package (symbol)
839 (unless (symbolp symbol)
840 (error "it is not a symbol"))
841 (oget symbol "package"))
843 (defun export (symbols &optional (package *package*))
844 (let ((exports (%package-external-symbols package)))
845 (dolist (symb symbols t)
846 (oset exports (symbol-name symb) symb))))
848 (defun get-universal-time ()
849 (+ (get-unix-time) 2208988800))
851 (defun concat (&rest strs)
852 (!reduce #'concat-two strs :initial-value ""))
854 (defun values-list (list)
855 (values-array (list-to-vector list)))
857 (defun values (&rest args)