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