X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=81b6f7b046a5bf0285d767fee01697d73b18640e;hb=77af6d16968262049d6dadfb5521af7a8a7c6868;hp=fe0f3195e1994d256240b56033d86c3a11630c8b;hpb=508bf17fa9e609c523a2795d84a3bc908db1b302;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index fe0f319..81b6f7b 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 @@ -123,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 @@ -161,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) @@ -261,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): @@ -300,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) @@ -601,26 +642,7 @@ ;;; 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 - ;; [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) @@ -643,11 +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)) - (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)))) @@ -806,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)) @@ -916,6 +933,15 @@ 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) @@ -1070,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)))