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