X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=f87de0424ce606fd0a8a8efbd1d504d592dfb218;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=323982d5ed5b9b9b201ca8690f6eb3f941a451fb;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 323982d..f87de04 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) @@ -563,7 +581,7 @@ (defmacro define-cached-synonym (name &optional (original (symbolicate "%" name))) - (let ((cached-name (symbolicate "%%" name "-cached"))) + (let ((cached-name (symbolicate "%%" name "-CACHED"))) `(progn (defun-cached (,cached-name :hash-bits 8 :hash-function (lambda (x) @@ -623,34 +641,18 @@ ;;;; various operations on names ;;; Is NAME a legal function name? +(declaim (inline legal-fun-name-p)) (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))) + +(deftype function-name () '(satisfies legal-fun-name-p)) ;;; Signal an error unless NAME is a legal function name. (defun legal-fun-name-or-type-error (name) (unless (legal-fun-name-p name) (error 'simple-type-error :datum name - :expected-type '(or symbol list) + :expected-type 'function-name :format-control "invalid function name: ~S" :format-arguments (list name)))) @@ -666,11 +668,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)))) @@ -796,29 +799,20 @@ (%failed-aver ,(format nil "~A" expr)))) (defun %failed-aver (expr-as-string) + ;; hackish way to tell we're in a cold sbcl and output the + ;; message before signallign error, as it may be this is too + ;; early in the cold init. + (when (find-package "SB!C") + (fresh-line) + (write-line "failed AVER:") + (write-line expr-as-string) + (terpri)) (bug "~@" expr-as-string)) -;;; We need a definition of BUG here for the host compiler to be able -;;; to deal with BUGs in sbcl. This should never affect an end-user, -;;; who will pick up the definition that signals a CONDITION of -;;; condition-class BUG; however, this is not defined on the host -;;; lisp, but for the target. SBCL developers sometimes trigger BUGs -;;; in their efforts, and it is useful to get the details of the BUG -;;; rather than an undefined function error. - CSR, 2002-04-12 -#+sb-xc-host (defun bug (format-control &rest format-arguments) - (error 'simple-error - :format-control "~@< ~? ~:@_~?~:>" - :format-arguments `(,format-control - ,format-arguments - "~@.~:@>" - ()))) + (error 'bug + :format-control format-control + :format-arguments format-arguments)) (defmacro enforce-type (value type) (once-only ((value value)) @@ -826,18 +820,14 @@ which can be found at .~:@>" (%failed-enforce-type ,value ',type)))) (defun %failed-enforce-type (value type) - (error 'simple-type-error ; maybe should be TYPE-BUG, subclass of BUG? - :value value + ;; maybe should be TYPE-BUG, subclass of BUG? If it is changed, + ;; check uses of it in user-facing code (e.g. WARN) + (error 'simple-type-error + :datum 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)) @@ -939,6 +929,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), @@ -1084,3 +1092,95 @@ which can be found at .~:@>" `(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)))) + +;;; 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))) + +;;; 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))) + +;;; Bind a few "potentially dangerous" printer control variables to +;;; safe values, respecting current values if possible. +(defmacro with-sane-io-syntax (&body forms) + `(call-with-sane-io-syntax (lambda () ,@forms))) + +(defun call-with-sane-io-syntax (function) + (declare (type function function)) + (macrolet ((true (sym) + `(and (boundp ',sym) ,sym))) + (let ((*print-readably* nil) + (*print-level* (or (true *print-level*) 6)) + (*print-length* (or (true *print-length*) 12))) + (funcall function))))