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))
107 (defmacro dolist ((var list &optional result) &body body)
108 (let ((g!list (gensym)))
109 (unless (symbolp var) (error "`~S' is not a symbol." var))
111 (let ((,g!list ,list)
114 (setq ,var (car ,g!list))
116 (setq ,g!list (cdr ,g!list)))
119 (defmacro dotimes ((var count &optional result) &body body)
120 (let ((g!count (gensym)))
121 (unless (symbolp var) (error "`~S' is not a symbol." var))
125 (%while (< ,var ,g!count)
130 (defmacro cond (&rest clausules)
131 (unless (null clausules)
132 (destructuring-bind (condition &body body)
138 (let ((test-symbol (gensym)))
139 `(let ((,test-symbol ,condition))
142 (cond ,@(rest clausules))))))
146 (cond ,@(rest clausules))))))))
148 (defmacro case (form &rest clausules)
149 (let ((!form (gensym)))
150 `(let ((,!form ,form))
152 ,@(mapcar (lambda (clausule)
153 (destructuring-bind (keys &body body)
155 (if (or (eq keys 't) (eq keys 'otherwise))
157 (let ((keys (if (listp keys) keys (list keys))))
158 `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
162 (defmacro ecase (form &rest clausules)
163 (let ((g!form (gensym)))
164 `(let ((,g!form ,form))
169 (error "ECASE expression failed for the object `~S'." ,g!form))))))))
171 (defmacro and (&rest forms)
182 (defmacro or (&rest forms)
190 `(let ((,g ,(car forms)))
191 (if ,g ,g (or ,@(cdr forms))))))))
193 (defmacro prog1 (form &body body)
194 (let ((value (gensym)))
195 `(let ((,value ,form))
199 (defmacro prog2 (form1 result &body body)
200 `(prog1 (progn ,form1 ,result) ,@body))
202 (defmacro prog (inits &rest body )
203 (multiple-value-bind (forms decls docstring) (parse-body body)
207 (tagbody ,@forms)))))
209 (defmacro psetq (&rest pairs)
210 (let (;; For each pair, we store here a list of the form
211 ;; (VARIABLE GENSYM VALUE).
215 ((null pairs) (return))
217 (error "Odd paris in PSETQ"))
219 (let ((variable (car pairs))
220 (value (cadr pairs)))
221 (push `(,variable ,(gensym) ,value) assignments)
222 (setq pairs (cddr pairs))))))
223 (setq assignments (reverse assignments))
225 `(let ,(mapcar #'cdr assignments)
226 (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
228 (defmacro do (varlist endlist &body body)
230 (let ,(mapcar (lambda (x) (if (symbolp x)
232 (list (first x) (second x)))) varlist)
235 (return (progn ,@(cdr endlist))))
242 (list (first v) (third v))))
245 (defmacro do* (varlist endlist &body body)
247 (let* ,(mapcar (lambda (x1) (if (symbolp x1)
249 (list (first x1) (second x1)))) varlist)
252 (return (progn ,@(cdr endlist))))
259 (list (first v) (third v))))
262 (defmacro with-collect (&body body)
263 (let ((head (gensym))
265 `(let* ((,head (cons 'sentinel nil))
268 (rplacd ,tail (cons x nil))
269 (setq ,tail (cdr ,tail))
275 (defmacro loop (&body body)
278 (defun identity (x) x)
280 (defun complement (x)
282 (not (apply x args))))
284 (defun constantly (x)
298 (< (char-code x) (char-code y)))
303 (defun alpha-char-p (x)
304 (or (<= (char-code #\a) (char-code x) (char-code #\z))
305 (<= (char-code #\A) (char-code x) (char-code #\Z))))
307 (defun digit-char-p (x)
308 (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
309 (- (char-code x) (char-code #\0))
312 (defun digit-char (weight)
314 (char "0123456789" weight)))
321 (equal (car x) (car y))
322 (equal (cdr x) (cdr y))))
324 (and (stringp y) (string= x y)))
327 (defun fdefinition (x)
334 (error "Invalid function `~S'." x))))
336 (defun disassemble (function)
337 (write-line (lambda-code (fdefinition function)))
340 (defmacro multiple-value-bind (variables value-from &body body)
341 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
345 (defmacro multiple-value-list (value-from)
346 `(multiple-value-call #'list ,value-from))
349 ;;; Generalized references (SETF)
351 (defvar *setf-expanders* nil)
353 (defun get-setf-expansion (place)
355 (let ((value (gensym)))
359 `(setq ,place ,value)
361 (let ((place (!macroexpand-1 place)))
362 (let* ((access-fn (car place))
363 (expander (cdr (assoc access-fn *setf-expanders*))))
364 (when (null expander)
365 (error "Unknown generalized reference."))
366 (apply expander (cdr place))))))
368 (defmacro define-setf-expander (access-fn lambda-list &body body)
369 (unless (symbolp access-fn)
370 (error "ACCESS-FN `~S' must be a symbol." access-fn))
371 `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
375 (defmacro setf (&rest pairs)
380 (error "Odd number of arguments to setf."))
382 (let ((place (!macroexpand-1 (first pairs)))
383 (value (second pairs)))
384 (multiple-value-bind (vars vals store-vars writer-form reader-form)
385 (get-setf-expansion place)
386 ;; TODO: Optimize the expansion a little bit to avoid let*
387 ;; or multiple-value-bind when unnecesary.
388 `(let* ,(mapcar #'list vars vals)
389 (multiple-value-bind ,store-vars
395 ,@(do ((pairs pairs (cddr pairs))
396 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
398 (reverse result)))))))
400 (defmacro incf (place &optional (delta 1))
401 (multiple-value-bind (dummies vals newval setter getter)
402 (get-setf-expansion place)
404 `(let* (,@(mapcar #'list dummies vals)
406 (,(car newval) (+ ,getter ,d))
410 (defmacro decf (place &optional (delta 1))
411 (multiple-value-bind (dummies vals newval setter getter)
412 (get-setf-expansion place)
414 `(let* (,@(mapcar #'list dummies vals)
416 (,(car newval) (- ,getter ,d))
420 (defmacro push (x place)
421 (multiple-value-bind (dummies vals newval setter getter)
422 (get-setf-expansion place)
425 ,@(mapcar #'list dummies vals)
426 (,(car newval) (cons ,g ,getter))
430 (defmacro pop (place)
431 (multiple-value-bind (dummies vals newval setter getter)
432 (get-setf-expansion place)
433 (let ((head (gensym)))
434 `(let* (,@(mapcar #'list dummies vals)
436 (,(car newval) (cdr ,head))
441 (defmacro pushnew (x place &rest keys &key key test test-not)
442 (declare (ignore key test test-not))
443 (multiple-value-bind (dummies vals newval setter getter)
444 (get-setf-expansion place)
448 ,@(mapcar #'list dummies vals)
451 (if (member ,g ,v ,@keys)
453 (let ((,(car newval) (cons ,g ,getter)))
458 ;; Incorrect typecase, but used in NCONC.
459 (defmacro typecase (x &rest clausules)
460 (let ((value (gensym)))
463 ,@(mapcar (lambda (c)
464 (if (find (car c) '(t otherwise))
471 (character 'characterp)
472 (sequence 'sequencep)
474 (function 'functionp)
486 (defmacro etypecase (x &rest clausules)
487 (let ((g!x (gensym)))
491 (t (error "~S fell through etypecase expression." ,g!x))))))
493 (defun notany (fn seq)
496 (defconstant internal-time-units-per-second 1000)
498 (defun get-internal-real-time ()
499 (get-internal-real-time))
501 (defun get-unix-time ()
502 (truncate (/ (get-internal-real-time) 1000)))
504 (defun get-universal-time ()
505 (+ (get-unix-time) 2208988800))
507 (defun values-list (list)
508 (values-array (list-to-vector list)))
510 (defun values (&rest args)
513 (defun error (fmt &rest args)
514 (%throw (apply #'format nil fmt args)))
516 (defmacro nth-value (n form)
517 `(multiple-value-call (lambda (&rest values)