(* 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
(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
;;; 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)
;; 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):
(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))))
\f
;;;; 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)
;;; Is NAME a legal function name?
(defun legal-fun-name-p (name)
- (or (symbolp name)
- (and (consp name)
- ;; (SETF FOO)
- ;; (CLASS-PREDICATE FOO)
- (or (and (or (eq (car name) 'setf)
- (eq (car name) 'sb!pcl::class-predicate))
- (consp (cdr name))
- (symbolp (cadr name))
- (null (cddr name)))
- ;; (SLOT-ACCESSOR <CLASSNAME-OR-:GLOBAL>
- ;; <SLOT-NAME> [READER|WRITER|BOUNDP])
- (and (eq (car name) 'sb!pcl::slot-accessor)
- (consp (cdr name))
- (symbolp (cadr name))
- (consp (cddr name))
- (symbolp (caddr name))
- (consp (cdddr name))
- (member
- (cadddr name)
- '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp)))))))
+ (values (valid-function-name-p name)))
;;; Signal an error unless NAME is a legal function name.
(defun legal-fun-name-or-type-error (name)
(defun fun-name-block-name (fun-name)
(cond ((symbolp fun-name)
fun-name)
- ((and (consp fun-name)
- (legal-fun-name-p fun-name))
- (case (car fun-name)
- ((setf sb!pcl::class-predicate) (second fun-name))
- ((sb!pcl::slot-accessor) (third 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))))
(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)))
\f
-;;; 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))
\f
;;;; 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)
`(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))))
+\f
+;;; 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)))
projects / sbcl.git / blobdiff