X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fearly-extensions.lisp;h=065f5694c562075dccc16aecd91c82ea2450a674;hb=4c16a9ef1bd70752c2d40d65211ecb76956bbd1d;hp=5163fe16b0b9d0698aa284b8b7e6796974f244eb;hpb=acce826c593a188b231b7b7918c752bda21d0201;p=sbcl.git
diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp
index 5163fe1..065f569 100644
--- a/src/code/early-extensions.lisp
+++ b/src/code/early-extensions.lisp
@@ -65,6 +65,28 @@
(* max-offset sb!vm:n-word-bytes))
scale)))
+;;; Similar to FUNCTION, but the result type is "exactly" specified:
+;;; if it is an object type, then the function returns exactly one
+;;; value, if it is a short form of VALUES, then this short form
+;;; specifies the exact number of values.
+(def!type sfunction (args &optional result)
+ (let ((result (cond ((eq result '*) '*)
+ ((or (atom result)
+ (not (eq (car result) 'values)))
+ `(values ,result &optional))
+ ((intersection (cdr result) lambda-list-keywords)
+ result)
+ (t `(values ,@(cdr result) &optional)))))
+ `(function ,args ,result)))
+
+;;; a type specifier
+;;;
+;;; FIXME: The SB!KERNEL:INSTANCE here really means CL:CLASS.
+;;; However, the CL:CLASS type is only defined once PCL is loaded,
+;;; which is before this is evaluated. Once PCL is moved into cold
+;;; init, this might be fixable.
+(def!type type-specifier () '(or list symbol sb!kernel:instance))
+
;;; the default value used for initializing character data. The ANSI
;;; spec says this is arbitrary, so we use the value that falls
;;; through when we just let the low-level consing code initialize
@@ -105,29 +127,6 @@
;;;; type-ish predicates
-;;; a helper function for various macros which expect clauses of a
-;;; given length, etc.
-(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))
- ;; 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.
- (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))))
-
;;; Is X a list containing a cycle?
(defun cyclic-list-p (x)
(and (listp x)
@@ -146,6 +145,11 @@
(and (consp x)
(list-of-length-at-least-p (cdr x) (1- n)))))
+(declaim (inline singleton-p))
+(defun singleton-p (list)
+ (and (consp list)
+ (null (rest list))))
+
;;; Is X is a positive prime integer?
(defun positive-primep (x)
;; This happens to be called only from one place in sbcl-0.7.0, and
@@ -184,7 +188,7 @@
;;; COLLECT-LIST-EXPANDER handles the list collection case. N-TAIL
;;; is the pointer to the current tail of the list, or NIL if the list
;;; is empty.
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(defun collect-normal-expander (n-value fun forms)
`(progn
,@(mapcar (lambda (form) `(setq ,n-value (,fun ,form ,n-value))) forms)
@@ -284,7 +288,12 @@
;; just define ASSQ explicitly in terms of more primitive
;; operations:
(dolist (pair alist)
- (when (eq (car pair) item)
+ ;; though it may look more natural to write this as
+ ;; (AND PAIR (EQ (CAR PAIR) ITEM))
+ ;; the temptation to do so should be resisted, as pointed out by PFD
+ ;; sbcl-devel 2003-08-16, as NIL elements are rare in association
+ ;; lists. -- CSR, 2003-08-16
+ (when (and (eq (car pair) item) (not (null pair)))
(return pair))))
;;; like (DELETE .. :TEST #'EQ):
@@ -323,10 +332,19 @@
(declaim (ftype (function (list index) t) nth-but-with-sane-arg-order))
(defun nth-but-with-sane-arg-order (list index)
(nth index list))
+
+(defun adjust-list (list length initial-element)
+ (let ((old-length (length list)))
+ (cond ((< old-length length)
+ (append list (make-list (- length old-length)
+ :initial-element initial-element)))
+ ((> old-length length)
+ (subseq list 0 length))
+ (t list))))
;;;; miscellaneous iteration extensions
-;;; "the ultimate iteration macro"
+;;; "the ultimate iteration macro"
;;;
;;; note for Schemers: This seems to be identical to Scheme's "named LET".
(defmacro named-let (name binds &body body)
@@ -352,7 +370,7 @@
;;; Iterate over the entries in a HASH-TABLE.
(defmacro dohash ((key-var value-var table &optional result) &body body)
- (multiple-value-bind (forms decls) (parse-body body nil)
+ (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil)
(let ((gen (gensym))
(n-more (gensym)))
`(with-hash-table-iterator (,gen ,table)
@@ -573,6 +591,27 @@
(defun ,name (&rest args)
(,cached-name args)))))
+;;; FIXME: maybe not the best place
+;;;
+;;; FIXME: think of a better name -- not only does this not have the
+;;; CAR recursion of EQUAL, it also doesn't have the special treatment
+;;; of pathnames, bit-vectors and strings.
+;;;
+;;; KLUDGE: This means that we will no longer cache specifiers of the
+;;; form '(INTEGER (0) 4). This is probably not a disaster.
+;;;
+;;; A helper function for the type system, which is the main user of
+;;; these caches: we must be more conservative than EQUAL for some of
+;;; our equality tests, because MEMBER and friends refer to EQLity.
+;;; So:
+(defun equal-but-no-car-recursion (x y)
+ (cond
+ ((eql x y) t)
+ ((consp x)
+ (and (consp y)
+ (eql (car x) (car y))
+ (equal-but-no-car-recursion (cdr x) (cdr y))))
+ (t nil)))
;;;; package idioms
@@ -603,13 +642,7 @@
;;; Is NAME a legal function name?
(defun legal-fun-name-p (name)
- (or (symbolp name)
- (and (consp name)
- (or (eq (car name) 'setf)
- (eq (car name) 'sb!pcl::class-predicate))
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))))
+ (values (valid-function-name-p name)))
;;; Signal an error unless NAME is a legal function name.
(defun legal-fun-name-or-type-error (name)
@@ -632,9 +665,12 @@
(defun fun-name-block-name (fun-name)
(cond ((symbolp fun-name)
fun-name)
- ((and (consp fun-name)
- (legal-fun-name-p fun-name))
- (second fun-name))
+ ((consp fun-name)
+ (multiple-value-bind (legalp block-name)
+ (valid-function-name-p fun-name)
+ (if legalp
+ block-name
+ (error "not legal as a function name: ~S" fun-name))))
(t
(error "not legal as a function name: ~S" fun-name))))
@@ -793,15 +829,9 @@ which can be found at .~:@>"
(error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG?
:value value
:expected-type type
- :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-control "~@<~S ~_is not a ~_~S~:>"
:format-arguments (list value type)))
-;;; Return a list of N gensyms. (This is a common suboperation in
-;;; macros and other code-manipulating code.)
-(declaim (ftype (function (index) list) make-gensym-list))
-(defun make-gensym-list (n)
- (loop repeat n collect (gensym)))
-
;;; Return a function like FUN, but expecting its (two) arguments in
;;; the opposite order that FUN does.
(declaim (inline swapped-args-fun))
@@ -903,6 +933,24 @@ which can be found at .~:@>"
;;;; utilities for two-VALUES predicates
+(defmacro not/type (x)
+ (let ((val (gensym "VAL"))
+ (win (gensym "WIN")))
+ `(multiple-value-bind (,val ,win)
+ ,x
+ (if ,win
+ (values (not ,val) t)
+ (values nil nil)))))
+
+(defmacro and/type (x y)
+ `(multiple-value-bind (val1 win1) ,x
+ (if (and (not val1) win1)
+ (values nil t)
+ (multiple-value-bind (val2 win2) ,y
+ (if (and val1 val2)
+ (values t t)
+ (values nil (and win2 (not val2))))))))
+
;;; sort of like ANY and EVERY, except:
;;; * We handle two-VALUES predicate functions, as SUBTYPEP does.
;;; (And if the result is uncertain, then we return (VALUES NIL NIL),
@@ -1048,3 +1096,45 @@ which can be found at .~:@>"
`(if ,test
(let ((it ,test)) (declare (ignorable it)),@body)
(acond ,@rest))))))
+
+;;; (binding* ({(name initial-value [flag])}*) body)
+;;; FLAG may be NIL or :EXIT-IF-NULL
+;;;
+;;; This form unites LET*, MULTIPLE-VALUE-BIND and AWHEN.
+(defmacro binding* ((&rest bindings) &body body)
+ (let ((bindings (reverse bindings)))
+ (loop with form = `(progn ,@body)
+ for binding in bindings
+ do (destructuring-bind (names initial-value &optional flag)
+ binding
+ (multiple-value-bind (names declarations)
+ (etypecase names
+ (null
+ (let ((name (gensym)))
+ (values (list name) `((declare (ignorable ,name))))))
+ (symbol
+ (values (list names) nil))
+ (list
+ (values names nil)))
+ (setq form `(multiple-value-bind ,names
+ ,initial-value
+ ,@declarations
+ ,(ecase flag
+ ((nil) form)
+ ((:exit-if-null)
+ `(when ,(first names) ,form)))))))
+ finally (return form))))
+
+;;; Delayed evaluation
+(defmacro delay (form)
+ `(cons nil (lambda () ,form)))
+
+(defun force (promise)
+ (cond ((not (consp promise)) promise)
+ ((car promise) (cdr promise))
+ (t (setf (car promise) t
+ (cdr promise) (funcall (cdr promise))))))
+
+(defun promise-ready-p (promise)
+ (or (not (consp promise))
+ (car promise)))