0.6.11.45:

[sbcl.git] / src / code / boot-extensions.lisp

diff --git a/src/code/boot-extensions.lisp b/src/code/boot-extensions.lisp
index 4dfc372..be509c6 100644 (file)
--- a/src/code/boot-extensions.lisp
+++ b/src/code/boot-extensions.lisp
@@ -9,20 +9,48 @@
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 
 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
 ;;;; files for more information.
 

-(in-package "SB!EXT")
+(in-package "SB!IMPL")

 
 

-;;; Lots of code wants to get to the KEYWORD package or the COMMON-LISP package
-;;; without a lot of fuss, so we cache them in variables. TO DO: How much
-;;; does this actually buy us? It sounds sensible, but I don't know for sure
-;;; that it saves space or time.. -- WHN 19990521
+;;; Lots of code wants to get to the KEYWORD package or the
+;;; COMMON-LISP package without a lot of fuss, so we cache them in
+;;; variables. TO DO: How much does this actually buy us? It sounds
+;;; sensible, but I don't know for sure that it saves space or time..
+;;; -- WHN 19990521
+;;;
+;;; (The initialization forms here only matter on the cross-compilation
+;;; host; In the target SBCL, these variables are set in cold init.)

 (declaim (type package *cl-package* *keyword-package*))
 (declaim (type package *cl-package* *keyword-package*))

-(defvar *cl-package*        (find-package "COMMON-LISP"))
-(defvar *keyword-package*   (find-package "KEYWORD"))
+(defvar *cl-package*      (find-package "COMMON-LISP"))
+(defvar *keyword-package* (find-package "KEYWORD"))
+
+;;; a helper function for various macros which expect clauses of a
+;;; given length, etc.
+;;;
+;;; FIXME: This implementation will hang on circular list structure.
+;;; Since this is an error-checking utility, i.e. its job is to deal
+;;; with screwed-up input, it'd be good style to fix it so that it can
+;;; deal with circular list structure.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  ;; Return true if X is a proper list whose length is between MIN and
+  ;; MAX (inclusive).
+  (defun proper-list-of-length-p (x min &optional (max min))
+    (cond ((minusp max)
+          nil)
+         ((null x)
+          (zerop min))
+         ((consp x)
+          (and (plusp max)
+               (proper-list-of-length-p (cdr x)
+                                        (if (plusp (1- min))
+                                          (1- min)
+                                          0)
+                                        (1- max))))
+         (t nil))))

 \f
 ;;;; the COLLECT macro
 
 \f
 ;;;; the COLLECT macro
 

-;;; helper functions for COLLECT, which become the expanders of the MACROLET
-;;; definitions created by COLLECT
+;;; helper functions for COLLECT, which become the expanders of the
+;;; MACROLET definitions created by COLLECT

 ;;;
 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
 ;;;
 ;;;
 ;;; COLLECT-NORMAL-EXPANDER handles normal collection macros.
 ;;;

@@ -95,48 +123,42 @@
                macros))))
     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
 \f
                macros))))
     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
 \f

+;;; This function can be used as the default value for keyword
+;;; arguments that must be always be supplied. Since it is known by
+;;; the compiler to never return, it will avoid any compile-time type
+;;; warnings that would result from a default value inconsistent with
+;;; the declared type. When this function is called, it signals an
+;;; error indicating that a required &KEY argument was not supplied.
+;;; This function is also useful for DEFSTRUCT slot defaults
+;;; corresponding to required arguments.

 (declaim (ftype (function () nil) required-argument))
 (defun required-argument ()
   #!+sb-doc
 (declaim (ftype (function () nil) required-argument))
 (defun required-argument ()
   #!+sb-doc

-  "This function can be used as the default value for keyword arguments that
-  must be always be supplied. Since it is known by the compiler to never
-  return, it will avoid any compile-time type warnings that would result from a
-  default value inconsistent with the declared type. When this function is
-  called, it signals an error indicating that a required keyword argument was
-  not supplied. This function is also useful for DEFSTRUCT slot defaults
-  corresponding to required arguments."

   (/show0 "entering REQUIRED-ARGUMENT")
   (/show0 "entering REQUIRED-ARGUMENT")

-  (error "A required keyword argument was not supplied."))
+  (error "A required &KEY argument was not supplied."))

 \f
 \f

-;;; "the ultimate iteration macro"
+;;; "the ultimate iteration macro" 

 ;;;
 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".
 ;;;
 ;;; note for Schemers: This seems to be identical to Scheme's "named LET".

