;; 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
("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")
;; 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.
"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"
"!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"
(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
;;; 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)
(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))))
--- /dev/null
+(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*))
(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)
#!+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)
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)))
(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))))))
(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))
,(nth-value 2 (sb-pcl::parse-specialized-lambda-list
(elt stuff arg-pos))))
`(defmethod ,name "<illegal syntax>"))))
+
+(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)))))
;;; 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"
projects / sbcl.git / commitdiff