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