-(defmacro iterate (name binds &body body)
+(defmacro named-let (name binds &body body)

   #!+sb-doc
   #!+sb-doc

-  "Iterate Name ({(Var Initial-Value)}*) Declaration* Form*
-  This is syntactic sugar for Labels. It creates a local function Name with
-  the specified Vars as its arguments and the Declarations and Forms as its
-  body. This function is then called with the Initial-Values, and the result
-  of the call is returned from the macro."

   (dolist (x binds)
     (unless (proper-list-of-length-p x 2)
       (error "Malformed ITERATE variable spec: ~S." x)))
   `(labels ((,name ,(mapcar #'first binds) ,@body))
      (,name ,@(mapcar #'second binds))))
   (dolist (x binds)
     (unless (proper-list-of-length-p x 2)
       (error "Malformed ITERATE variable spec: ~S." x)))
   `(labels ((,name ,(mapcar #'first binds) ,@body))
      (,name ,@(mapcar #'second binds))))

-\f
-;;; Once-Only is a utility useful in writing source transforms and macros.
-;;; It provides an easy way to wrap a LET around some code to ensure that some
-;;; forms are only evaluated once.
+
+;;; ONCE-ONLY is a utility useful in writing source transforms and
+;;; macros. It provides a concise way to wrap a LET around some code
+;;; to ensure that some forms are only evaluated once.
+;;;
+;;; Create a LET* which evaluates each value expression, binding a
+;;; temporary variable to the result, and wrapping the LET* around the
+;;; result of the evaluation of BODY. Within the body, each VAR is
+;;; bound to the corresponding temporary variable.

 (defmacro once-only (specs &body body)
 (defmacro once-only (specs &body body)

-  #!+sb-doc
-  "Once-Only ({(Var Value-Expression)}*) Form*
-  Create a Let* which evaluates each Value-Expression, binding a temporary
-  variable to the result, and wrapping the Let* around the result of the
-  evaluation of Body. Within the body, each Var is bound to the corresponding
-  temporary variable."
-  (iterate frob
-          ((specs specs)
-           (body body))
+  (named-let frob ((specs specs)
+                  (body body))

     (if (null specs)
        `(progn ,@body)
        (let ((spec (first specs)))
     (if (null specs)
        `(progn ,@body)
        (let ((spec (first specs)))

@@ -146,7 +168,7 @@
          (let* ((name (first spec))
                 (exp-temp (gensym (symbol-name name))))
            `(let ((,exp-temp ,(second spec))
          (let* ((name (first spec))
                 (exp-temp (gensym (symbol-name name))))
            `(let ((,exp-temp ,(second spec))

-                  (,name (gensym "OO-")))
+                  (,name (gensym "ONCE-ONLY-")))

               `(let ((,,name ,,exp-temp))
                  ,,(frob (rest specs) body))))))))
 \f
               `(let ((,,name ,,exp-temp))
                  ,,(frob (rest specs) body))))))))
 \f

@@ -181,8 +203,9 @@
   ;; which is pretty, but which would have required adding awkward
   ;; build order constraints on SBCL (or figuring out some way to make
   ;; inline definitions installable at build-the-cross-compiler time,
   ;; which is pretty, but which would have required adding awkward
   ;; build order constraints on SBCL (or figuring out some way to make
   ;; inline definitions installable at build-the-cross-compiler time,

-  ;; which was too ambitious for now). Rather than mess with that,
-  ;; we just define ASSQ explicitly in terms of more primitive operations:
+  ;; which was too ambitious for now). Rather than mess with that, we
+  ;; just define ASSQ explicitly in terms of more primitive
+  ;; operations:

   (dolist (pair alist)
     (when (eq (car pair) item)
       (return pair))))
   (dolist (pair alist)
     (when (eq (car pair) item)
       (return pair))))

@@ -200,3 +223,17 @@
               (setq list (cdr x))
               (rplacd splice (cdr x))))
            (t (setq splice x)))))) ; Move splice along to include element.
               (setq list (cdr x))
               (rplacd splice (cdr x))))
            (t (setq splice x)))))) ; Move splice along to include element.

+
+
+;; (defmacro posq (item list) `(position ,item ,list :test #'eq))
+(defun posq (item list)
+  #!+sb-doc
+  "Returns the position of the first element EQ to ITEM."
+  (do ((i list (cdr i))
+       (j 0 (1+ j)))
+      ((null i))
+    (when (eq (car i) item)
+      (return j))))
+
+;; (defmacro neq (x y) `(not (eq ,x ,y)))
+(defun neq (x y) (not (eq x y)))