X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=3541b23a863e800e602dc220d4542eb2eba185b3;hb=25d3ce6406a74dca652ff4bb27f025986626958a;hp=14d0ab90d5a97cc95186ecc16d97aad041131626;hpb=4410f136fe0502076d71b92a12774783ccdf6a4e;p=jscl.git

diff --git a/src/boot.lisp b/src/boot.lisp
index 14d0ab9..3541b23 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -22,19 +22,20 @@
 ;;; Lisp world from scratch. This code has to define enough language
 ;;; to the compiler to be able to run.
 
+(/debug "loading boot.lisp!")
+
 (eval-when-compile
-  (%compile-defmacro 'defmacro
-                     '(function
-                       (lambda (name args &rest body)
-                        `(eval-when-compile
-                           (%compile-defmacro ',name
-                                              '(function
-                                                (lambda ,(mapcar #'(lambda (x)
-                                                                     (if (eq x '&body)
-                                                                         '&rest
-                                                                         x))
-                                                                 args)
-                                                 ,@body))))))))
+  (let ((defmacro-macroexpander
+         '#'(lambda (form)
+              (destructuring-bind (name args &body body)
+                  form
+                (let ((whole (gensym)))
+                  `(eval-when-compile
+                     (%compile-defmacro ',name
+                                        '#'(lambda (,whole)
+                                             (destructuring-bind ,args ,whole
+                                               ,@body)))))))))
+    (%compile-defmacro 'defmacro defmacro-macroexpander)))
 
 (defmacro declaim (&rest decls)
   `(eval-when-compile
@@ -45,7 +46,7 @@
      (declaim (special ,name))
      (declaim (constant ,name))
      (setq ,name ,value)
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defconstant t 't)
@@ -61,17 +62,17 @@
 (defmacro unless (condition &body body)
   `(if ,condition nil (progn ,@body)))
 
-(defmacro defvar (name value &optional docstring)
+(defmacro defvar (name &optional (value nil value-p) docstring)
   `(progn
      (declaim (special ,name))
-     (unless (boundp ',name) (setq ,name ,value))
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when value-p `((unless (boundp ',name) (setq ,name ,value))))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defmacro defparameter (name value &optional docstring)
   `(progn
      (setq ,name ,value)
-     ,@(when (stringp docstring) `((oset ',name "vardoc" ,docstring)))
+     ,@(when (stringp docstring) `((oset ,docstring ',name "vardoc")))
      ',name))
 
 (defmacro defun (name args &rest body)
@@ -88,28 +89,20 @@
 (defvar *gensym-counter* 0)
 (defun gensym (&optional (prefix "G"))
   (setq *gensym-counter* (+ *gensym-counter* 1))
-  (make-symbol (concat-two prefix (integer-to-string *gensym-counter*))))
+  (make-symbol (concat prefix (integer-to-string *gensym-counter*))))
 
 (defun boundp (x)
   (boundp x))
 
-;; Basic functions
-(defun = (x y) (= x y))
-(defun * (x y) (* x y))
-(defun / (x y) (/ x y))
-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
-(defun zerop (x) (= x 0))
-
-(defun truncate (x &optional (y 1))
-  (floor (/ x y)))
+(defun fboundp (x)
+  (fboundp x))
 
+(defun eq (x y) (eq x y))
 (defun eql (x y) (eq x y))
 
 (defun not (x) (if x nil t))
 
 ;; Basic macros
-
 (defmacro incf (place &optional (delta 1))
   (multiple-value-bind (dummies vals newval setter getter)
       (get-setf-expansion place)
@@ -140,54 +133,74 @@
               ,@(cdr newval))
          ,setter))))
 
-(defmacro dolist (iter &body body)
-  (let ((var (first iter))
-        (g!list (gensym)))
+(defmacro pushnew (x place &rest keys &key key test test-not)
+  (declare (ignore key test test-not))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (get-setf-expansion place)
+    (let ((g (gensym))
+          (v (gensym)))
+      `(let* ((,g ,x)
+              ,@(mapcar #'list dummies vals)
+              ,@(cdr newval)
+              (,v ,getter))
+         (if (member ,g ,v ,@keys)
+             ,v
+             (let ((,(car newval) (cons ,g ,getter)))
+               ,setter))))))
+
+(defmacro dolist ((var list &optional result) &body body)
+  (let ((g!list (gensym)))
+    (unless (symbolp var) (error "`~S' is not a symbol." var))
     `(block nil
-       (let ((,g!list ,(second iter))
+       (let ((,g!list ,list)
              (,var nil))
          (%while ,g!list
                  (setq ,var (car ,g!list))
                  (tagbody ,@body)
                  (setq ,g!list (cdr ,g!list)))
-         ,(third iter)))))
+         ,result))))
 
-(defmacro dotimes (iter &body body)
-  (let ((g!to (gensym))
-        (var (first iter))
-        (to (second iter))
-        (result (third iter)))
+(defmacro dotimes ((var count &optional result) &body body)
+  (let ((g!count (gensym)))
+    (unless (symbolp var) (error "`~S' is not a symbol." var))
     `(block nil
        (let ((,var 0)
-             (,g!to ,to))
-         (%while (< ,var ,g!to)
+             (,g!count ,count))
+         (%while (< ,var ,g!count)
                  (tagbody ,@body)
                  (incf ,var))
          ,result))))
 
 (defmacro cond (&rest clausules)
-  (if (null clausules)
-    nil
-    (if (eq (caar clausules) t)
-      `(progn ,@(cdar clausules))
-      (let ((test-symbol (gensym)))
-        `(let ((,test-symbol ,(caar clausules)))
-           (if ,test-symbol
-             ,(if (null (cdar clausules))
-                test-symbol
-                `(progn ,@(cdar clausules)))
-             (cond ,@(cdr clausules))))))))
+  (unless (null clausules)
+    (destructuring-bind (condition &body body)
+        (first clausules)
+      (cond
+        ((eq condition t)
+         `(progn ,@body))
+        ((null body)
+         (let ((test-symbol (gensym)))
+           `(let ((,test-symbol ,condition))
+              (if ,test-symbol
+                  ,test-symbol
+                  (cond ,@(rest clausules))))))
+        (t
+         `(if ,condition
+              (progn ,@body)
+              (cond ,@(rest clausules))))))))
 
 (defmacro case (form &rest clausules)
   (let ((!form (gensym)))
     `(let ((,!form ,form))
        (cond
          ,@(mapcar (lambda (clausule)
-                     (if (or (eq (car clausule) t)
-                             (eq (car clausule) 'otherwise))
-                         `(t ,@(cdr clausule))
-                         `((eql ,!form ',(car clausule))
-                           ,@(cdr clausule))))
+                     (destructuring-bind (keys &body body)
+                         clausule
+                       (if (or (eq keys 't) (eq keys 'otherwise))
+                           `(t nil ,@body)
+                           (let ((keys (if (listp keys) keys (list keys))))
+                             `((or ,@(mapcar (lambda (key) `(eql ,!form ',key)) keys))
+                               nil ,@body)))))
                    clausules)))))
 
 (defmacro ecase (form &rest clausules)
@@ -230,23 +243,17 @@
 (defmacro prog2 (form1 result &body body)
   `(prog1 (progn ,form1 ,result) ,@body))
 
+(defmacro prog (inits &rest body )
+  (multiple-value-bind (forms decls docstring) (parse-body body)
+    `(block nil
+       (let ,inits
+         ,@decls
+         (tagbody ,@forms)))))
 
 
 ;;; Go on growing the Lisp language in Ecmalisp, with more high level
 ;;; utilities as well as correct versions of other constructions.
 
-(defun + (&rest args)
-  (let ((r 0))
-    (dolist (x args r)
-      (incf r x))))
-
-(defun - (x &rest others)
-  (if (null others)
-      (- x)
-      (let ((r x))
-        (dolist (y others r)
-          (decf r y)))))
-
 (defun append-two (list1 list2)
   (if (null list1)
       list2
@@ -286,7 +293,9 @@
 
 (defmacro do (varlist endlist &body body)
   `(block nil
-     (let ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+     (let ,(mapcar (lambda (x) (if (symbolp x)
+                                   (list x nil)
+                                 (list (first x) (second x)))) varlist)
        (while t
          (when ,(car endlist)
            (return (progn ,@(cdr endlist))))
@@ -294,13 +303,16 @@
          (psetq
           ,@(apply #'append
                    (mapcar (lambda (v)
-                             (and (consp (cddr v))
+                             (and (listp v)
+                                  (consp (cddr v))
                                   (list (first v) (third v))))
                            varlist)))))))
 
 (defmacro do* (varlist endlist &body body)
   `(block nil
-     (let* ,(mapcar (lambda (x) (list (first x) (second x))) varlist)
+     (let* ,(mapcar (lambda (x1) (if (symbolp x1)
+                                     (list x1 nil)
+                                   (list (first x1) (second x1)))) varlist)
        (while t
          (when ,(car endlist)
            (return (progn ,@(cdr endlist))))
@@ -308,7 +320,8 @@
          (setq
           ,@(apply #'append
                    (mapcar (lambda (v)
-                             (and (consp (cddr v))
+                             (and (listp v)
+                                  (consp (cddr v))
                                   (list (first v) (third v))))
                            varlist)))))))
 
@@ -328,9 +341,6 @@
     ((listp seq)
      (list-length seq))))
 
-(defun concat-two (s1 s2)
-  (concat-two s1 s2))
-
 (defmacro with-collect (&body body)
   (let ((head (gensym))
         (tail (gensym)))
@@ -349,6 +359,10 @@
 
 (defun identity (x) x)
 
+(defun complement (x)
+  (lambda (&rest args)
+    (not (apply x args))))
+
 (defun constantly (x)
   (lambda (&rest args)
     x))
@@ -362,50 +376,15 @@
 (defun char= (x y)
   (eql x y))
 
-(defun integerp (x)
-  (and (numberp x) (= (floor x) x)))
-
-(defun floatp (x)
-  (and (numberp x) (not (integerp x))))
-
-(defun plusp (x) (< 0 x))
-(defun minusp (x) (< x 0))
+(defun char< (x y)
+  (< (char-code x) (char-code y)))
 
 (defun atom (x)
   (not (consp x)))
 
-(defun find (item list &key (key #'identity) (test #'eql))
-  (dolist (x list)
-    (when (funcall test (funcall key x) item)
-      (return x))))
-
-(defun remove (x list)
-  (cond
-    ((null list)
-     nil)
-    ((eql x (car list))
-     (remove x (cdr list)))
-    (t
-     (cons (car list) (remove x (cdr list))))))
-
-(defun remove-if (func list)
-  (cond
-    ((null list)
-     nil)
-    ((funcall func (car list))
-     (remove-if func (cdr list)))
-    (t
-     ;;
-     (cons (car list) (remove-if func (cdr list))))))
-
-(defun remove-if-not (func list)
-  (cond
-    ((null list)
-     nil)
-    ((funcall func (car list))
-     (cons (car list) (remove-if-not func (cdr list))))
-    (t
-     (remove-if-not func (cdr list)))))
+(defun alpha-char-p (x)
+  (or (<= (char-code #\a) (char-code x) (char-code #\z))
+      (<= (char-code #\A) (char-code x) (char-code #\Z))))
 
 (defun digit-char-p (x)
   (if (and (<= (char-code #\0) (char-code x) (char-code #\9)))
@@ -416,49 +395,6 @@
   (and (<= 0 weight 9)
        (char "0123456789" weight)))
 
-(defun subseq (seq a &optional b)
-  (if b
-      (slice seq a b)
-      (slice seq a)))
-
-(defmacro do-sequence (iteration &body body)
-  (let ((seq (gensym))
-        (index (gensym)))
-    `(let ((,seq ,(second iteration)))
-       (cond
-         ;; Strings
-         ((stringp ,seq)
-          (let ((,index 0))
-            (dotimes (,index (length ,seq))
-              (let ((,(first iteration)
-                     (char ,seq ,index)))
-                ,@body))))
-         ;; Lists
-         ((listp ,seq)
-          (dolist (,(first iteration) ,seq)
-            ,@body))
-         (t
-          (error "type-error!"))))))
-
-(defun some (function seq)
-  (do-sequence (elt seq)
-    (when (funcall function elt)
-      (return-from some t))))
-
-(defun every (function seq)
-  (do-sequence (elt seq)
-    (unless (funcall function elt)
-      (return-from every nil)))
-  t)
-
-(defun position (elt sequence)
-  (let ((pos 0))
-    (do-sequence (x seq)
-      (when (eq elt x)
-        (return))
-      (incf pos))
-    pos))
-
 (defun equal (x y)
   (cond
     ((eql x y) t)
@@ -538,14 +474,15 @@
     ((null (cddr pairs))
      (let ((place (!macroexpand-1 (first pairs)))
            (value (second pairs)))
-       (multiple-value-bind (vars vals store-vars writer-form)
+       (multiple-value-bind (vars vals store-vars writer-form reader-form)
            (get-setf-expansion place)
          ;; TODO: Optimize the expansion a little bit to avoid let*
          ;; or multiple-value-bind when unnecesary.
          `(let* ,(mapcar #'list vars vals)
             (multiple-value-bind ,store-vars
                 ,value
-              ,writer-form)))))
+              ,writer-form
+              ,reader-form)))))
     (t
      `(progn
         ,@(do ((pairs pairs (cddr pairs))
@@ -560,11 +497,13 @@
        (cond
          ,@(mapcar (lambda (c)
                      (if (eq (car c) t)
-                         `((t ,@(rest c)))
+                         `(t ,@(rest c))
                          `((,(ecase (car c)
                                     (integer 'integerp)
                                     (cons 'consp)
                                     (symbol 'symbolp)
+                                    (function 'functionp)
+                                    (float 'floatp)
                                     (array 'arrayp)
                                     (string 'stringp)
                                     (atom 'atom)
@@ -574,10 +513,16 @@
                                  (list nil)))))
                    clausules)))))
 
+(defmacro etypecase (x &rest clausules)
+  (let ((g!x (gensym)))
+    `(let ((,g!x ,x))
+       (typecase ,g!x
+         ,@clausules
+         (t (error "~X fell through etypecase expression." ,g!x))))))
+
 (defun notany (fn seq)
   (not (some fn seq)))
 
-
 (defconstant internal-time-units-per-second 1000) 
 
 (defun get-internal-real-time ()
@@ -589,9 +534,6 @@
 (defun get-universal-time ()
   (+ (get-unix-time) 2208988800))
 
-(defun concat (&rest strs)
-  (!reduce #'concat-two strs ""))
-
 (defun values-list (list)
   (values-array (list-to-vector list)))
 
@@ -601,3 +543,7 @@
 (defun error (fmt &rest args)
   (%throw (apply #'format nil fmt args)))
 
+(defmacro nth-value (n form)
+  `(multiple-value-call (lambda (&rest values)
+                          (nth ,n values))
+     ,form))