1 ;;; boot.lisp --- First forms to be cross compiled
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
6 ;; JSCL 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 ;; JSCL 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 JSCL. If not, see <http://www.gnu.org/licenses/>.
19 ;;; This code is executed when JSCL compiles this file itself. The
20 ;;; compiler provides compilation of some special forms, as well as
21 ;;; funcalls and macroexpansion, but no functions. So, we define the
22 ;;; Lisp world from scratch. This code has to define enough language
23 ;;; to the compiler to be able to run.
25 (/debug "loading boot.lisp!")
28 (let ((defmacro-macroexpander
30 (destructuring-bind (name args &body body)
32 (let ((whole (gensym)))
34 (%compile-defmacro ',name
36 (destructuring-bind ,args ,whole
38 (%compile-defmacro 'defmacro defmacro-macroexpander)))
40 (defmacro declaim (&rest decls)
42 ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
44 (defmacro defconstant (name value &optional docstring)
46 (declaim (special ,name))
47 (declaim (constant ,name))
49 ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
53 (defconstant nil 'nil)
56 (defmacro lambda (args &body body)
57 `(function (lambda ,args ,@body)))
59 (defmacro when (condition &body body)
60 `(if ,condition (progn ,@body) nil))
62 (defmacro unless (condition &body body)
63 `(if ,condition nil (progn ,@body)))
65 (defmacro defvar (name &optional (value nil value-p) docstring)
67 (declaim (special ,name))
68 ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
69 ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
72 (defmacro defparameter (name value &optional docstring)
75 ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
78 (defmacro defun (name args &rest body)
80 (fset ',name #'(named-lambda ,name ,args ,@body))
83 (defmacro return (&optional value)
84 `(return-from nil ,value))
86 (defmacro while (condition &body body)
87 `(block nil (%while ,condition ,@body)))
89 (defvar *gensym-counter* 0)
90 (defun gensym (&optional (prefix "G"))
91 (setq *gensym-counter* (+ *gensym-counter* 1))
92 (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
100 (defun eq (x y) (eq x y))
101 (defun eql (x y) (eq x y))
103 (defun not (x) (if x nil t))
106 (defmacro incf (place &optional (delta 1))
107 (multiple-value-bind (dummies vals newval setter getter)
108 (get-setf-expansion place)
110 `(let* (,@(mapcar #'list dummies vals)
112 (,(car newval) (+ ,getter ,d))
116 (defmacro decf (place &optional (delta 1))
117 (multiple-value-bind (dummies vals newval setter getter)
118 (get-setf-expansion place)
120 `(let* (,@(mapcar #'list dummies vals)
122 (,(car newval) (- ,getter ,d))
126 (defmacro push (x place)
127 (multiple-value-bind (dummies vals newval setter getter)
128 (get-setf-expansion place)
131 ,@(mapcar #'list dummies vals)
132 (,(car newval) (cons ,g ,getter))
136 (defmacro pushnew (x place &rest keys &key key test test-not)
137 (declare (ignore key test test-not))
138 (multiple-value-bind (dummies vals newval setter getter)
139 (get-setf-expansion place)
143 ,@(mapcar #'list dummies vals)
146 (if (member ,g ,v ,@keys)
148 (let ((,(car newval) (cons ,g ,getter)))
151 (defmacro dolist ((var list &optional result) &body body)
152 (let ((g!list (gensym)))
153 (unless (symbolp var) (error "`~S' is not a symbol." var))
155 (let ((,g!list ,list)
158 (setq ,var (car ,g!list))
160 (setq ,g!list (cdr ,g!list)))
163 (defmacro dotimes ((var count &optional result) &body body)
164 (let ((g!count (gensym)))
165 (unless (symbolp var) (error "`~S' is not a symbol." var))
169 (%while (< ,var ,g!count)
174 (defmacro cond (&rest clausules)
175 (unless (null clausules)
176 (destructuring-bind (condition &body body)
182 (let ((test-symbol (gensym)))
183 `(let ((,test-symbol ,condition))
186 (cond ,@(rest clausules))))))
190 (cond ,@(rest clausules))))))))
192 (defmacro case (form &rest clausules)
193 (let ((!form (gensym)))
194 `(let ((,!form ,form))
196 ,@(mapcar (lambda (clausule)
197 (destructuring-bind (keys &body body)
199 (if (or (eq keys 't) (eq keys 'otherwise))
201 (let ((keys (if (listp keys) keys (list keys))))
202 `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
206 (defmacro ecase (form &rest clausules)
207 (let ((g!form (gensym)))
208 `(let ((,g!form ,form))
213 (error "ECASE expression failed for the object `~S'." ,g!form))))))))
215 (defmacro and (&rest forms)
226 (defmacro or (&rest forms)
234 `(let ((,g ,(car forms)))
235 (if ,g ,g (or ,@(cdr forms))))))))
237 (defmacro prog1 (form &body body)
238 (let ((value (gensym)))
239 `(let ((,value ,form))
243 (defmacro prog2 (form1 result &body body)
244 `(prog1 (progn ,form1 ,result) ,@body))
246 (defmacro prog (inits &rest body )
247 (multiple-value-bind (forms decls docstring) (parse-body body)
251 (tagbody ,@forms)))))
254 ;;; Go on growing the Lisp language in Ecmalisp, with more high level
255 ;;; utilities as well as correct versions of other constructions.
257 (defun append-two (list1 list2)
261 (append (cdr list1) list2))))
263 (defun append (&rest lists)
264 (!reduce #'append-two lists nil))
266 (defun revappend (list1 list2)
268 (push (car list1) list2)
269 (setq list1 (cdr list1)))
272 (defun reverse (list)
273 (revappend list '()))
275 (defmacro psetq (&rest pairs)
276 (let (;; For each pair, we store here a list of the form
277 ;; (VARIABLE GENSYM VALUE).
281 ((null pairs) (return))
283 (error "Odd paris in PSETQ"))
285 (let ((variable (car pairs))
286 (value (cadr pairs)))
287 (push `(,variable ,(gensym) ,value) assignments)
288 (setq pairs (cddr pairs))))))
289 (setq assignments (reverse assignments))
291 `(let ,(mapcar #'cdr assignments)
292 (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
294 (defmacro do (varlist endlist &body body)
296 (let ,(mapcar (lambda (x) (if (symbolp x)
298 (list (first x) (second x)))) varlist)
301 (return (progn ,@(cdr endlist))))
308 (list (first v) (third v))))
311 (defmacro do* (varlist endlist &body body)
313 (let* ,(mapcar (lambda (x1) (if (symbolp x1)
315 (list (first x1) (second x1)))) varlist)
318 (return (progn ,@(cdr endlist))))
325 (list (first v) (third v))))
328 (defun list-length (list)
330 (while (not (null list))
332 (setq list (cdr list)))
344 (defmacro with-collect (&body body)
345 (let ((head (gensym))
347 `(let* ((,head (cons 'sentinel nil))
350 (rplacd ,tail (cons x nil))
351 (setq ,tail (cdr ,tail))
357 (defmacro loop (&body body)
360 (defun identity (x) x)
362 (defun complement (x)
364 (not (apply x args))))
366 (defun constantly (x)
380 (< (char-code x) (char-code y)))
385 (defun alpha-char-p (x)
386 (or (<= (char-code #\a) (char-code x) (char-code #\z))
387 (<= (char-code #\A) (char-code x) (char-code #\Z))))
389 (defun digit-char-p (x)
390 (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
391 (- (char-code x) (char-code #\0))
394 (defun digit-char (weight)
396 (char "0123456789" weight)))
403 (equal (car x) (car y))
404 (equal (cdr x) (cdr y))))
406 (and (stringp y) (string= x y)))
409 (defun fdefinition (x)
416 (error "Invalid function `~S'." x))))
418 (defun disassemble (function)
419 (write-line (lambda-code (fdefinition function)))
422 (defun documentation (x type)
423 "Return the documentation of X. TYPE must be the symbol VARIABLE or FUNCTION."
426 (let ((func (fdefinition x)))
427 (oget func "docstring")))
430 (error "The type of documentation `~S' is not a symbol." type))
433 (defmacro multiple-value-bind (variables value-from &body body)
434 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
438 (defmacro multiple-value-list (value-from)
439 `(multiple-value-call #'list ,value-from))
442 ;;; Generalized references (SETF)
444 (defvar *setf-expanders* nil)
446 (defun get-setf-expansion (place)
448 (let ((value (gensym)))
452 `(setq ,place ,value)
454 (let ((place (!macroexpand-1 place)))
455 (let* ((access-fn (car place))
456 (expander (cdr (assoc access-fn *setf-expanders*))))
457 (when (null expander)
458 (error "Unknown generalized reference."))
459 (apply expander (cdr place))))))
461 (defmacro define-setf-expander (access-fn lambda-list &body body)
462 (unless (symbolp access-fn)
463 (error "ACCESS-FN `~S' must be a symbol." access-fn))
464 `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
468 (defmacro setf (&rest pairs)
473 (error "Odd number of arguments to setf."))
475 (let ((place (!macroexpand-1 (first pairs)))
476 (value (second pairs)))
477 (multiple-value-bind (vars vals store-vars writer-form reader-form)
478 (get-setf-expansion place)
479 ;; TODO: Optimize the expansion a little bit to avoid let*
480 ;; or multiple-value-bind when unnecesary.
481 `(let* ,(mapcar #'list vars vals)
482 (multiple-value-bind ,store-vars
488 ,@(do ((pairs pairs (cddr pairs))
489 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
491 (reverse result)))))))
493 ;; Incorrect typecase, but used in NCONC.
494 (defmacro typecase (x &rest clausules)
495 (let ((value (gensym)))
498 ,@(mapcar (lambda (c)
505 (function 'functionp)
516 (defmacro etypecase (x &rest clausules)
517 (let ((g!x (gensym)))
521 (t (error "~X fell through etypecase expression." ,g!x))))))
523 (defun notany (fn seq)
526 (defconstant internal-time-units-per-second 1000)
528 (defun get-internal-real-time ()
529 (get-internal-real-time))
531 (defun get-unix-time ()
532 (truncate (/ (get-internal-real-time) 1000)))
534 (defun get-universal-time ()
535 (+ (get-unix-time) 2208988800))
537 (defun values-list (list)
538 (values-array (list-to-vector list)))
540 (defun values (&rest args)
543 (defun error (fmt &rest args)
544 (%throw (apply #'format nil fmt args)))
546 (defmacro nth-value (n form)
547 `(multiple-value-call (lambda (&rest values)