X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fboot.lisp;h=736c07dd35e2d4667787fff2d3cb6f970ab4aa20;hb=95984c591c75b8085adde1d478b224c2ed29eaa5;hp=1b3541cd10c1da24cc127d9f9c895999b5141a90;hpb=8d61c3934b3394a7596d6967ce8dfbdbc70bdc67;p=jscl.git

diff --git a/src/boot.lisp b/src/boot.lisp
index 1b3541c..736c07d 100644
--- a/src/boot.lisp
+++ b/src/boot.lisp
@@ -24,13 +24,13 @@
 
 (/debug "loading boot.lisp!")
 
-(eval-when-compile
+(eval-when (:compile-toplevel)
   (let ((defmacro-macroexpander
          '#'(lambda (form)
               (destructuring-bind (name args &body body)
                   form
                 (let ((whole (gensym)))
-                  `(eval-when-compile
+                  `(eval-when (:compile-toplevel :execute)
                      (%compile-defmacro ',name
                                         '#'(lambda (,whole)
                                              (destructuring-bind ,args ,whole
@@ -38,7 +38,7 @@
     (%compile-defmacro 'defmacro defmacro-macroexpander)))
 
 (defmacro declaim (&rest decls)
-  `(eval-when-compile
+  `(eval-when (:compile-toplevel :execute)
      ,@(mapcar (lambda (decl) `(!proclaim ',decl)) decls)))
 
 (defmacro defconstant (name value &optional docstring)
@@ -102,51 +102,13 @@
 
 (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)
-    (let ((d (gensym)))
-      `(let* (,@(mapcar #'list dummies vals)
-              (,d ,delta)
-                (,(car newval) (+ ,getter ,d))
-                ,@(cdr newval))
-         ,setter))))
-
-(defmacro decf (place &optional (delta 1))
-  (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-expansion place)
-    (let ((d (gensym)))
-      `(let* (,@(mapcar #'list dummies vals)
-              (,d ,delta)
-              (,(car newval) (- ,getter ,d))
-              ,@(cdr newval))
-         ,setter))))
+(defun funcall (function &rest args)
+  (apply function args))
 
-(defmacro push (x place)
-  (multiple-value-bind (dummies vals newval setter getter)
-      (get-setf-expansion place)
-    (let ((g (gensym)))
-      `(let* ((,g ,x)
-              ,@(mapcar #'list dummies vals)
-              (,(car newval) (cons ,g ,getter))
-              ,@(cdr newval))
-         ,setter))))
+(defun apply (function arg &rest args)
+  (apply function (apply #'list* arg args)))
 
-(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))))))
+;; Basic macros
 
 (defmacro dolist ((var list &optional result) &body body)
   (let ((g!list (gensym)))
@@ -250,28 +212,6 @@
          ,@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 append-two (list1 list2)
-  (if (null list1)
-      list2
-      (cons (car list1)
-            (append (cdr list1) list2))))
-
-(defun append (&rest lists)
-  (!reduce #'append-two lists nil))
-
-(defun revappend (list1 list2)
-  (while list1
-    (push (car list1) list2)
-    (setq list1 (cdr list1)))
-  list2)
-
-(defun reverse (list)
-  (revappend list '()))
-
 (defmacro psetq (&rest pairs)
   (let (;; For each pair, we store here a list of the form
         ;; (VARIABLE GENSYM VALUE).
@@ -325,22 +265,6 @@
                                   (list (first v) (third v))))
                            varlist)))))))
 
-(defun list-length (list)
-  (let ((l 0))
-    (while (not (null list))
-      (incf l)
-      (setq list (cdr list)))
-    l))
-
-(defun length (seq)
-  (cond
-    ((stringp seq)
-     (string-length seq))
-    ((arrayp seq)
-     (oget seq "length"))
-    ((listp seq)
-     (list-length seq))))
-
 (defmacro with-collect (&body body)
   (let ((head (gensym))
         (tail (gensym)))
@@ -430,29 +354,31 @@
 
 ;;; Generalized references (SETF)
 
-(defvar *setf-expanders* nil)
-
-(defun get-setf-expansion (place)
-  (if (symbolp place)
-      (let ((value (gensym)))
-        (values nil
-                nil
-                `(,value)
-                `(setq ,place ,value)
-                place))
-      (let ((place (!macroexpand-1 place)))
-        (let* ((access-fn (car place))
-               (expander (cdr (assoc access-fn *setf-expanders*))))
-          (when (null expander)
-            (error "Unknown generalized reference."))
-          (apply expander (cdr place))))))
+(eval-when(:compile-toplevel :load-toplevel :execute)
+  (defvar *setf-expanders* nil)
+  (defun !get-setf-expansion (place)
+    (if (symbolp place)
+        (let ((value (gensym)))
+          (values nil
+                  nil
+                  `(,value)
+                  `(setq ,place ,value)
+                  place))
+        (let ((place (!macroexpand-1 place)))
+          (let* ((access-fn (car place))
+                 (expander (cdr (assoc access-fn *setf-expanders*))))
+            (when (null expander)
+              (error "Unknown generalized reference."))
+            (apply expander (cdr place)))))))
+(fset 'get-setf-expansion (fdefinition '!get-setf-expansion))
 
 (defmacro define-setf-expander (access-fn lambda-list &body body)
   (unless (symbolp access-fn)
     (error "ACCESS-FN `~S' must be a symbol." access-fn))
-  `(progn (push (cons ',access-fn (lambda ,lambda-list ,@body))
-                *setf-expanders*)
-          ',access-fn))
+  `(eval-when (:compile-toplevel :load-toplevel :execute)
+     (push (cons ',access-fn (lambda ,lambda-list ,@body))
+           *setf-expanders*)
+     ',access-fn))
 
 (defmacro setf (&rest pairs)
   (cond
@@ -464,7 +390,7 @@
      (let ((place (!macroexpand-1 (first pairs)))
            (value (second pairs)))
        (multiple-value-bind (vars vals store-vars writer-form reader-form)
-           (get-setf-expansion place)
+           (!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)
@@ -479,6 +405,64 @@
               ((null pairs)
                (reverse result)))))))
 
+(defmacro incf (place &optional (delta 1))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+                (,(car newval) (+ ,getter ,d))
+                ,@(cdr newval))
+         ,setter))))
+
+(defmacro decf (place &optional (delta 1))
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((d (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,d ,delta)
+              (,(car newval) (- ,getter ,d))
+              ,@(cdr newval))
+         ,setter))))
+
+(defmacro push (x place)
+  (multiple-value-bind (dummies vals newval setter getter)
+      (!get-setf-expansion place)
+    (let ((g (gensym)))
+      `(let* ((,g ,x)
+              ,@(mapcar #'list dummies vals)
+              (,(car newval) (cons ,g ,getter))
+              ,@(cdr newval))
+         ,setter))))
+
+(defmacro pop (place)
+  (multiple-value-bind (dummies vals newval setter getter)
+    (!get-setf-expansion place)
+    (let ((head (gensym)))
+      `(let* (,@(mapcar #'list dummies vals)
+              (,head ,getter)
+              (,(car newval) (cdr ,head))
+              ,@(cdr newval))
+         ,setter
+         (car ,head)))))
+
+(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))))))
+
+
+
 ;; Incorrect typecase, but used in NCONC.
 (defmacro typecase (x &rest clausules)
   (let ((value (gensym)))
@@ -517,7 +501,7 @@
 (defun notany (fn seq)
   (not (some fn seq)))
 
-(defconstant internal-time-units-per-second 1000) 
+(defconstant internal-time-units-per-second 1000)
 
 (defun get-internal-real-time ()
   (get-internal-real-time))