X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=3541b23a863e800e602dc220d4542eb2eba185b3;hb=030869df1e9829e0b284b96e585bdda7d45e0602;hp=8c1d6c2780e81f07f278ca5745ec42cf67fb9078;hpb=6d86a4367eb3ea3e7a33284c9f86cf06c01105be;p=jscl.git

diff --git a/src/boot.lisp b/src/boot.lisp
index 8c1d6c2..3541b23 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -22,6 +22,8 @@
 ;;; 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
   (let ((defmacro-macroexpander
          '#'(lambda (form)
@@ -44,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)
@@ -60,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)
@@ -87,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)
@@ -139,6 +133,21 @@
               ,@(cdr newval))
          ,setter))))
 
+(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))
@@ -163,28 +172,35 @@
          ,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)
@@ -227,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
@@ -283,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))))
@@ -291,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))))
@@ -305,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)))))))
 
@@ -325,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)))
@@ -346,6 +359,10 @@
 
 (defun identity (x) x)
 
+(defun complement (x)
+  (lambda (&rest args)
+    (not (apply x args))))
+
 (defun constantly (x)
   (lambda (&rest args)
     x))
@@ -359,49 +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 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 #\Z) (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)))
@@ -412,59 +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 find (item sequence &key (key #'identity) (test #'eql))
-  (do-sequence (x sequence)
-    (when (funcall test (funcall key x) item)
-      (return x))))
-
-(defun find-if (predicate sequence &key (key #'identity))
-  (do-sequence (x sequence)
-    (when (funcall predicate (funcall key x))
-      (return x))))
-
-(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)
@@ -544,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))
@@ -566,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)
@@ -585,7 +518,7 @@
     `(let ((,g!x ,x))
        (typecase ,g!x
          ,@clausules
-         (t (error "~X fell through etypeacase expression." ,g!x))))))
+         (t (error "~X fell through etypecase expression." ,g!x))))))
 
 (defun notany (fn seq)
   (not (some fn seq)))
@@ -601,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)))
 
@@ -613,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))