Add *version* variable
[jscl.git] / src / boot.lisp
1 ;;; boot.lisp --- First forms to be cross compiled
2
3 ;; Copyright (C) 2012, 2013 David Vazquez
4 ;; Copyright (C) 2012 Raimon Grau
5
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.
10 ;;
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.
15 ;;
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/>.
18
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.
24
25 (/debug "loading boot.lisp!")
26
27 (eval-when (:compile-toplevel)
28   (let ((defmacro-macroexpander
29          '#'(lambda (form)
30               (destructuring-bind (name args &body body)
31                   form
32                 (let ((whole (gensym)))
33                   `(eval-when (:compile-toplevel :execute)
34                      (%compile-defmacro ',name
35                                         '#'(lambda (,whole)
36                                              (destructuring-bind ,args ,whole
37                                                ,@body)))))))))
38     (%compile-defmacro 'defmacro defmacro-macroexpander)))
39
40 (defmacro declaim (&rest decls)
41   `(eval-when (:compile-toplevel :execute)
42      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
43
44 (defmacro defconstant (name value &optional docstring)
45   `(progn
46      (declaim (special ,name))
47      (declaim (constant ,name))
48      (setq ,name ,value)
49      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
50      ',name))
51
52 (defconstant t 't)
53 (defconstant nil 'nil)
54 (%js-vset "nil" nil)
55 (%js-vset "t" t)
56
57 (defmacro lambda (args &body body)
58   `(function (lambda ,args ,@body)))
59
60 (defmacro when (condition &body body)
61   `(if ,condition (progn ,@body) nil))
62
63 (defmacro unless (condition &body body)
64   `(if ,condition nil (progn ,@body)))
65
66 (defmacro defvar (name &optional (value nil value-p) docstring)
67   `(progn
68      (declaim (special ,name))
69      ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
70      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
71      ',name))
72
73 (defmacro defparameter (name value &optional docstring)
74   `(progn
75      (setq ,name ,value)
76      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
77      ',name))
78
79 (defmacro defun (name args &rest body)
80   `(progn
81      (eval-when (:compile-toplevel)
82        (fn-info ',name :defined t))
83      (fset ',name #'(named-lambda ,name ,args ,@body))
84      ',name))
85
86 (defmacro return (&optional value)
87   `(return-from nil ,value))
88
89 (defmacro while (condition &body body)
90   `(block nil (%while ,condition ,@body)))
91
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*))))
96
97 (defun boundp (x)
98   (boundp x))
99
100 (defun fboundp (x)
101   (fboundp x))
102
103 (defun eq (x y) (eq x y))
104 (defun eql (x y) (eq x y))
105
106 (defun not (x) (if x nil t))
107
108 (defun funcall (function &rest args)
109   (apply function args))
110
111 (defun apply (function arg &rest args)
112   (apply function (apply #'list* arg args)))
113
114 ;; Basic macros
115
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))
119     `(block nil
120        (let ((,g!list ,list)
121              (,var nil))
122          (%while ,g!list
123                  (setq ,var (car ,g!list))
124                  (tagbody ,@body)
125                  (setq ,g!list (cdr ,g!list)))
126          ,result))))
127
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))
131     `(block nil
132        (let ((,var 0)
133              (,g!count ,count))
134          (%while (< ,var ,g!count)
135                  (tagbody ,@body)
136                  (incf ,var))
137          ,result))))
138
139 (defmacro cond (&rest clausules)
140   (unless (null clausules)
141     (destructuring-bind (condition &body body)
142         (first clausules)
143       (cond
144         ((eq condition t)
145          `(progn ,@body))
146         ((null body)
147          (let ((test-symbol (gensym)))
148            `(let ((,test-symbol ,condition))
149               (if ,test-symbol
150                   ,test-symbol
151                   (cond ,@(rest clausules))))))
152         (t
153          `(if ,condition
154               (progn ,@body)
155               (cond ,@(rest clausules))))))))
156
157 (defmacro case (form &rest clausules)
158   (let ((!form (gensym)))
159     `(let ((,!form ,form))
160        (cond
161          ,@(mapcar (lambda (clausule)
162                      (destructuring-bind (keys &body body)
163                          clausule
164                        (if (or (eq keys 't) (eq keys 'otherwise))
165                            `(t nil ,@body)
166                            (let ((keys (if (listp keys) keys (list keys))))
167                              `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
168                                nil ,@body)))))
169                    clausules)))))
170
171 (defmacro ecase (form &rest clausules)
172   (let ((g!form (gensym)))
173     `(let ((,g!form ,form))
174        (case ,g!form
175          ,@(append
176             clausules
177             `((t
178                (error "ECASE expression failed for the object `~S'." ,g!form))))))))
179
180 (defmacro and (&rest forms)
181   (cond
182     ((null forms)
183      t)
184     ((null (cdr forms))
185      (car forms))
186     (t
187      `(if ,(car forms)
188           (and ,@(cdr forms))
189           nil))))
190
191 (defmacro or (&rest forms)
192   (cond
193     ((null forms)
194      nil)
195     ((null (cdr forms))
196      (car forms))
197     (t
198      (let ((g (gensym)))
199        `(let ((,g ,(car forms)))
200           (if ,g ,g (or ,@(cdr forms))))))))
201
202 (defmacro prog1 (form &body body)
203   (let ((value (gensym)))
204     `(let ((,value ,form))
205        ,@body
206        ,value)))
207
208 (defmacro prog2 (form1 result &body body)
209   `(prog1 (progn ,form1 ,result) ,@body))
210
211 (defmacro prog (inits &rest body )
212   (multiple-value-bind (forms decls docstring) (parse-body body)
213     `(block nil
214        (let ,inits
215          ,@decls
216          (tagbody ,@forms)))))
217
218 (defmacro psetq (&rest pairs)
219   (let (;; For each pair, we store here a list of the form
220         ;; (VARIABLE GENSYM VALUE).
221         (assignments '()))
222     (while t
223       (cond
224         ((null pairs) (return))
225         ((null (cdr pairs))
226          (error "Odd paris in PSETQ"))
227         (t
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))
233     ;;
234     `(let ,(mapcar #'cdr assignments)
235        (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
236
237 (defmacro do (varlist endlist &body body)
238   `(block nil
239      (let ,(mapcar (lambda (x) (if (symbolp x)
240                                    (list x nil)
241                                  (list (first x) (second x)))) varlist)
242        (while t
243          (when ,(car endlist)
244            (return (progn ,@(cdr endlist))))
245          (tagbody ,@body)
246          (psetq
247           ,@(apply #'append
248                    (mapcar (lambda (v)
249                              (and (listp v)
250                                   (consp (cddr v))
251                                   (list (first v) (third v))))
252                            varlist)))))))
253
254 (defmacro do* (varlist endlist &body body)
255   `(block nil
256      (let* ,(mapcar (lambda (x1) (if (symbolp x1)
257                                      (list x1 nil)
258                                    (list (first x1) (second x1)))) varlist)
259        (while t
260          (when ,(car endlist)
261            (return (progn ,@(cdr endlist))))
262          (tagbody ,@body)
263          (setq
264           ,@(apply #'append
265                    (mapcar (lambda (v)
266                              (and (listp v)
267                                   (consp (cddr v))
268                                   (list (first v) (third v))))
269                            varlist)))))))
270
271 (defmacro with-collect (&body body)
272   (let ((head (gensym))
273         (tail (gensym)))
274     `(let* ((,head (cons 'sentinel nil))
275             (,tail ,head))
276        (flet ((collect (x)
277                 (rplacd ,tail (cons x nil))
278                 (setq ,tail (cdr ,tail))
279                 x))
280          ,@body)
281        (cdr ,head))))
282
283
284 (defmacro loop (&body body)
285   `(while t ,@body))
286
287 (defun identity (x) x)
288
289 (defun complement (x)
290   (lambda (&rest args)
291     (not (apply x args))))
292
293 (defun constantly (x)
294   (lambda (&rest args)
295     x))
296
297 (defun code-char (x)
298   (code-char x))
299
300 (defun char-code (x)
301   (char-code x))
302
303 (defun char= (x y)
304   (eql x y))
305
306 (defun char< (x y)
307   (< (char-code x) (char-code y)))
308
309 (defun atom (x)
310   (not (consp x)))
311
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))))
315
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))
319       nil))
320
321 (defun digit-char (weight)
322   (and (<= 0 weight 9)
323        (char "0123456789" weight)))
324
325 (defun equal (x y)
326   (cond
327     ((eql x y) t)
328     ((consp x)
329      (and (consp y)
330           (equal (car x) (car y))
331           (equal (cdr x) (cdr y))))
332     ((stringp x)
333      (and (stringp y) (string= x y)))
334     (t nil)))
335
336 (defun fdefinition (x)
337   (cond
338     ((functionp x)
339      x)
340     ((symbolp x)
341      (symbol-function x))
342     (t
343      (error "Invalid function `~S'." x))))
344
345 (defun disassemble (function)
346   (write-line (lambda-code (fdefinition function)))
347   nil)
348
349 (defmacro multiple-value-bind (variables value-from &body body)
350   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
351                           ,@body)
352      ,value-from))
353
354 (defmacro multiple-value-list (value-from)
355   `(multiple-value-call #'list ,value-from))
356
357
358 ;; Incorrect typecase, but used in NCONC.
359 (defmacro typecase (x &rest clausules)
360   (let ((value (gensym)))
361     `(let ((,value ,x))
362        (cond
363          ,@(mapcar (lambda (c)
364                      (if (find (car c) '(t otherwise))
365                          `(t ,@(rest c))
366                          `((,(ecase (car c)
367                                     (integer 'integerp)
368                                     (cons 'consp)
369                                     (list 'listp)
370                                     (vector 'vectorp)
371                                     (character 'characterp)
372                                     (sequence 'sequencep)
373                                     (symbol 'symbolp)
374                                     (function 'functionp)
375                                     (float 'floatp)
376                                     (array 'arrayp)
377                                     (string 'stringp)
378                                     (atom 'atom)
379                                     (null 'null)
380                                     (package 'packagep))
381                              ,value)
382                            ,@(or (rest c)
383                                  (list nil)))))
384                    clausules)))))
385
386 (defmacro etypecase (x &rest clausules)
387   (let ((g!x (gensym)))
388     `(let ((,g!x ,x))
389        (typecase ,g!x
390          ,@clausules
391          (t (error "~S fell through etypecase expression." ,g!x))))))
392
393 (defun notany (fn seq)
394   (not (some fn seq)))
395
396 (defconstant internal-time-units-per-second 1000)
397
398 (defun get-internal-real-time ()
399   (get-internal-real-time))
400
401 (defun get-unix-time ()
402   (truncate (/ (get-internal-real-time) 1000)))
403
404 (defun get-universal-time ()
405   (+ (get-unix-time) 2208988800))
406
407 (defun values-list (list)
408   (values-array (list-to-vector list)))
409
410 (defun values (&rest args)
411   (values-list args))
412
413 (defun error (fmt &rest args)
414   (%throw (apply #'format nil fmt args)))
415
416 (defmacro nth-value (n form)
417   `(multiple-value-call (lambda (&rest values)
418                           (nth ,n values))
419      ,form))