(* 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
;; 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)
;;; 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)
;;; 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))
- (or (symbolp (caddr name)) (stringp (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 function like FUN, but expecting its (two) arguments in
\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* ({(names 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
+ (collect ((new-names) (ignorable))
+ (dolist (name names)
+ (when (eq name nil)
+ (setq name (gensym))
+ (ignorable name))
+ (new-names name))
+ (values (new-names)
+ (when (ignorable)
+ `((declare (ignorable ,@(ignorable)))))))))
+ (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)))
+\f
+;;; toplevel helper
+(defmacro with-rebound-io-syntax (&body body)
+ `(%with-rebound-io-syntax (lambda () ,@body)))
+
+(defun %with-rebound-io-syntax (function)
+ (declare (type function function))
+ (let ((*package* *package*)
+ (*print-array* *print-array*)
+ (*print-base* *print-base*)
+ (*print-case* *print-case*)
+ (*print-circle* *print-circle*)
+ (*print-escape* *print-escape*)
+ (*print-gensym* *print-gensym*)
+ (*print-length* *print-length*)
+ (*print-level* *print-level*)
+ (*print-lines* *print-lines*)
+ (*print-miser-width* *print-miser-width*)
+ (*print-pretty* *print-pretty*)
+ (*print-radix* *print-radix*)
+ (*print-readably* *print-readably*)
+ (*print-right-margin* *print-right-margin*)
+ (*read-base* *read-base*)
+ (*read-default-float-format* *read-default-float-format*)
+ (*read-eval* *read-eval*)
+ (*read-suppress* *read-suppress*)
+ (*readtable* *readtable*))
+ (funcall function)))