From 1513b29bfbe948e7b431b5f67f1ff10769c192cf Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 6 Sep 2001 23:50:43 +0000 Subject: [PATCH] 0.pre7.37: merged %COMPILER-TRULY-DEFSTRUCT into %COMPILER-DEFSTRUCT The '%.*defstruct' operators no longer need to be exported. made PROCLAIM-AS-FUNCTION not complain about redefinition unless the function name is actually fbound (not just noted as accessor in info database) moved some function definitions from proclaim.lisp to info-functions.lisp so they'd be available earlier --- package-data-list.lisp-expr | 2 +- src/code/defstruct.lisp | 108 +++++++++++++++----------------------- src/compiler/info-functions.lisp | 63 +++++++++++++++++----- src/compiler/proclaim.lisp | 35 ------------ version.lisp-expr | 2 +- 5 files changed, 94 insertions(+), 116 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index de7abe1..41c3e22 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1261,7 +1261,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%INSTANCE-LAYOUT" "LAYOUT-CLOS-HASH" "%FUNCTION-TYPE" "PROCLAIM-AS-FUNCTION-NAME" "BECOME-DEFINED-FUNCTION-NAME" - "%%COMPILER-TRULY-DEFSTRUCT" "%NUMERATOR" "CLASS-TYPEP" + "%NUMERATOR" "CLASS-TYPEP" "STRUCTURE-CLASS-PRINT-FUNCTION" "DSD-READ-ONLY" "LAYOUT-INHERITS" "DD-LENGTH" "%CODE-ENTRY-POINTS" "%DENOMINATOR" diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index ce09578..448116b 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -236,9 +236,7 @@ (let ((inherits (inherits-for-structure dd))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) - (%compiler-defstruct ',dd ',inherits) - ,@(when (eq (dd-type dd) 'structure) - `((%compiler-truly-defstruct ',dd)))) + (%compiler-defstruct ',dd ',inherits)) (%defstruct ',dd ',inherits) ,@(unless expanding-into-code-for-xc-host-p (append (raw-accessor-definitions dd) @@ -790,7 +788,6 @@ ;; FIXME: Someday it'd probably be good to go back to using ;; closures for the out-of-line forms of structure accessors. - ;; See comment on corresponding code in %%COMPILER-TRULY-DEFSTRUCT. #| (when (dd-predicate info) (protect-cl (dd-predicate info)) @@ -823,12 +820,13 @@ (values)) -;;; Do compile-time actions for DEFSTRUCT. -(defun %compiler-defstruct (info inherits) +;;; Do (COMPILE LOAD EVAL)-time actions for the defstruct described by DD. +(defun %compiler-defstruct (dd inherits) + (declare (type defstruct-description dd)) (multiple-value-bind (class layout old-layout) (multiple-value-bind (clayout clayout-p) - (info :type :compiler-layout (dd-name info)) - (ensure-structure-class info + (info :type :compiler-layout (dd-name dd)) + (ensure-structure-class dd inherits (if clayout-p "previously compiled" "current") "compiled" @@ -849,63 +847,43 @@ (t (unless (eq (class-layout class) layout) (register-layout layout :invalidate nil)) - (setf (sb!xc:find-class (dd-name info)) class))) - - (setf (info :type :compiler-layout (dd-name info)) layout)) - (values)) - -;;; Do (COMPILE LOAD EVAL) time actions for updating the compiler's -;;; global meta-information to represent the definition of a structure -;;; (truly a structure, not just DEFSTRUCT :TYPE VECTOR or DEFSTRUCT -;;; :TYPE LIST) described by INFO. -(defun %compiler-truly-defstruct (info) - (declare (type defstruct-description info)) - (let* ((name (dd-name info)) - (class (sb!xc:find-class name))) - - (let ((copier (dd-copier info))) - (when copier - (proclaim `(ftype (function (,name) ,name) ,copier)))) - - ;; FIXME: This (and corresponding code in %DEFSTRUCT) are the way - ;; that CMU CL defined the predicate, instead of using DEFUN. - ;; Perhaps it would be better to go back to to the CMU CL way, or - ;; something similar. I want to reduce the amount of magic in - ;; DEFSTRUCT functions, but making the predicate be a closure - ;; looks like a good thing, and can even be done without magic. - ;; (OTOH, there are some bootstrapping issues involved, since - ;; GENESIS understands DEFUN but doesn't understand a - ;; (SETF SYMBOL-FUNCTION) call inside %DEFSTRUCT.) - #| - (let ((predicate-name (dd-predicate-name info))) - (when predicate-name - (proclaim-as-defstruct-function-name predicate-name) - (setf (info :function :inlinep pred) :inline) - (setf (info :function :inline-expansion predicate-name) - `(lambda (x) (typep x ',name))))) - |# - - (dolist (slot (dd-slots info)) - (let* ((fun (dsd-accessor-name slot)) - (setf-fun `(setf ,fun))) - (when (and fun (eq (dsd-raw-type slot) t)) - (proclaim-as-defstruct-function-name fun) - (setf (info :function :accessor-for fun) class) - (unless (dsd-read-only slot) - (proclaim-as-defstruct-function-name setf-fun) - (setf (info :function :accessor-for setf-fun) class))))) - - ;; FIXME: Couldn't this logic be merged into - ;; PROCLAIM-AS-DEFSTRUCT-FUNCTION? - (when (boundp 'sb!c:*free-functions*) ; when compiling - (let ((free-functions sb!c:*free-functions*)) - (dolist (slot (dd-slots info)) - (let ((accessor-name (dsd-accessor-name slot))) - (remhash accessor-name free-functions) - (unless (dsd-read-only slot) - (remhash `(setf ,accessor-name) free-functions)))) - (remhash (dd-predicate-name info) free-functions) - (remhash (dd-copier info) free-functions)))) + (setf (sb!xc:find-class (dd-name dd)) class))) + + (setf (info :type :compiler-layout (dd-name dd)) layout)) + + (ecase (dd-type dd) + ((vector list funcallable-structure) + ;; nothing extra to do in this case + ) + ((structure) + (let* ((name (dd-name dd)) + (class (sb!xc:find-class name))) + + (let ((copier (dd-copier dd))) + (when copier + (proclaim `(ftype (function (,name) ,name) ,copier)))) + + (dolist (slot (dd-slots dd)) + (let* ((fun (dsd-accessor-name slot)) + (setf-fun `(setf ,fun))) + (when (and fun (eq (dsd-raw-type slot) t)) + (proclaim-as-defstruct-function-name fun) + (setf (info :function :accessor-for fun) class) + (unless (dsd-read-only slot) + (proclaim-as-defstruct-function-name setf-fun) + (setf (info :function :accessor-for setf-fun) class))))) + + ;; FIXME: Couldn't this logic be merged into + ;; PROCLAIM-AS-DEFSTRUCT-FUNCTION? + (when (boundp 'sb!c:*free-functions*) ; when compiling + (let ((free-functions sb!c:*free-functions*)) + (dolist (slot (dd-slots dd)) + (let ((accessor-name (dsd-accessor-name slot))) + (remhash accessor-name free-functions) + (unless (dsd-read-only slot) + (remhash `(setf ,accessor-name) free-functions)))) + (remhash (dd-predicate-name dd) free-functions) + (remhash (dd-copier dd) free-functions)))))) (values)) diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 8d3c8c9..f6f51dd 100644 --- a/src/compiler/info-functions.lisp +++ b/src/compiler/info-functions.lisp @@ -17,31 +17,66 @@ (in-package "SB!C") +;;; Check that NAME is a valid function name, returning the name if +;;; OK, and signalling an error if not. In addition to checking for +;;; basic well-formedness, we also check that symbol names are not NIL +;;; or the name of a special form. +(defun check-function-name (name) + (typecase name + (list + (unless (and (consp name) (consp (cdr name)) + (null (cddr name)) (eq (car name) 'setf) + (symbolp (cadr name))) + (compiler-error "illegal function name: ~S" name))) + (symbol + (when (eq (info :function :kind name) :special-form) + (compiler-error "Special form is an illegal function name: ~S" name))) + (t + (compiler-error "illegal function name: ~S" name))) + name) + ;;; Record a new function definition, and check its legality. (declaim (ftype (function ((or symbol cons)) t) proclaim-as-function-name)) (defun proclaim-as-function-name (name) (check-function-name name) - (ecase (info :function :kind name) - (:function - (let ((accessor-for (info :function :accessor-for name))) - (when accessor-for - (compiler-style-warning - "~@" - name - accessor-for) - (clear-info :function :accessor-for name)))) - (:macro - (compiler-style-warning "~S was previously defined as a macro." name) - (setf (info :function :where-from name) :assumed) - (clear-info :function :macro-function name)) - ((nil))) + name + accessor-for) + (clear-info :function :accessor-for name)))) + (:macro + (compiler-style-warning "~S was previously defined as a macro." name) + (setf (info :function :where-from name) :assumed) + (clear-info :function :macro-function name)) + ((nil)))) (setf (info :function :kind name) :function) (note-if-setf-function-and-macro name) name) +;;; This is called to do something about SETF functions that overlap +;;; with SETF macros. Perhaps we should interact with the user to see +;;; whether the macro should be blown away, but for now just give a +;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we +;;; can't assume that they aren't just naming a function (SETF FOO) +;;; for the heck of it. NAME is already known to be well-formed. +(defun note-if-setf-function-and-macro (name) + (when (consp name) + (when (or (info :setf :inverse name) + (info :setf :expander name)) + (compiler-style-warning + "defining as a SETF function a name that already has a SETF macro:~ + ~% ~S" + name))) + (values)) + ;;; Make NAME no longer be a function name: clear everything back to ;;; the default. (defun undefine-function-name (name) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 4b35191..4c86f5f 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -19,41 +19,6 @@ (defvar *undefined-warnings*) (declaim (list *undefined-warnings*)) -;;; Check that NAME is a valid function name, returning the name if -;;; OK, and doing an error if not. In addition to checking for basic -;;; well-formedness, we also check that symbol names are not NIL or -;;; the name of a special form. -(defun check-function-name (name) - (typecase name - (list - (unless (and (consp name) (consp (cdr name)) - (null (cddr name)) (eq (car name) 'setf) - (symbolp (cadr name))) - (compiler-error "illegal function name: ~S" name)) - name) - (symbol - (when (eq (info :function :kind name) :special-form) - (compiler-error "Special form is an illegal function name: ~S" name)) - name) - (t - (compiler-error "illegal function name: ~S" name)))) - -;;; This is called to do something about SETF functions that overlap -;;; with SETF macros. Perhaps we should interact with the user to see -;;; whether the macro should be blown away, but for now just give a -;;; warning. Due to the weak semantics of the (SETF FUNCTION) name, we -;;; can't assume that they aren't just naming a function (SETF FOO) -;;; for the heck of it. NAME is already known to be well-formed. -(defun note-if-setf-function-and-macro (name) - (when (consp name) - (when (or (info :setf :inverse name) - (info :setf :expander name)) - (compiler-style-warning - "defining as a SETF function a name that already has a SETF macro:~ - ~% ~S" - name))) - (values)) - ;;; Look up some symbols in *FREE-VARIABLES*, returning the var ;;; structures for any which exist. If any of the names aren't ;;; symbols, we complain. diff --git a/version.lisp-expr b/version.lisp-expr index dd828d9..8f03d2c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.36" +"0.pre7.37" -- 1.7.10.4