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