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!")
27 (eval-when (:compile-toplevel)
28 (let ((defmacro-macroexpander
30 (destructuring-bind (name args &body body)
32 (let ((whole (gensym)))
33 `(eval-when (:compile-toplevel :execute)
34 (%compile-defmacro ',name
36 (destructuring-bind ,args ,whole
38 (%compile-defmacro 'defmacro defmacro-macroexpander)))
40 (defmacro declaim (&rest decls)
41 `(eval-when (:compile-toplevel :execute)
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))
105 (defun funcall (function &rest args)
106 (apply function args))
108 (defun apply (function arg &rest args)
109 (apply function (apply #'list* arg args)))
113 (defmacro dolist ((var list &optional result) &body body)
114 (let ((g!list (gensym)))
115 (unless (symbolp var) (error "`~S' is not a symbol." var))
117 (let ((,g!list ,list)
120 (setq ,var (car ,g!list))
122 (setq ,g!list (cdr ,g!list)))
125 (defmacro dotimes ((var count &optional result) &body body)
126 (let ((g!count (gensym)))
127 (unless (symbolp var) (error "`~S' is not a symbol." var))
131 (%while (< ,var ,g!count)
136 (defmacro cond (&rest clausules)
137 (unless (null clausules)
138 (destructuring-bind (condition &body body)
144 (let ((test-symbol (gensym)))
145 `(let ((,test-symbol ,condition))
148 (cond ,@(rest clausules))))))
152 (cond ,@(rest clausules))))))))
154 (defmacro case (form &rest clausules)
155 (let ((!form (gensym)))
156 `(let ((,!form ,form))
158 ,@(mapcar (lambda (clausule)
159 (destructuring-bind (keys &body body)
161 (if (or (eq keys 't) (eq keys 'otherwise))
163 (let ((keys (if (listp keys) keys (list keys))))
164 `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
168 (defmacro ecase (form &rest clausules)
169 (let ((g!form (gensym)))
170 `(let ((,g!form ,form))
175 (error "ECASE expression failed for the object `~S'." ,g!form))))))))
177 (defmacro and (&rest forms)
188 (defmacro or (&rest forms)
196 `(let ((,g ,(car forms)))
197 (if ,g ,g (or ,@(cdr forms))))))))
199 (defmacro prog1 (form &body body)
200 (let ((value (gensym)))
201 `(let ((,value ,form))
205 (defmacro prog2 (form1 result &body body)
206 `(prog1 (progn ,form1 ,result) ,@body))
208 (defmacro prog (inits &rest body )
209 (multiple-value-bind (forms decls docstring) (parse-body body)
213 (tagbody ,@forms)))))
215 (defmacro psetq (&rest pairs)
216 (let (;; For each pair, we store here a list of the form
217 ;; (VARIABLE GENSYM VALUE).
221 ((null pairs) (return))
223 (error "Odd paris in PSETQ"))
225 (let ((variable (car pairs))
226 (value (cadr pairs)))
227 (push `(,variable ,(gensym) ,value) assignments)
228 (setq pairs (cddr pairs))))))
229 (setq assignments (reverse assignments))
231 `(let ,(mapcar #'cdr assignments)
232 (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
234 (defmacro do (varlist endlist &body body)
236 (let ,(mapcar (lambda (x) (if (symbolp x)
238 (list (first x) (second x)))) varlist)
241 (return (progn ,@(cdr endlist))))
248 (list (first v) (third v))))
251 (defmacro do* (varlist endlist &body body)
253 (let* ,(mapcar (lambda (x1) (if (symbolp x1)
255 (list (first x1) (second x1)))) varlist)
258 (return (progn ,@(cdr endlist))))
265 (list (first v) (third v))))
268 (defmacro with-collect (&body body)
269 (let ((head (gensym))
271 `(let* ((,head (cons 'sentinel nil))
274 (rplacd ,tail (cons x nil))
275 (setq ,tail (cdr ,tail))
281 (defmacro loop (&body body)
284 (defun identity (x) x)
286 (defun complement (x)
288 (not (apply x args))))
290 (defun constantly (x)
304 (< (char-code x) (char-code y)))
309 (defun alpha-char-p (x)
310 (or (<= (char-code #\a) (char-code x) (char-code #\z))
311 (<= (char-code #\A) (char-code x) (char-code #\Z))))
313 (defun digit-char-p (x)
314 (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
315 (- (char-code x) (char-code #\0))
318 (defun digit-char (weight)
320 (char "0123456789" weight)))
327 (equal (car x) (car y))
328 (equal (cdr x) (cdr y))))
330 (and (stringp y) (string= x y)))
333 (defun fdefinition (x)
340 (error "Invalid function `~S'." x))))
342 (defun disassemble (function)
343 (write-line (lambda-code (fdefinition function)))
346 (defmacro multiple-value-bind (variables value-from &body body)
347 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
351 (defmacro multiple-value-list (value-from)
352 `(multiple-value-call #'list ,value-from))
355 ;;; Generalized references (SETF)
357 (eval-when(:compile-toplevel :load-toplevel :execute)
358 (defvar *setf-expanders* nil)
359 (defun !get-setf-expansion (place)
361 (let ((value (gensym)))
365 `(setq ,place ,value)
367 (let ((place (!macroexpand-1 place)))
368 (let* ((access-fn (car place))
369 (expander (cdr (assoc access-fn *setf-expanders*))))
370 (when (null expander)
371 (error "Unknown generalized reference."))
372 (apply expander (cdr place)))))))
373 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
375 (defmacro define-setf-expander (access-fn lambda-list &body body)
376 (unless (symbolp access-fn)
377 (error "ACCESS-FN `~S' must be a symbol." access-fn))
378 `(eval-when (:compile-toplevel :load-toplevel :execute)
379 (push (cons ',access-fn (lambda ,lambda-list ,@body))
383 (defmacro setf (&rest pairs)
388 (error "Odd number of arguments to setf."))
390 (let ((place (!macroexpand-1 (first pairs)))
391 (value (second pairs)))
392 (multiple-value-bind (vars vals store-vars writer-form reader-form)
393 (!get-setf-expansion place)
394 (declare (ignorable reader-form))
395 ;; TODO: Optimize the expansion a little bit to avoid let*
396 ;; or multiple-value-bind when unnecesary.
397 `(let* ,(mapcar #'list vars vals)
398 (multiple-value-bind ,store-vars
403 ,@(do ((pairs pairs (cddr pairs))
404 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
406 (reverse result)))))))
408 (defmacro incf (place &optional (delta 1))
409 (multiple-value-bind (dummies vals newval setter getter)
410 (!get-setf-expansion place)
412 `(let* (,@(mapcar #'list dummies vals)
414 (,(car newval) (+ ,getter ,d))
418 (defmacro decf (place &optional (delta 1))
419 (multiple-value-bind (dummies vals newval setter getter)
420 (!get-setf-expansion place)
422 `(let* (,@(mapcar #'list dummies vals)
424 (,(car newval) (- ,getter ,d))
428 (defmacro push (x place)
429 (multiple-value-bind (dummies vals newval setter getter)
430 (!get-setf-expansion place)
433 ,@(mapcar #'list dummies vals)
434 (,(car newval) (cons ,g ,getter))
438 (defmacro pop (place)
439 (multiple-value-bind (dummies vals newval setter getter)
440 (!get-setf-expansion place)
441 (let ((head (gensym)))
442 `(let* (,@(mapcar #'list dummies vals)
444 (,(car newval) (cdr ,head))
449 (defmacro pushnew (x place &rest keys &key key test test-not)
450 (declare (ignore key test test-not))
451 (multiple-value-bind (dummies vals newval setter getter)
452 (!get-setf-expansion place)
456 ,@(mapcar #'list dummies vals)
459 (if (member ,g ,v ,@keys)
461 (let ((,(car newval) (cons ,g ,getter)))
466 ;; Incorrect typecase, but used in NCONC.
467 (defmacro typecase (x &rest clausules)
468 (let ((value (gensym)))
471 ,@(mapcar (lambda (c)
472 (if (find (car c) '(t otherwise))
479 (character 'characterp)
480 (sequence 'sequencep)
482 (function 'functionp)
494 (defmacro etypecase (x &rest clausules)
495 (let ((g!x (gensym)))
499 (t (error "~S fell through etypecase expression." ,g!x))))))
501 (defun notany (fn seq)
504 (defconstant internal-time-units-per-second 1000)
506 (defun get-internal-real-time ()
507 (get-internal-real-time))
509 (defun get-unix-time ()
510 (truncate (/ (get-internal-real-time) 1000)))
512 (defun get-universal-time ()
513 (+ (get-unix-time) 2208988800))
515 (defun values-list (list)
516 (values-array (list-to-vector list)))
518 (defun values (&rest args)
521 (defun error (fmt &rest args)
522 (%throw (apply #'format nil fmt args)))
524 (defmacro nth-value (n form)
525 `(multiple-value-call (lambda (&rest values)