X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=ff139461cce695eb198dba09f458eb12c8acfb5e;hb=2b0851c405b494143009f68e2bc7e91017a809d4;hp=ac0552d010698bafee3c64559498072b8eae534d;hpb=45bc305be4e269d2e1a477c8e0ae9a64df1ccd1c;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index ac0552d..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,22 +769,43 @@ ;;; foo => 13, (constantp 'foo) => t ;;; ;;; ...in which case you frankly deserve to lose. -(defun about-to-modify-symbol-value (symbol action) +(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)))) + (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 @@ -832,9 +855,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)))))))) @@ -865,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 @@ -1041,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) @@ -1203,6 +1226,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*)) @@ -1214,53 +1247,19 @@ 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 sb!xc: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 - (declare (optimize #-sb-xc-host sb!c::stack-allocate-dynamic-extent - #-sb-xc-host sb!c::stack-allocate-value-cells)) - (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")