X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=5f2aa4629878b641011de1c475ac871ccd3ca184;hb=71bc8b09fc75083ea4bb2aee954abca1f1e1f214;hp=2281678a2610274bd979685c278d7a7c91ffeddd;hpb=ec2e02db335d1545b3c18233bf440ca4160f780d;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 2281678..5f2aa46 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -13,9 +13,23 @@ (in-package "SB!IMPL") +(defvar *core-pathname* nil + #!+sb-doc + "The absolute pathname of the running SBCL core.") + +(defvar *runtime-pathname* nil + #!+sb-doc + "The absolute pathname of the running SBCL runtime.") + ;;; something not EQ to anything we might legitimately READ (defparameter *eof-object* (make-symbol "EOF-OBJECT")) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant max-hash sb!xc:most-positive-fixnum)) + +(def!type hash () + `(integer 0 ,max-hash)) + ;;; a type used for indexing into arrays, and for related quantities ;;; like lengths of lists ;;; @@ -102,7 +116,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))) @@ -377,8 +391,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) @@ -395,11 +409,12 @@ ;;;; 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))) @@ -433,17 +448,22 @@ (tagbody ,@forms))))))) -;;; Iterate over the entries in a HASH-TABLE. -(defmacro dohash ((key-var value-var table &optional result) &body body) +;;; 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))) - `(with-hash-table-iterator (,gen ,table) - (loop - (multiple-value-bind (,n-more ,key-var ,value-var) (,gen) - ,@decls - (unless ,n-more (return ,result)) - ,@forms)))))) + (with-unique-names (gen n-more n-table) + (let ((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-system-table (,n-table) + ,iter-form) + iter-form)))))) ;;;; hash cache utility @@ -504,16 +524,20 @@ (init-wrapper 'progn) (values 1)) (let* ((var-name (symbolicate "*" name "-CACHE-VECTOR*")) + (probes-name (when *profile-hash-cache* + (symbolicate "*" name "-CACHE-PROBES*"))) + (misses-name (when *profile-hash-cache* + (symbolicate "*" name "-CACHE-MISSES*"))) (nargs (length args)) (size (ash 1 hash-bits)) (default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) - (args-and-values (gensym)) + (args-and-values (sb!xc:gensym "ARGS-AND-VALUES")) (args-and-values-size (+ nargs values)) - (n-index (gensym)) - (n-cache (gensym))) - + (n-index (sb!xc:gensym "INDEX")) + (n-cache (sb!xc:gensym "CACHE"))) + (declare (ignorable probes-name misses-name)) (unless (= (length default-values) values) (error "The number of default values ~S differs from :VALUES ~W." default values)) @@ -527,7 +551,7 @@ (values-refs) (values-names)) (dotimes (i values) - (let ((name (gensym))) + (let ((name (sb!xc:gensym "VALUE"))) (values-names name) (values-refs `(svref ,args-and-values (+ ,nargs ,i))) (sets `(setf (svref ,args-and-values (+ ,nargs ,i)) ,name)))) @@ -543,20 +567,16 @@ (incf n))) (when *profile-hash-cache* - (let ((n-probe (symbolicate "*" name "-CACHE-PROBES*")) - (n-miss (symbolicate "*" name "-CACHE-MISSES*"))) - (inits `(setq ,n-probe 0)) - (inits `(setq ,n-miss 0)) - (forms `(defvar ,n-probe)) - (forms `(defvar ,n-miss)) - (forms `(declaim (fixnum ,n-miss ,n-probe))))) + (inits `(setq ,probes-name 0)) + (inits `(setq ,misses-name 0)) + (forms `(declaim (fixnum ,probes-name ,misses-name)))) (let ((fun-name (symbolicate name "-CACHE-LOOKUP"))) (inlines fun-name) (forms `(defun ,fun-name ,(arg-vars) ,@(when *profile-hash-cache* - `((incf ,(symbolicate "*" name "-CACHE-PROBES*")))) + `((incf ,probes-name))) (let* ((,n-index (,hash-function ,@(arg-vars))) (,n-cache ,var-name) (,args-and-values (svref ,n-cache ,n-index))) @@ -565,7 +585,7 @@ (values ,@(values-refs))) (t ,@(when *profile-hash-cache* - `((incf ,(symbolicate "*" name "-CACHE-MISSES*")))) + `((incf ,misses-name))) ,default)))))) (let ((fun-name (symbolicate name "-CACHE-ENTER"))) @@ -591,6 +611,9 @@ `(progn (defvar ,var-name) + ,@(when *profile-hash-cache* + `((defvar ,probes-name) + (defvar ,misses-name))) (declaim (type (simple-vector ,size) ,var-name)) #!-sb-fluid (declaim (inline ,@(inlines))) (,init-wrapper ,@(inits)) @@ -605,42 +628,40 @@ (let ((default-values (if (and (consp default) (eq (car default) 'values)) (cdr default) (list default))) - (arg-names (mapcar #'car args))) - (collect ((values-names)) - (dotimes (i values) - (values-names (gensym))) - (multiple-value-bind (body decls doc) (parse-body body-decls-doc) - `(progn - (define-hash-cache ,name ,args ,@options) - (defun ,name ,arg-names - ,@decls - ,doc - (cond #!+sb-show - ((not (boundp '*hash-caches-initialized-p*)) - ;; This shouldn't happen, but it did happen to me - ;; when revising the type system, and it's a lot - ;; easier to figure out what what's going on with - ;; that kind of problem if the system can be kept - ;; alive until cold boot is complete. The recovery - ;; mechanism should definitely be conditional on - ;; some debugging feature (e.g. SB-SHOW) because - ;; it's big, duplicating all the BODY code. -- WHN - (/show0 ,name " too early in cold init, uncached") - (/show0 ,(first arg-names) "=..") - (/hexstr ,(first arg-names)) - ,@body) - (t - (multiple-value-bind ,(values-names) - (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) - (if (and ,@(mapcar (lambda (val def) - `(eq ,val ,def)) - (values-names) default-values)) - (multiple-value-bind ,(values-names) - (progn ,@body) - (,(symbolicate name "-CACHE-ENTER") ,@arg-names - ,@(values-names)) - (values ,@(values-names))) - (values ,@(values-names)))))))))))) + (arg-names (mapcar #'car args)) + (values-names (make-gensym-list values))) + (multiple-value-bind (body decls doc) (parse-body body-decls-doc) + `(progn + (define-hash-cache ,name ,args ,@options) + (defun ,name ,arg-names + ,@decls + ,doc + (cond #!+sb-show + ((not (boundp '*hash-caches-initialized-p*)) + ;; This shouldn't happen, but it did happen to me + ;; when revising the type system, and it's a lot + ;; easier to figure out what what's going on with + ;; that kind of problem if the system can be kept + ;; alive until cold boot is complete. The recovery + ;; mechanism should definitely be conditional on some + ;; debugging feature (e.g. SB-SHOW) because it's big, + ;; duplicating all the BODY code. -- WHN + (/show0 ,name " too early in cold init, uncached") + (/show0 ,(first arg-names) "=..") + (/hexstr ,(first arg-names)) + ,@body) + (t + (multiple-value-bind ,values-names + (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names) + (if (and ,@(mapcar (lambda (val def) + `(eq ,val ,def)) + values-names default-values)) + (multiple-value-bind ,values-names + (progn ,@body) + (,(symbolicate name "-CACHE-ENTER") ,@arg-names + ,@values-names) + (values ,@values-names)) + (values ,@values-names)))))))))) (defmacro define-cached-synonym (name &optional (original (symbolicate "%" name))) @@ -747,38 +768,57 @@ (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) bind) + (declare (symbol symbol)) + (flet ((describe-action () + (ecase action + (set "set SYMBOL-VALUE of ~S") + (progv "bind ~S") + (compare-and-swap "compare-and-swap SYMBOL-VALUE of ~S") + (defconstant "define ~S as a constant") + (makunbound "make ~S unbound")))) + (let ((kind (info :variable :kind symbol))) + (multiple-value-bind (what continue) + (cond ((eq :constant kind) + (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)))) + ((and bind (eq :global kind)) + (values "Can't ~@? (global variable)." nil))) + (when what + (if continue + (cerror "Modify the constant." what (describe-action) symbol) + (error what (describe-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 nil) + (let ((spec (type-specifier type))) + (error 'simple-type-error + :format-control "~@" + :format-arguments (list (describe-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) ..)) @@ -826,9 +866,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)))))))) @@ -859,18 +899,18 @@ ;;; guts of complex systems anyway, I replaced it too.) (defmacro aver (expr) `(unless ,expr - (%failed-aver ,(format nil "~A" expr)))) + (%failed-aver ',expr))) -(defun %failed-aver (expr-as-string) +(defun %failed-aver (expr) ;; hackish way to tell we're in a cold sbcl and output the - ;; message before signallign error, as it may be this is too + ;; message before signalling 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) + (write expr) (terpri)) - (bug "~@" expr-as-string)) + (bug "~@" expr)) (defun bug (format-control &rest format-arguments) (error 'bug @@ -920,75 +960,27 @@ (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)))))) + (typecase 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*)))) + (t + (error "invalid feature expression: ~S" x)))) + ;;;; utilities for two-VALUES predicates @@ -1086,7 +1078,7 @@ (let ((first? t) maybe-print-space (reversed-prints nil) - (stream (gensym "STREAM"))) + (stream (sb!xc:gensym "STREAM"))) (flet ((sref (slot-name) `(,(symbolicate conc-name slot-name) structure))) (dolist (slot-desc slot-descs) @@ -1137,10 +1129,54 @@ (translate-logical-pathname possibly-logical-pathname) possibly-logical-pathname)) -(defun deprecation-warning (bad-name &optional good-name) - (warn "using deprecated ~S~@[, should use ~S instead~]" - bad-name - good-name)) +;;;; Deprecating stuff + +(defun deprecation-error (since name replacement) + (error 'deprecation-error + :name name + :replacement replacement + :since since)) + +(defun deprecation-warning (state since name replacement + &key (runtime-error (neq :early state))) + (warn (ecase state + (:early 'early-deprecation-warning) + (:late 'late-deprecation-warning) + (:final 'final-deprecation-warning)) + :name name + :replacement replacement + :since since + :runtime-error runtime-error)) + +(defun deprecated-function (since name replacement) + (lambda (&rest deprecated-function-args) + (declare (ignore deprecated-function-args)) + (deprecation-error since name replacement))) + +(defun deprecation-compiler-macro (state since name replacement) + (lambda (form env) + (declare (ignore env)) + (deprecation-warning state since name replacement) + form)) + +(defmacro define-deprecated-function (state since name replacement lambda-list &body body) + (let ((doc (let ((*package* (find-package :keyword))) + (format nil "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>" + name since replacement)))) + `(progn + ,(ecase state + ((:early :late) + `(defun ,name ,lambda-list + ,doc + ,@body)) + ((:final) + `(progn + (declaim (ftype (function * nil) ,name)) + (setf (fdefinition ',name) + (deprecated-function ',name ',replacement ,since)) + (setf (documentation ',name 'function) ,doc)))) + (setf (compiler-macro-function ',name) + (deprecation-compiler-macro ,state ,since ',name ',replacement))))) ;;; Anaphoric macros (defmacro awhen (test &body body) @@ -1248,6 +1284,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*)) @@ -1259,50 +1305,42 @@ to :INTERPRET, an interpreter will be used.") ;;; Helper for making the DX closure allocation in macros expanding ;;; to CALL-WITH-FOO less ugly. -;;; -;;; This expands to something like -;;; -;;; (flet ((foo (...) )) -;;; (declare (optimize stack-allocate-dynamic-extent)) -;;; (flet ((foo (...) -;;; (foo ...)) -;;; (declare (dynamic-extent #'foo)) -;;; ))) -;;; -;;; The outer FLETs are inlined into the inner ones, and the inner ones -;;; are DX-allocated. The double-fletting is done to keep the bodies of -;;; the functions in an environment with correct policy: we don't want -;;; to force DX allocation in their bodies, which would be bad eg. -;;; in safe code. (defmacro dx-flet (functions &body forms) - (let ((names (mapcar #'car functions))) - `(flet ,functions - #-sb-xc-host - (declare (optimize sb!c::stack-allocate-dynamic-extent)) - (flet ,(mapcar - (lambda (f) - (let ((args (cadr f)) - (name (car f))) - (when (intersection args lambda-list-keywords) - ;; No fundamental reason not to support them, but we - ;; don't currently need them here. - (error "Non-required arguments not implemented for DX-FLET.")) - `(,name ,args - (,name ,@args)))) - functions) - (declare (dynamic-extent ,@(mapcar (lambda (x) `(function ,x)) names))) - ,@forms)))) - -;;; Another similar one -- but actually touches the policy of the body, -;;; so take care with this one... + `(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) - `(locally - #-sb-xc-host - (declare (optimize sb!c::stack-allocate-dynamic-extent)) - (let ,bindings - (declare (dynamic-extent ,@(mapcar (lambda (bind) - (if (consp bind) - (car bind) - bind)) - bindings))) - ,@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))))