X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-extensions.lisp;h=341c69ba0c83c49f80fa4c69c78fdd376bc21caa;hb=8eee0d3a30bf39d9f201acff28c92059fe6c3e4e;hp=d52a0dc0a1fd8e0f173fcd52db91532575438c78;hpb=edf8d3701ba59bd9f0c1bd027f3179b98250cfd0;p=sbcl.git diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index d52a0dc..341c69b 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -102,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))) @@ -755,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) ..)) @@ -834,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)))))))) @@ -1205,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*)) @@ -1216,53 +1235,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 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")