X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Fearly-extensions.lisp;h=341c69ba0c83c49f80fa4c69c78fdd376bc21caa;hb=2db410feb35e7e30c95af8f20f67e6177fa92488;hp=451405790bc9e8eb3107221fd57f90ab9aadeaca;hpb=35bfc07cbd9aa8029e9cc42f1a3fab27f1a673f4;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 4514057..341c69b 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -30,6 +30,10 @@ ;;; bound because ANSI specifies it as an exclusive bound.) (def!type index () `(integer 0 (,sb!xc:array-dimension-limit))) +;;; like INDEX, but only up to half the maximum. Used by hash-table +;;; code that does plenty to (aref v (* 2 i)) and (aref v (1+ (* 2 i))). +(def!type index/2 () `(integer 0 (,(floor sb!xc:array-dimension-limit 2)))) + ;;; like INDEX, but augmented with -1 (useful when using the index ;;; to count downwards to 0, e.g. LOOP FOR I FROM N DOWNTO 0, with ;;; an implementation which terminates the loop by testing for the @@ -65,6 +69,30 @@ (* max-offset sb!vm:n-word-bytes)) scale))) +#!+(or x86 x86-64) +(defun displacement-bounds (lowtag element-size data-offset) + (let* ((adjustment (- (* data-offset sb!vm:n-word-bytes) lowtag)) + (bytes-per-element (ceiling element-size sb!vm:n-byte-bits)) + (min (truncate (+ sb!vm::minimum-immediate-offset adjustment) + bytes-per-element)) + (max (truncate (+ sb!vm::maximum-immediate-offset adjustment) + bytes-per-element))) + (values min max))) + +#!+(or x86 x86-64) +(def!type constant-displacement (lowtag element-size data-offset) + (flet ((integerify (x) + (etypecase x + (integer x) + (symbol (symbol-value x))))) + (let ((lowtag (integerify lowtag)) + (element-size (integerify element-size)) + (data-offset (integerify data-offset))) + (multiple-value-bind (min max) (displacement-bounds lowtag + element-size + data-offset) + `(integer ,min ,max))))) + ;;; 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 @@ -74,7 +102,7 @@ ((or (atom result) (not (eq (car result) 'values))) `(values ,result &optional)) - ((intersection (cdr result) lambda-list-keywords) + ((intersection (cdr result) sb!xc:lambda-list-keywords) result) (t `(values ,@(cdr result) &optional))))) `(function ,args ,result))) @@ -349,8 +377,8 @@ ;;; not really an old-fashioned function, but what the calling ;;; convention should've been: like NTH, but with the same argument -;;; order as in all the other dereferencing functions, with the -;;; collection first and the index second +;;; order as in all the other indexed dereferencing functions, with +;;; the collection first and the index second (declaim (inline nth-but-with-sane-arg-order)) (declaim (ftype (function (list index) t) nth-but-with-sane-arg-order)) (defun nth-but-with-sane-arg-order (list index) @@ -367,41 +395,63 @@ ;;;; miscellaneous iteration extensions -;;; "the ultimate iteration macro" +;;; like Scheme's named LET ;;; -;;; note for Schemers: This seems to be identical to Scheme's "named LET". +;;; (CMU CL called this ITERATE, and commented it as "the ultimate +;;; iteration macro...". I (WHN) found the old name insufficiently +;;; specific to remind me what the macro means, so I renamed it.) (defmacro named-let (name binds &body body) - #!+sb-doc (dolist (x binds) (unless (proper-list-of-length-p x 2) (error "malformed NAMED-LET variable spec: ~S" x))) `(labels ((,name ,(mapcar #'first binds) ,@body)) (,name ,@(mapcar #'second binds)))) +(defun filter-dolist-declarations (decls) + (mapcar (lambda (decl) + `(declare ,@(remove-if + (lambda (clause) + (and (consp clause) + (or (eq (car clause) 'type) + (eq (car clause) 'ignore)))) + (cdr decl)))) + decls)) + ;;; just like DOLIST, but with one-dimensional arrays -(defmacro dovector ((elt vector &optional result) &rest forms) - (let ((index (gensym)) - (length (gensym)) - (vec (gensym))) - `(let ((,vec ,vector)) - (declare (type vector ,vec)) - (do ((,index 0 (1+ ,index)) - (,length (length ,vec))) - ((>= ,index ,length) ,result) - (let ((,elt (aref ,vec ,index))) - ,@forms))))) - -;;; Iterate over the entries in a HASH-TABLE. -(defmacro dohash ((key-var value-var table &optional result) &body body) +(defmacro dovector ((elt vector &optional result) &body body) (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) - (let ((gen (gensym)) - (n-more (gensym))) - `(with-hash-table-iterator (,gen ,table) - (loop - (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) + (with-unique-names (index length vec) + `(let ((,vec ,vector)) + (declare (type vector ,vec)) + (do ((,index 0 (1+ ,index)) + (,length (length ,vec))) + ((>= ,index ,length) (let ((,elt nil)) + ,@(filter-dolist-declarations decls) + ,elt + ,result)) + (let ((,elt (aref ,vec ,index))) ,@decls - (unless ,n-more (return ,result)) - ,@forms)))))) + (tagbody + ,@forms))))))) + +;;; Iterate over the entries in a HASH-TABLE, first obtaining the lock +;;; if the table is a synchronized table. +(defmacro dohash (((key-var value-var) table &key result locked) &body body) + (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) + (let* ((gen (gensym)) + (n-more (gensym)) + (n-table (gensym)) + (iter-form `(with-hash-table-iterator (,gen ,n-table) + (loop + (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) + ,@decls + (unless ,n-more (return ,result)) + ,@forms))))) + `(let ((,n-table ,table)) + ,(if locked + `(with-locked-hash-table (,n-table) + ,iter-form) + iter-form))))) ;;;; hash cache utility @@ -705,38 +755,47 @@ (char= #\* (aref name 0)) (char= #\* (aref name (1- (length name)))))))) -;;; Some symbols are defined by ANSI to be self-evaluating. Return -;;; non-NIL for such symbols (and make the non-NIL value a traditional -;;; message, for use in contexts where the user asks us to change such -;;; a symbol). -(defun symbol-self-evaluating-p (symbol) - (declare (type symbol symbol)) - (cond ((eq symbol t) - "Veritas aeterna. (can't change T)") - ((eq symbol nil) - "Nihil ex nihil. (can't change NIL)") - ((keywordp symbol) - "Keyword values can't be changed.") - (t - nil))) - -;;; This function is to be called just before a change which would -;;; affect the symbol value. (We don't absolutely have to call this -;;; function before such changes, since such changes are given as -;;; undefined behavior. In particular, we don't if the runtime cost -;;; would be annoying. But otherwise it's nice to do so.) -(defun about-to-modify-symbol-value (symbol) - (declare (type symbol symbol)) - (let ((reason (symbol-self-evaluating-p symbol))) - (when reason - (error reason))) - ;; (Note: Just because a value is CONSTANTP is not a good enough - ;; reason to complain here, because we want DEFCONSTANT to be able - ;; to use this function, and it's legal to DEFCONSTANT a constant as - ;; long as the new value is EQL to the old value.) +;;; This function is to be called just before a change which would affect the +;;; symbol value. We don't absolutely have to call this function before such +;;; changes, since such changes to constants are given as undefined behavior, +;;; it's nice to do so. To circumvent this you need code like this: +;;; +;;; (defvar foo) +;;; (defun set-foo (x) (setq foo x)) +;;; (defconstant foo 42) +;;; (set-foo 13) +;;; foo => 13, (constantp 'foo) => t +;;; +;;; ...in which case you frankly deserve to lose. +(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep)) + (declare (symbol symbol)) + (multiple-value-bind (what continue) + (when (eq :constant (info :variable :kind symbol)) + (cond ((eq symbol t) + (values "Veritas aeterna. (can't ~@?)" nil)) + ((eq symbol nil) + (values "Nihil ex nihil. (can't ~@?)" nil)) + ((keywordp symbol) + (values "Can't ~@?." nil)) + (t + (values "Constant modification: attempt to ~@?." t)))) + (when what + (if continue + (cerror "Modify the constant." what action symbol) + (error what action symbol))) + (when valuep + ;; :VARIABLE :TYPE is in the db only if it is declared, so no need to + ;; check. + (let ((type (info :variable :type symbol))) + (unless (sb!kernel::%%typep new-value type) + (let ((spec (type-specifier type))) + (error 'simple-type-error + :format-control "Cannot ~@? to ~S (not of type ~S.)" + :format-arguments (list action symbol new-value spec) + :datum new-value + :expected-type spec)))))) (values)) - ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary ;;; assignment instead of doing cold static linking. That way things like ;;; (FLET ((FROB (X) ..)) @@ -784,9 +843,9 @@ (unless (proper-list-of-length-p spec 2) (error "malformed ONCE-ONLY binding spec: ~S" spec)) (let* ((name (first spec)) - (exp-temp (gensym (symbol-name name)))) + (exp-temp (gensym "ONCE-ONLY"))) `(let ((,exp-temp ,(second spec)) - (,name (gensym "ONCE-ONLY-"))) + (,name (gensym ,(symbol-name name)))) `(let ((,,name ,,exp-temp)) ,,(frob (rest specs) body)))))))) @@ -878,75 +937,24 @@ (def-constantly-fun constantly-nil nil) (def-constantly-fun constantly-0 0)) -;;; If X is an atom, see whether it is present in *FEATURES*. Also +;;; If X is a symbol, see whether it is present in *FEATURES*. Also ;;; handle arbitrary combinations of atoms using NOT, AND, OR. (defun featurep (x) - (if (consp x) - (case (car x) - ((:not not) - (if (cddr x) - (error "too many subexpressions in feature expression: ~S" x) - (not (featurep (cadr x))))) - ((:and and) (every #'featurep (cdr x))) - ((:or or) (some #'featurep (cdr x))) - (t - (error "unknown operator in feature expression: ~S." x))) - (not (null (memq x *features*))))) - -;;; Given a list of keyword substitutions `(,OLD ,NEW), and a -;;; &KEY-argument-list-style list of alternating keywords and -;;; arbitrary values, return a new &KEY-argument-list-style list with -;;; all substitutions applied to it. -;;; -;;; Note: If efficiency mattered, we could do less consing. (But if -;;; efficiency mattered, why would we be using &KEY arguments at -;;; all, much less renaming &KEY arguments?) -;;; -;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201 -(defun rename-key-args (rename-list key-args) - (declare (type list rename-list key-args)) - ;; Walk through RENAME-LIST modifying RESULT as per each element in - ;; RENAME-LIST. - (do ((result (copy-list key-args))) ; may be modified below - ((null rename-list) result) - (destructuring-bind (old new) (pop rename-list) - ;; ANSI says &KEY arg names aren't necessarily KEYWORDs. - (declare (type symbol old new)) - ;; Walk through RESULT renaming any OLD key argument to NEW. - (do ((in-result result (cddr in-result))) - ((null in-result)) - (declare (type list in-result)) - (when (eq (car in-result) old) - (setf (car in-result) new)))))) - -;;; ANSI Common Lisp's READ-SEQUENCE function, unlike most of the -;;; other ANSI input functions, is defined to communicate end of file -;;; status with its return value, not by signalling. That is not the -;;; behavior that we usually want. This function is a wrapper which -;;; restores the behavior that we usually want, causing READ-SEQUENCE -;;; to communicate end-of-file status by signalling. -(defun read-sequence-or-die (sequence stream &key start end) - ;; implementation using READ-SEQUENCE - #-no-ansi-read-sequence - (let ((read-end (read-sequence sequence - stream - :start start - :end end))) - (unless (= read-end end) - (error 'end-of-file :stream stream)) - (values)) - ;; workaround for broken READ-SEQUENCE - #+no-ansi-read-sequence - (progn - (aver (<= start end)) - (let ((etype (stream-element-type stream))) - (cond ((equal etype '(unsigned-byte 8)) - (do ((i start (1+ i))) - ((>= i end) - (values)) - (setf (aref sequence i) - (read-byte stream)))) - (t (error "unsupported element type ~S" etype)))))) + (etypecase x + (cons + (case (car x) + ((:not not) + (cond + ((cddr x) + (error "too many subexpressions in feature expression: ~S" x)) + ((null (cdr x)) + (error "too few subexpressions in feature expression: ~S" x)) + (t (not (featurep (cadr x)))))) + ((:and and) (every #'featurep (cdr x))) + ((:or or) (some #'featurep (cdr x))) + (t + (error "unknown operator in feature expression: ~S." x)))) + (symbol (not (null (memq x *features*)))))) ;;;; utilities for two-VALUES predicates @@ -1206,6 +1214,16 @@ (*print-length* (or (true *print-length*) 12))) (funcall function)))) +;;; Returns a list of members of LIST. Useful for dealing with circular lists. +;;; For a dotted list returns a secondary value of T -- in which case the +;;; primary return value does not include the dotted tail. +(defun list-members (list) + (when list + (do ((tail (cdr list) (cdr tail)) + (members (list (car list)) (cons (car tail) members))) + ((or (not (consp tail)) (eq tail list)) + (values members (not (listp tail))))))) + ;;; Default evaluator mode (interpeter / compiler) (declaim (type (member :compile #!+sb-eval :interpret) *evaluator-mode*)) @@ -1215,3 +1233,44 @@ an implementation of EVAL that calls the compiler will be used. If set to :INTERPRET, an interpreter will be used.") +;;; Helper for making the DX closure allocation in macros expanding +;;; to CALL-WITH-FOO less ugly. +(defmacro dx-flet (functions &body forms) + `(flet ,functions + (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent + ,@(mapcar (lambda (func) `(function ,(car func))) functions))) + ,@forms)) + +;;; Another similar one. +(defmacro dx-let (bindings &body forms) + `(let ,bindings + (declare (#+sb-xc-host dynamic-extent #-sb-xc-host truly-dynamic-extent + ,@(mapcar (lambda (bind) (if (consp bind) (car bind) bind)) + bindings))) + ,@forms)) + +(in-package "SB!KERNEL") + +(defun fp-zero-p (x) + (typecase x + (single-float (zerop x)) + (double-float (zerop x)) + #!+long-float + (long-float (zerop x)) + (t nil))) + +(defun neg-fp-zero (x) + (etypecase x + (single-float + (if (eql x 0.0f0) + (make-unportable-float :single-float-negative-zero) + 0.0f0)) + (double-float + (if (eql x 0.0d0) + (make-unportable-float :double-float-negative-zero) + 0.0d0)) + #!+long-float + (long-float + (if (eql x 0.0l0) + (make-unportable-float :long-float-negative-zero) + 0.0l0))))