cb964e4413c2ef06d7bfbced9c6ffb2b4d6ace10
[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
56 (defmacro lambda (args &body body)
57   `(function (lambda ,args ,@body)))
58
59 (defmacro when (condition &body body)
60   `(if ,condition (progn ,@body) nil))
61
62 (defmacro unless (condition &body body)
63   `(if ,condition nil (progn ,@body)))
64
65 (defmacro defvar (name &optional (value nil value-p) docstring)
66   `(progn
67      (declaim (special ,name))
68      ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
69      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
70      ',name))
71
72 (defmacro defparameter (name value &optional docstring)
73   `(progn
74      (setq ,name ,value)
75      ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
76      ',name))
77
78 (defmacro defun (name args &rest body)
79   `(progn
80      (fset ',name #'(named-lambda ,name ,args ,@body))
81      ',name))
82
83 (defmacro return (&optional value)
84   `(return-from nil ,value))
85
86 (defmacro while (condition &body body)
87   `(block nil (%while ,condition ,@body)))
88
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*))))
93
94 (defun boundp (x)
95   (boundp x))
96
97 (defun fboundp (x)
98   (fboundp x))
99
100 (defun eq (x y) (eq x y))
101 (defun eql (x y) (eq x y))
102
103 (defun not (x) (if x nil t))
104
105 ;; Basic macros
106
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))
110     `(block nil
111        (let ((,g!list ,list)
112              (,var nil))
113          (%while ,g!list
114                  (setq ,var (car ,g!list))
115                  (tagbody ,@body)
116                  (setq ,g!list (cdr ,g!list)))
117          ,result))))
118
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))
122     `(block nil
123        (let ((,var 0)
124              (,g!count ,count))
125          (%while (< ,var ,g!count)
126                  (tagbody ,@body)
127                  (incf ,var))
128          ,result))))
129
130 (defmacro cond (&rest clausules)
131   (unless (null clausules)
132     (destructuring-bind (condition &body body)
133         (first clausules)
134       (cond
135         ((eq condition t)
136          `(progn ,@body))
137         ((null body)
138          (let ((test-symbol (gensym)))
139            `(let ((,test-symbol ,condition))
140               (if ,test-symbol
141                   ,test-symbol
142                   (cond ,@(rest clausules))))))
143         (t
144          `(if ,condition
145               (progn ,@body)
146               (cond ,@(rest clausules))))))))
147
148 (defmacro case (form &rest clausules)
149   (let ((!form (gensym)))
150     `(let ((,!form ,form))
151        (cond
152          ,@(mapcar (lambda (clausule)
153                      (destructuring-bind (keys &body body)
154                          clausule
155                        (if (or (eq keys 't) (eq keys 'otherwise))
156                            `(t nil ,@body)
157                            (let ((keys (if (listp keys) keys (list keys))))
158                              `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
159                                nil ,@body)))))
160                    clausules)))))
161
162 (defmacro ecase (form &rest clausules)
163   (let ((g!form (gensym)))
164     `(let ((,g!form ,form))
165        (case ,g!form
166          ,@(append
167             clausules
168             `((t
169                (error "ECASE expression failed for the object `~S'." ,g!form))))))))
170
171 (defmacro and (&rest forms)
172   (cond
173     ((null forms)
174      t)
175     ((null (cdr forms))
176      (car forms))
177     (t
178      `(if ,(car forms)
179           (and ,@(cdr forms))
180           nil))))
181
182 (defmacro or (&rest forms)
183   (cond
184     ((null forms)
185      nil)
186     ((null (cdr forms))
187      (car forms))
188     (t
189      (let ((g (gensym)))
190        `(let ((,g ,(car forms)))
191           (if ,g ,g (or ,@(cdr forms))))))))
192
193 (defmacro prog1 (form &body body)
194   (let ((value (gensym)))
195     `(let ((,value ,form))
196        ,@body
197        ,value)))
198
199 (defmacro prog2 (form1 result &body body)
200   `(prog1 (progn ,form1 ,result) ,@body))
201
202 (defmacro prog (inits &rest body )
203   (multiple-value-bind (forms decls docstring) (parse-body body)
204     `(block nil
205        (let ,inits
206          ,@decls
207          (tagbody ,@forms)))))
208
209 (defmacro psetq (&rest pairs)
210   (let (;; For each pair, we store here a list of the form
211         ;; (VARIABLE GENSYM VALUE).
212         (assignments '()))
213     (while t
214       (cond
215         ((null pairs) (return))
216         ((null (cdr pairs))
217          (error "Odd paris in PSETQ"))
218         (t
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))
224     ;;
225     `(let ,(mapcar #'cdr assignments)
226        (setq ,@(!reduce #'append (mapcar #'butlast assignments) nil)))))
227
228 (defmacro do (varlist endlist &body body)
229   `(block nil
230      (let ,(mapcar (lambda (x) (if (symbolp x)
231                                    (list x nil)
232                                  (list (first x) (second x)))) varlist)
233        (while t
234          (when ,(car endlist)
235            (return (progn ,@(cdr endlist))))
236          (tagbody ,@body)
237          (psetq
238           ,@(apply #'append
239                    (mapcar (lambda (v)
240                              (and (listp v)
241                                   (consp (cddr v))
242                                   (list (first v) (third v))))
243                            varlist)))))))
244
245 (defmacro do* (varlist endlist &body body)
246   `(block nil
247      (let* ,(mapcar (lambda (x1) (if (symbolp x1)
248                                      (list x1 nil)
249                                    (list (first x1) (second x1)))) varlist)
250        (while t
251          (when ,(car endlist)
252            (return (progn ,@(cdr endlist))))
253          (tagbody ,@body)
254          (setq
255           ,@(apply #'append
256                    (mapcar (lambda (v)
257                              (and (listp v)
258                                   (consp (cddr v))
259                                   (list (first v) (third v))))
260                            varlist)))))))
261
262 (defmacro with-collect (&body body)
263   (let ((head (gensym))
264         (tail (gensym)))
265     `(let* ((,head (cons 'sentinel nil))
266             (,tail ,head))
267        (flet ((collect (x)
268                 (rplacd ,tail (cons x nil))
269                 (setq ,tail (cdr ,tail))
270                 x))
271          ,@body)
272        (cdr ,head))))
273
274
275 (defmacro loop (&body body)
276   `(while t ,@body))
277
278 (defun identity (x) x)
279
280 (defun complement (x)
281   (lambda (&rest args)
282     (not (apply x args))))
283
284 (defun constantly (x)
285   (lambda (&rest args)
286     x))
287
288 (defun code-char (x)
289   (code-char x))
290
291 (defun char-code (x)
292   (char-code x))
293
294 (defun char= (x y)
295   (eql x y))
296
297 (defun char< (x y)
298   (< (char-code x) (char-code y)))
299
300 (defun atom (x)
301   (not (consp x)))
302
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))))
306
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))
310       nil))
311
312 (defun digit-char (weight)
313   (and (<= 0 weight 9)
314        (char "0123456789" weight)))
315
316 (defun equal (x y)
317   (cond
318     ((eql x y) t)
319     ((consp x)
320      (and (consp y)
321           (equal (car x) (car y))
322           (equal (cdr x) (cdr y))))
323     ((stringp x)
324      (and (stringp y) (string= x y)))
325     (t nil)))
326
327 (defun fdefinition (x)
328   (cond
329     ((functionp x)
330      x)
331     ((symbolp x)
332      (symbol-function x))
333     (t
334      (error "Invalid function `~S'." x))))
335
336 (defun disassemble (function)
337   (write-line (lambda-code (fdefinition function)))
338   nil)
339
340 (defmacro multiple-value-bind (variables value-from &body body)
341   `(multiple-value-call (lambda (&optional ,@variables &rest ,(gensym))
342                           ,@body)
343      ,value-from))
344
345 (defmacro multiple-value-list (value-from)
346   `(multiple-value-call #'list ,value-from))
347
348
349 ;;; Generalized references (SETF)
350
351 (defvar *setf-expanders* nil)
352
353 (defun get-setf-expansion (place)
354   (if (symbolp place)
355       (let ((value (gensym)))
356         (values nil
357                 nil
358                 `(,value)
359                 `(setq ,place ,value)
360                 place))
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))))))
367
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))
372                 *setf-expanders*)
373           ',access-fn))
374
375 (defmacro setf (&rest pairs)
376   (cond
377     ((null pairs)
378      nil)
379     ((null (cdr pairs))
380      (error "Odd number of arguments to setf."))
381     ((null (cddr pairs))
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
390                 ,value
391               ,writer-form
392               ,reader-form)))))
393     (t
394      `(progn
395         ,@(do ((pairs pairs (cddr pairs))
396                (result '() (cons `(setf ,(car pairs) ,(cadr pairs)) result)))
397               ((null pairs)
398                (reverse result)))))))
399
400 (defmacro incf (place &optional (delta 1))
401   (multiple-value-bind (dummies vals newval setter getter)
402       (get-setf-expansion place)
403     (let ((d (gensym)))
404       `(let* (,@(mapcar #'list dummies vals)
405               (,d ,delta)
406                 (,(car newval) (+ ,getter ,d))
407                 ,@(cdr newval))
408          ,setter))))
409
410 (defmacro decf (place &optional (delta 1))
411   (multiple-value-bind (dummies vals newval setter getter)
412       (get-setf-expansion place)
413     (let ((d (gensym)))
414       `(let* (,@(mapcar #'list dummies vals)
415               (,d ,delta)
416               (,(car newval) (- ,getter ,d))
417               ,@(cdr newval))
418          ,setter))))
419
420 (defmacro push (x place)
421   (multiple-value-bind (dummies vals newval setter getter)
422       (get-setf-expansion place)
423     (let ((g (gensym)))
424       `(let* ((,g ,x)
425               ,@(mapcar #'list dummies vals)
426               (,(car newval) (cons ,g ,getter))
427               ,@(cdr newval))
428          ,setter))))
429
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)
435               (,head ,getter)
436               (,(car newval) (cdr ,head))
437               ,@(cdr newval))
438          ,setter
439          (car ,head)))))
440
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)
445     (let ((g (gensym))
446           (v (gensym)))
447       `(let* ((,g ,x)
448               ,@(mapcar #'list dummies vals)
449               ,@(cdr newval)
450               (,v ,getter))
451          (if (member ,g ,v ,@keys)
452              ,v
453              (let ((,(car newval) (cons ,g ,getter)))
454                ,setter))))))
455
456
457
458 ;; Incorrect typecase, but used in NCONC.
459 (defmacro typecase (x &rest clausules)
460   (let ((value (gensym)))
461     `(let ((,value ,x))
462        (cond
463          ,@(mapcar (lambda (c)
464                      (if (find (car c) '(t otherwise))
465                          `(t ,@(rest c))
466                          `((,(ecase (car c)
467                                     (integer 'integerp)
468                                     (cons 'consp)
469                                     (list 'listp)
470                                     (vector 'vectorp)
471                                     (character 'characterp)
472                                     (sequence 'sequencep)
473                                     (symbol 'symbolp)
474                                     (function 'functionp)
475                                     (float 'floatp)
476                                     (array 'arrayp)
477                                     (string 'stringp)
478                                     (atom 'atom)
479                                     (null 'null)
480                                     (package 'packagep))
481                              ,value)
482                            ,@(or (rest c)
483                                  (list nil)))))
484                    clausules)))))
485
486 (defmacro etypecase (x &rest clausules)
487   (let ((g!x (gensym)))
488     `(let ((,g!x ,x))
489        (typecase ,g!x
490          ,@clausules
491          (t (error "~S fell through etypecase expression." ,g!x))))))
492
493 (defun notany (fn seq)
494   (not (some fn seq)))
495
496 (defconstant internal-time-units-per-second 1000)
497
498 (defun get-internal-real-time ()
499   (get-internal-real-time))
500
501 (defun get-unix-time ()
502   (truncate (/ (get-internal-real-time) 1000)))
503
504 (defun get-universal-time ()
505   (+ (get-unix-time) 2208988800))
506
507 (defun values-list (list)
508   (values-array (list-to-vector list)))
509
510 (defun values (&rest args)
511   (values-list args))
512
513 (defun error (fmt &rest args)
514   (%throw (apply #'format nil fmt args)))
515
516 (defmacro nth-value (n form)
517   `(multiple-value-call (lambda (&rest values)
518                           (nth ,n values))
519      ,form))