X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=ff139461cce695eb198dba09f458eb12c8acfb5e;hb=2b0851c405b494143009f68e2bc7e91017a809d4;hp=341c69ba0c83c49f80fa4c69c78fdd376bc21caa;hpb=9935d377076aacfb8ac397a993bd7eb99c52e4a9;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 341c69b..ff13946 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -16,6 +16,12 @@ ;;; 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 ;;; @@ -438,20 +444,18 @@ ;;; 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) + (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-hash-table (,n-table) - ,iter-form) - iter-form))))) + `(let ((,n-table ,table)) + ,(if locked + `(with-locked-hash-table (,n-table) + ,iter-form) + iter-form)))))) ;;;; hash cache utility @@ -517,10 +521,10 @@ (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"))) (unless (= (length default-values) values) (error "The number of default values ~S differs from :VALUES ~W." @@ -535,7 +539,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)))) @@ -613,42 +617,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))) @@ -767,33 +769,43 @@ ;;; 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)) +(defun about-to-modify-symbol-value (symbol action &optional (new-value nil valuep) bind) (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)))))) + (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 "Cannot ~@? to ~S (not of type ~S.)" + :format-arguments (list action (describe-action) new-value spec) + :datum new-value + :expected-type spec)))))))) (values)) ;;; If COLD-FSET occurs not at top level, just treat it as an ordinary @@ -876,18 +888,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 @@ -1052,7 +1064,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)