Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv13217/src/code
Modified Files:
cold-init.lisp early-extensions.lisp toplevel.lisp
Added Files:
function-names.lisp
Log Message:
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)
--- NEW FILE: function-names.lisp ---
(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*))
Index: cold-init.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/cold-init.lisp,v
retrieving revision 1.38
retrieving revision 1.39
diff -u -d -r1.38 -r1.39
--- cold-init.lisp 5 May 2003 23:27:07 -0000 1.38
+++ cold-init.lisp 25 May 2003 22:34:23 -0000 1.39
@@ -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
Index: early-extensions.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-extensions.lisp,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- early-extensions.lisp 5 May 2003 14:09:06 -0000 1.57
+++ early-extensions.lisp 25 May 2003 22:34:23 -0000 1.58
@@ -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 <CLASSNAME-OR-:GLOBAL>
- ;; <SLOT-NAME> [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))))
Index: toplevel.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/toplevel.lisp,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- toplevel.lisp 8 May 2003 11:17:25 -0000 1.46
+++ toplevel.lisp 25 May 2003 22:34:23 -0000 1.47
@@ -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)
|