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 (eval-when (:compile-toplevel)
82 (fn-info ',name :defined t))
83 (fset ',name #'(named-lambda ,name ,args ,@body))
86 (defmacro return (&optional value)
87 `(return-from nil ,value))
89 (defmacro while (condition &body body)
90 `(block nil (%while ,condition ,@body)))
92 (defvar *gensym-counter* 0)
93 (defun gensym (&optional (prefix "G"))
94 (setq *gensym-counter* (+ *gensym-counter* 1))
95 (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
103 (defun eq (x y) (eq x y))
104 (defun eql (x y) (eq x y))
106 (defun not (x) (if x nil t))
108 (defun funcall (function &rest args)
109 (apply function args))
111 (defun apply (function arg &rest args)
112 (apply function (apply #'list* arg args)))
116 (defmacro dolist ((var list &optional result) &body body)
117 (let ((g!list (gensym)))
118 (unless (symbolp var) (error "`~S' is not a symbol." var))
120 (let ((,g!list ,list)
123 (setq ,var (car ,g!list))
125 (setq ,g!list (cdr ,g!list)))
128 (defmacro dotimes ((var count &optional result) &body body)
129 (let ((g!count (gensym)))
130 (unless (symbolp var) (error "`~S' is not a symbol." var))
134 (%while (< ,var ,g!count)
139 (defmacro cond (&rest clausules)
140 (unless (null clausules)
141 (destructuring-bind (condition &body body)
147 (let ((test-symbol (gensym)))
148 `(let ((,test-symbol ,condition))
151 (cond ,@(rest clausules))))))
155 (cond ,@(rest clausules))))))))
157 (defmacro case (form &rest clausules)
158 (let ((!form (gensym)))
159 `(let ((,!form ,form))
161 ,@(mapcar (lambda (clausule)
162 (destructuring-bind (keys &body body)
164 (if (or (eq keys 't) (eq keys 'otherwise))
166 (let ((keys (if (listp keys) keys (list keys))))
167 `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
171 (defmacro ecase (form &rest clausules)
172 (let ((g!form (gensym)))
173 `(let ((,g!form ,form))
178 (error "ECASE expression failed for the object `~S'." ,g!form))))))))
180 (defmacro and (&rest forms)
191 (defmacro or (&rest forms)
199 `(let ((,g ,(car forms)))
200 (if ,g ,g (or ,@(cdr forms))))))))
202 (defmacro prog1 (form &body body)
203 (let ((value (gensym)))
204 `(let ((,value ,form))
208 (defmacro prog2 (form1 result &body body)
209 `(prog1 (progn ,form1 ,result) ,@body))
211 (defmacro prog (inits &rest body )
212 (multiple-value-bind (forms decls docstring) (parse-body body)
216 (tagbody ,@forms)))))
218 (defmacro psetq (&rest pairs)
219 (let (;; For each pair, we store here a list of the form
220 ;; (VARIABLE GENSYM VALUE).
224 ((null pairs) (return))
226 (error "Odd paris in PSETQ"))
228 (let ((variable (car pairs))
229 (value (cadr pairs)))
230 (push `(,variable ,(gensym) ,value) assignments)
231 (setq pairs (cddr pairs))))))
232 (setq assignments (reverse assignments))
234 `(let ,(mapcar #'cdr assignments)
235 (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
237 (defmacro do (varlist endlist &body body)
239 (let ,(mapcar (lambda (x) (if (symbolp x)
241 (list (first x) (second x)))) varlist)
244 (return (progn ,@(cdr endlist))))
251 (list (first v) (third v))))
254 (defmacro do* (varlist endlist &body body)
256 (let* ,(mapcar (lambda (x1) (if (symbolp x1)
258 (list (first x1) (second x1)))) varlist)
261 (return (progn ,@(cdr endlist))))
268 (list (first v) (third v))))
271 (defmacro with-collect (&body body)
272 (let ((head (gensym))
274 `(let* ((,head (cons 'sentinel nil))
277 (rplacd ,tail (cons x nil))
278 (setq ,tail (cdr ,tail))
284 (defmacro loop (&body body)
287 (defun identity (x) x)
289 (defun complement (x)
291 (not (apply x args))))
293 (defun constantly (x)
307 (< (char-code x) (char-code y)))
312 (defun alpha-char-p (x)
313 (or (<= (char-code #\a) (char-code x) (char-code #\z))
314 (<= (char-code #\A) (char-code x) (char-code #\Z))))
316 (defun digit-char-p (x)
317 (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
318 (- (char-code x) (char-code #\0))
321 (defun digit-char (weight)
323 (char "0123456789" weight)))
330 (equal (car x) (car y))
331 (equal (cdr x) (cdr y))))
333 (and (stringp y) (string= x y)))
336 (defun fdefinition (x)
343 (error "Invalid function `~S'." x))))
345 (defun disassemble (function)
346 (write-line (lambda-code (fdefinition function)))
349 (defmacro multiple-value-bind (variables value-from &body body)
350 `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
354 (defmacro multiple-value-list (value-from)
355 `(multiple-value-call #'list ,value-from))
358 ;; Incorrect typecase, but used in NCONC.
359 (defmacro typecase (x &rest clausules)
360 (let ((value (gensym)))
363 ,@(mapcar (lambda (c)
364 (if (find (car c) '(t otherwise))
371 (character 'characterp)
372 (sequence 'sequencep)
374 (function 'functionp)
386 (defmacro etypecase (x &rest clausules)
387 (let ((g!x (gensym)))
391 (t (error "~S fell through etypecase expression." ,g!x))))))
393 (defun notany (fn seq)
396 (defconstant internal-time-units-per-second 1000)
398 (defun get-internal-real-time ()
399 (get-internal-real-time))
401 (defun get-unix-time ()
402 (truncate (/ (get-internal-real-time) 1000)))
404 (defun get-universal-time ()
405 (+ (get-unix-time) 2208988800))
407 (defun values-list (list)
408 (values-array (list-to-vector list)))
410 (defun values (&rest args)
413 (defun error (fmt &rest args)
414 (%throw (apply #'format nil fmt args)))
416 (defmacro nth-value (n form)
417 `(multiple-value-call (lambda (&rest values)