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