From: Christophe Rhodes Date: Sun, 25 May 2003 22:34:23 +0000 (+0000) Subject: 0.8.0.2: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=bd0ba0f214518e8d72ff2d44de5a1e3e4b02af2c;p=sbcl.git 0.8.0.2: Fix stack exhaustion stack exhaustion death ... define DEFINE-FUNCTION-NAME-SYNTAX function-name-defining macro; ... use it for SETF functions, and define LEGAL-FUNCTION-NAME-P and FUN-NAME-BLOCK-NAME in terms of VALID-FUNCTION-NAME-P; ... also define internal PCL generalized function name syntax as such, and test for internalness in SET-ARG-INFO1; ... OAOO bonus: delete bits of SB!PCL::CLASS-PREDICATE that were decorating the compiler; (note: this API is interface-compatible with CMUCL's for defining generalized function name syntax. However, it's not currently exported from SB-EXT because I happen to think that calling something VALID-FUNCTION-NAME-P when it returns two values, the second of which is syntactically significant, is a bit lame, and maybe we'll be able to agree a better name between the two projects) --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 8054175..ed67fe2 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -66,6 +66,8 @@ ;; that they can handle the change. -- WHN 19990919 ("src/code/defsetfs") + ("src/code/cold-init-helper-macros") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; cross-compiler-only replacements for stuff which in target Lisp would be ;;; supplied by basic machinery @@ -89,6 +91,9 @@ ("src/code/primordial-extensions") + ;; comes early so that stuff can reason about function names + ("src/code/function-names") + ;; for various constants e.g. SB!XC:MOST-POSITIVE-FIXNUM and ;; SB!VM:N-LOWTAG-BITS, needed by "early-objdef" and others ("src/compiler/generic/early-vm") @@ -111,8 +116,6 @@ ;; mostly needed by stuff from comcom, but also used by "x86-vm" ("src/code/debug-var-io") - ("src/code/cold-init-helper-macros") - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; basic machinery for the target Lisp. Note that although most of these ;;; files are flagged :NOT-HOST, a few might not be. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 54a7f27..424501d 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -844,6 +844,7 @@ retained, possibly temporariliy, because it might be used internally." "C-STRINGS->STRING-LIST" ;; misc. utilities used internally + "DEFINE-FUNCTION-NAME-SYNTAX" "VALID-FUNCTION-NAME-P" ; should be SB!EXT? "LEGAL-FUN-NAME-P" "LEGAL-FUN-NAME-OR-TYPE-ERROR" "FUN-NAME-BLOCK-NAME" "FUN-NAME-INLINE-EXPANSION" @@ -1370,6 +1371,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF" "!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT" + "!FUNCTION-NAMES-COLD-INIT" "!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT" "!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT" "!EARLY-TYPE-COLD-INIT" "!LATE-TYPE-COLD-INIT" diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index fc26b92..acf20fb 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -113,13 +113,14 @@ (show-and-call !random-cold-init) (show-and-call !package-cold-init) - + ;; All sorts of things need INFO and/or (SETF INFO). (/show0 "about to SHOW-AND-CALL !GLOBALDB-COLD-INIT") (show-and-call !globaldb-cold-init) ;; This needs to be done early, but needs to be after INFO is ;; initialized. + (show-and-call !function-names-cold-init) (show-and-call !fdefn-cold-init) ;; Various toplevel forms call MAKE-ARRAY, which calls SUBTYPEP, so diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 1a62a86..481a83d 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -601,26 +601,7 @@ ;;; Is NAME a legal function name? (defun legal-fun-name-p (name) - (or (symbolp name) - (and (consp name) - ;; (SETF FOO) - ;; (CLASS-PREDICATE FOO) - (or (and (or (eq (car name) 'setf) - (eq (car name) 'sb!pcl::class-predicate)) - (consp (cdr name)) - (symbolp (cadr name)) - (null (cddr name))) - ;; (SLOT-ACCESSOR - ;; [READER|WRITER|BOUNDP]) - (and (eq (car name) 'sb!pcl::slot-accessor) - (consp (cdr name)) - (symbolp (cadr name)) - (consp (cddr name)) - (or (symbolp (caddr name)) (stringp (caddr name))) - (consp (cdddr name)) - (member - (cadddr name) - '(sb!pcl::reader sb!pcl::writer sb!pcl::boundp))))))) + (values (valid-function-name-p name))) ;;; Signal an error unless NAME is a legal function name. (defun legal-fun-name-or-type-error (name) @@ -643,11 +624,12 @@ (defun fun-name-block-name (fun-name) (cond ((symbolp fun-name) fun-name) - ((and (consp fun-name) - (legal-fun-name-p fun-name)) - (case (car fun-name) - ((setf sb!pcl::class-predicate) (second fun-name)) - ((sb!pcl::slot-accessor) (third fun-name)))) + ((consp fun-name) + (multiple-value-bind (legalp block-name) + (valid-function-name-p fun-name) + (if legalp + block-name + (error "not legal as a function name: ~S" fun-name)))) (t (error "not legal as a function name: ~S" fun-name)))) diff --git a/src/code/function-names.lisp b/src/code/function-names.lisp new file mode 100644 index 0000000..405916d --- /dev/null +++ b/src/code/function-names.lisp @@ -0,0 +1,60 @@ +(in-package "SB!IMPL") + +;;;; generalized function names +(defvar *valid-fun-names-alist* nil) + +(defun %define-fun-name-syntax (symbol checker) + (let ((found (assoc symbol *valid-fun-names-alist* :test #'eq))) + (if found + (setf (cdr found) checker) + (setq *valid-fun-names-alist* + (acons symbol checker *valid-fun-names-alist*))))) + +(defmacro define-function-name-syntax (symbol (var) &body body) + #!+sb-doc + "Define function names of the form of a list headed by SYMBOL to be +a legal function name, subject to restrictions imposed by BODY. BODY +is evaluated with VAR bound to the form required to check, and should +return two values: the first value is a generalized boolean indicating +legality, and the second a symbol for use as a BLOCK name or similar +situations." + (declare (type symbol symbol)) + (let ((syntax-checker (symbolicate '%check- symbol '-fun-name))) + `(progn + (defun ,syntax-checker (,var) ,@body) + ;; FIXME: is it too expensive to go through a runtime call to + ;; FDEFINITION each time we want to check a name's syntax? + (%define-fun-name-syntax ',symbol ',syntax-checker)))) + +;;; FIXME: this is a really lame name for something that has two +;;; return values. +(defun valid-function-name-p (name) + #!+sb-doc + "The primary return value indicates whether NAME is a valid function +name; if it is, the second return value will be a symbol suitable for +use as a BLOCK name in the function in question." + (typecase name + (cons + (when (symbolp (car name)) + (let ((syntax-checker (cdr (assoc (car name) *valid-fun-names-alist* + :test #'eq)))) + (when syntax-checker + (funcall syntax-checker name))))) + (symbol (values t name)) + (otherwise nil))) + +(define-function-name-syntax setf (name) + (when (cdr name) + (destructuring-bind (fun &rest rest) (cdr name) + (when (null rest) + (typecase fun + ;; ordinary (SETF FOO) case + (symbol (values t fun)) + ;; reasonable (SETF (QUUX BAZ)) case [but not (SETF (SETF + ;; FOO))] + (cons (unless (eq (car fun) 'setf) + (valid-function-name-p fun)))))))) + +#-sb-xc-host +(defun !function-names-cold-init () + (setf *valid-fun-names-alist* '#.*valid-fun-names-alist*)) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 3afa9ad..67bb513 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -173,7 +173,8 @@ (let* ((csp (sap-int (sb!c::control-stack-pointer-sap))) (initial-offset (logand csp (1- bytes-per-scrub-unit))) (end-of-stack - (- sb!vm:*control-stack-end* sb!c:*backend-page-size*))) + (- (sb!vm:fixnumize sb!vm:*control-stack-end*) + sb!c:*backend-page-size*))) (labels ((scrub (ptr offset count) (declare (type system-area-pointer ptr) @@ -205,7 +206,8 @@ #!+stack-grows-downward-not-upward (let* ((csp (sap-int (sb!c::control-stack-pointer-sap))) - (end-of-stack (+ sb!vm:*control-stack-start* sb!c:*backend-page-size*)) + (end-of-stack (+ (sb!vm:fixnumize sb!vm:*control-stack-start*) + sb!c:*backend-page-size*)) (initial-offset (logand csp (1- bytes-per-scrub-unit)))) (labels ((scrub (ptr offset count) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index ce06123..892ddfc 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -430,15 +430,16 @@ Return the lexically apparent definition of the function Name. Name may also be a lambda expression." (if (consp thing) - (case (car thing) - ((lambda named-lambda instance-lambda lambda-with-lexenv) + (cond + ((member (car thing) + '(lambda named-lambda instance-lambda lambda-with-lexenv)) (reference-leaf start cont (ir1-convert-lambdalike thing :debug-name (debug-namify "#'~S" thing) :allow-debug-catch-tag t))) - ((setf sb!pcl::class-predicate sb!pcl::slot-accessor) + ((legal-fun-name-p thing) (let ((var (find-lexically-apparent-fun thing "as the argument to FUNCTION"))) (reference-leaf start cont var))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index c614cbc..5994239 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -1039,9 +1039,8 @@ (bug "full call to ~S" fname))) (when (consp fname) + (aver (legal-fun-name-p fname)) (destructuring-bind (setfoid &rest stem) fname - (aver (member setfoid - '(setf sb!pcl::class-predicate sb!pcl::slot-accessor))) (when (eq setfoid 'setf) (setf (gethash (car stem) *setf-assumed-fboundp*) t)))))) diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 49edcfe..14e6984 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1747,27 +1747,21 @@ bootstrapping. (generic-function-name gf) (!early-gf-name gf)))) (esetf (gf-precompute-dfun-and-emf-p arg-info) - (let* ((sym (if (atom name) name (cadr name))) - (pkg-list (cons *pcl-package* - (package-use-list *pcl-package*)))) - ;; FIXME: given the presence of generalized function - ;; names, this test is broken. A little - ;; reverse-engineering suggests that this was intended - ;; to prevent precompilation of things on some - ;; PCL-internal automatically-constructed functions - ;; like the old "~A~A standard class ~A reader" - ;; functions. When the CADR of SB-PCL::SLOT-ACCESSOR - ;; generalized functions was *, this test returned T, - ;; not NIL, and an error was signalled in - ;; MAKE-ACCESSOR-TABLE for (DEFUN FOO (X) (SLOT-VALUE X - ;; 'ASLDKJ)). Whether the right thing to do is to fix - ;; MAKE-ACCESSOR-TABLE so that it can work in the - ;; presence of slot names that have no classes, or to - ;; restore this test to something more obvious, I don't - ;; know. -- CSR, 2003-02-14 - (and sym (symbolp sym) - (not (null (memq (symbol-package sym) pkg-list))) - (not (find #\space (symbol-name sym)))))))) + (cond + ((and (consp name) + (member (car name) + *internal-pcl-generalized-fun-name-symbols*)) + nil) + (t (let* ((symbol (fun-name-block-name name)) + (package (symbol-package symbol))) + (and (or (eq package *pcl-package*) + (memq package (package-use-list *pcl-package*))) + ;; FIXME: this test will eventually be + ;; superseded by the *internal-pcl...* test, + ;; above. While we are in a process of + ;; transition, however, it should probably + ;; remain. + (not (find #\Space (symbol-name symbol)))))))))) (esetf (gf-info-fast-mf-p arg-info) (or (not (eq *boot-state* 'complete)) (let* ((method-class (generic-function-method-class gf)) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index b35093c..d4e113e 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -54,3 +54,25 @@ ,(nth-value 2 (sb-pcl::parse-specialized-lambda-list (elt stuff arg-pos)))) `(defmethod ,name "")))) + +(defvar sb-pcl::*internal-pcl-generalized-fun-name-symbols* nil) + +(defmacro define-internal-pcl-function-name-syntax (name &rest rest) + `(progn + (define-function-name-syntax ,name ,@rest) + (pushnew ',name sb-pcl::*internal-pcl-generalized-fun-name-symbols*))) + +(define-internal-pcl-function-name-syntax sb-pcl::class-predicate (list) + (when (cdr list) + (destructuring-bind (name &rest rest) (cdr list) + (when (and (symbolp name) + (null rest)) + (values t name))))) + +(define-internal-pcl-function-name-syntax sb-pcl::slot-accessor (list) + (when (= (length list) 4) + (destructuring-bind (class slot rwb) (cdr list) + (when (and (member rwb '(sb-pcl::reader sb-pcl::writer sb-pcl::boundp)) + (symbolp slot) + (symbolp class)) + (values t slot))))) diff --git a/version.lisp-expr b/version.lisp-expr index 4d50ca0..a4c5f45 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.1" +"0.8.0.2"