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)
57 (defmacro lambda (args &body body)
58 `(function (lambda ,args ,@body)))
60 (defmacro when (condition &body body)
61 `(if ,condition (progn ,@body) nil))
63 (defmacro unless (condition &body body)
64 `(if ,condition nil (progn ,@body)))
66 (defmacro defvar (name &optional (value nil value-p) docstring)
68 (declaim (special ,name))
69 ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
70 ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
73 (defmacro defparameter (name value &optional docstring)
76 ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
79 (defmacro defun (name args &rest body)
81 (fset ',name #'(named-lambda ,name ,args ,@body))
84 (defmacro return (&optional value)
85 `(return-from nil ,value))
87 (defmacro while (condition &body body)
88 `(block nil (%while ,condition ,@body)))
90 (defvar *gensym-counter* 0)
91 (defun gensym (&optional (prefix "G"))
92 (setq *gensym-counter* (+ *gensym-counter* 1))
93 (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
101 (defun eq (x y) (eq x y))
102 (defun eql (x y) (eq x y))
104 (defun not (x) (if x nil t))
106 (defun funcall (function &rest args)
107 (apply function args))
109 (defun apply (function arg &rest args)
110 (apply function (apply #'list* arg args)))
114 (defmacro dolist ((var list &optional result) &body body)
115 (let ((g!list (gensym)))
116 (unless (symbolp var) (error "`~S' is not a symbol." var))
118 (let ((,g!list ,list)
121 (setq ,var (car ,g!list))
123 (setq ,g!list (cdr ,g!list)))
126 (defmacro dotimes ((var count &optional result) &body body)
127 (let ((g!count (gensym)))
128 (unless (symbolp var) (error "`~S' is not a symbol." var))
132 (%while (< ,var ,g!count)
137 (defmacro cond (&rest clausules)
138 (unless (null clausules)
139 (destructuring-bind (condition &body body)
145 (let ((test-symbol (gensym)))
146 `(let ((,test-symbol ,condition))
149 (cond ,@(rest clausules))))))
153 (cond ,@(rest clausules))))))))
155 (defmacro case (form &rest clausules)
156 (let ((!form (gensym)))
157 `(let ((,!form ,form))
159 ,@(mapcar (lambda (clausule)
160 (destructuring-bind (keys &body body)
162 (if (or (eq keys 't) (eq keys 'otherwise))
164 (let ((keys (if (listp keys) keys (list keys))))
165 `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
169 (defmacro ecase (form &rest clausules)
170 (let ((g!form (gensym)))
171 `(let ((,g!form ,form))
176 (error "ECASE expression failed for the object `~S'." ,g!form))))))))
178 (defmacro and (&rest forms)
189 (defmacro or (&rest forms)
197 `(let ((,g ,(car forms)))
198 (if ,g ,g (or ,@(cdr forms))))))))
200 (defmacro prog1 (form &body body)
201 (let ((value (gensym)))
202 `(let ((,value ,form))
206 (defmacro prog2 (form1 result &body body)
207 `(prog1 (progn ,form1 ,result) ,@body))
209 (defmacro prog (inits &rest body )
210 (multiple-value-bind (forms decls docstring) (parse-body body)
214 (tagbody ,@forms)))))
216 (defmacro psetq (&rest pairs)
217 (let (;; For each pair, we store here a list of the form
218 ;; (VARIABLE GENSYM VALUE).
222 ((null pairs) (return))
224 (error "Odd paris in PSETQ"))
226 (let ((variable (car pairs))
227 (value (cadr pairs)))
228 (push `(,variable ,(gensym) ,value) assignments)
229 (setq pairs (cddr pairs))))))
230 (setq assignments (reverse assignments))
232 `(let ,(mapcar #'cdr assignments)
233 (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
235 (defmacro do (varlist endlist &body body)
237 (let ,(mapcar (lambda (x) (if (symbolp x)
239 (list (first x) (second x)))) varlist)
242 (return (progn ,@(cdr endlist))))
249 (list (first v) (third v))))
252 (defmacro do* (varlist endlist &body body)
254 (let* ,(mapcar (lambda (x1) (if (symbolp x1)
256 (list (first x1) (second x1)))) varlist)
259 (return (progn ,@(cdr endlist))))
266 (list (first v) (third v))))
269 (defmacro with-collect (&body body)
270 (let ((head (gensym))
272 `(let* ((,head (cons 'sentinel nil))
275 (rplacd ,tail (cons x nil))
276 (setq ,tail (cdr ,tail))
282 (defmacro loop (&body body)
285 (defun identity (x) x)
287 (defun complement (x)
289 (not (apply x args))))
291 (defun constantly (x)
305 (< (char-code x) (char-code y)))
310 (defun alpha-char-p (x)
311 (or (<= (char-code #\a) (char-code x) (char-code #\z))
312 (<= (char-code #\A) (char-code x) (char-code #\Z))))
314 (defun digit-char-p (x)
315 (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
316 (- (char-code x) (char-code #\0))
319 (defun digit-char (weight)
321 (char "0123456789" weight)))
328 (equal (car x) (car y))
329 (equal (cdr x) (cdr y))))
331 (and (stringp y) (string= x y)))
334 (defun fdefinition (x)
341 (error "Invalid function `~S'." x))))
343 (defun disassemble (function)
344 (write-line (lambda-code (fdefinition function)))
347 (defmacro multiple-value-bind (variables value-from &body body)
348 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
352 (defmacro multiple-value-list (value-from)
353 `(multiple-value-call #'list ,value-from))
356 ;;; Generalized references (SETF)
358 (eval-when(:compile-toplevel :load-toplevel :execute)
359 (defvar *setf-expanders* nil)
360 (defun !get-setf-expansion (place)
362 (let ((value (gensym)))
366 `(setq ,place ,value)
368 (let ((place (!macroexpand-1 place)))
369 (let* ((access-fn (car place))
370 (expander (cdr (assoc access-fn *setf-expanders*))))
371 (when (null expander)
372 (error "Unknown generalized reference."))
373 (apply expander (cdr place)))))))
374 (fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
376 (defmacro define-setf-expander (access-fn lambda-list &body body)
377 (unless (symbolp access-fn)
378 (error "ACCESS-FN `~S' must be a symbol." access-fn))
379 `(eval-when (:compile-toplevel :load-toplevel :execute)
380 (push (cons ',access-fn (lambda ,lambda-list ,@body))
384 (defmacro setf (&rest pairs)
389 (error "Odd number of arguments to setf."))
391 (let ((place (!macroexpand-1 (first pairs)))
392 (value (second pairs)))
393 (multiple-value-bind (vars vals store-vars writer-form reader-form)
394 (!get-setf-expansion place)
395 (declare (ignorable reader-form))
396 ;; TODO: Optimize the expansion a little bit to avoid let*
397 ;; or multiple-value-bind when unnecesary.
398 `(let* ,(mapcar #'list vars vals)
399 (multiple-value-bind ,store-vars
404 ,@(do ((pairs pairs (cddr pairs))
405 (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
407 (reverse result)))))))
409 (defmacro incf (place &optional (delta 1))
410 (multiple-value-bind (dummies vals newval setter getter)
411 (!get-setf-expansion place)
413 `(let* (,@(mapcar #'list dummies vals)
415 (,(car newval) (+ ,getter ,d))
419 (defmacro decf (place &optional (delta 1))
420 (multiple-value-bind (dummies vals newval setter getter)
421 (!get-setf-expansion place)
423 `(let* (,@(mapcar #'list dummies vals)
425 (,(car newval) (- ,getter ,d))
429 (defmacro push (x place)
430 (multiple-value-bind (dummies vals newval setter getter)
431 (!get-setf-expansion place)
434 ,@(mapcar #'list dummies vals)
435 (,(car newval) (cons ,g ,getter))
439 (defmacro pop (place)
440 (multiple-value-bind (dummies vals newval setter getter)
441 (!get-setf-expansion place)
442 (let ((head (gensym)))
443 `(let* (,@(mapcar #'list dummies vals)
445 (,(car newval) (cdr ,head))
450 (defmacro pushnew (x place &rest keys &key key test test-not)
451 (declare (ignore key test test-not))
452 (multiple-value-bind (dummies vals newval setter getter)
453 (!get-setf-expansion place)
457 ,@(mapcar #'list dummies vals)
460 (if (member ,g ,v ,@keys)
462 (let ((,(car newval) (cons ,g ,getter)))
467 ;; Incorrect typecase, but used in NCONC.
468 (defmacro typecase (x &rest clausules)
469 (let ((value (gensym)))
472 ,@(mapcar (lambda (c)
473 (if (find (car c) '(t otherwise))
480 (character 'characterp)
481 (sequence 'sequencep)
483 (function 'functionp)
495 (defmacro etypecase (x &rest clausules)
496 (let ((g!x (gensym)))
500 (t (error "~S fell through etypecase expression." ,g!x))))))
502 (defun notany (fn seq)
505 (defconstant internal-time-units-per-second 1000)
507 (defun get-internal-real-time ()
508 (get-internal-real-time))
510 (defun get-unix-time ()
511 (truncate (/ (get-internal-real-time) 1000)))
513 (defun get-universal-time ()
514 (+ (get-unix-time) 2208988800))
516 (defun values-list (list)
517 (values-array (list-to-vector list)))
519 (defun values (&rest args)
522 (defun error (fmt &rest args)
523 (%throw (apply #'format nil fmt args)))
525 (defmacro nth-value (n form)
526 `(multiple-value-call (lambda (&rest values)