X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fboot-extensions.lisp;h=be509c66c788cedd757d95e294eca1c4fb9e29ef;hb=204f2fa9771ad9e55718dc76205afec7d11b3011;hp=4dfc372a2ad2448fe262e0f6b1b8460cd971cd9d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git diff --git a/src/code/boot-extensions.lisp b/src/code/boot-extensions.lisp index 4dfc372..be509c6 100644 --- 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. -(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*)) -(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)))) ;;;; 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. ;;; @@ -95,48 +123,42 @@ macros)))) `(macrolet ,macros (let* ,(nreverse binds) ,@body)))) +;;; 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 - "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") - (error "A required keyword argument was not supplied.")) + (error "A required &KEY argument was not supplied.")) -;;; "the ultimate iteration macro" +;;; "the ultimate iteration macro" ;;; ;;; 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 - "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)))) - -;;; 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) - #!+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))) @@ -146,7 +168,7 @@ (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)))))))) @@ -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 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)))) @@ -200,3 +223,17 @@ (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)))