Firefighting the build, part II
... remove DSD-%NAME optimization, in the interest of making
SLOT-VALUE (and hence MAKE-LOAD-FORM-SAVING-SLOTS)
a more reliable operation.
... now the name of the slot is the symbol in the DEFSTRUCT
form, as expected; also, now the CL package is pristine,
containing only the 978 exported symbols.
Essentially this version has built from CMUCL and built itself
successfully.
(:conc-name dsd-)
(:copier nil)
#-sb-xc-host (:pure t))
(:conc-name dsd-)
(:copier nil)
#-sb-xc-host (:pure t))
- ;; string name of slot
- %name
;; its position in the implementation sequence
(index (missing-arg) :type fixnum)
;; the name of the accessor function
;; its position in the implementation sequence
(index (missing-arg) :type fixnum)
;; the name of the accessor function
(def!method print-object ((x defstruct-slot-description) stream)
(print-unreadable-object (x stream :type t)
(prin1 (dsd-name x) stream)))
(def!method print-object ((x defstruct-slot-description) stream)
(print-unreadable-object (x stream :type t)
(prin1 (dsd-name x) stream)))
-
-;;; Return the name of a defstruct slot as a symbol. We store it as a
-;;; string to avoid creating lots of worthless symbols at load time.
-;;;
-;;; FIXME: This has horrible package issues. In many ways, it would
-;;; be very nice to treat the names of structure slots as strings, but
-;;; unfortunately PCL requires slot names to be interned symbols.
-;;; Maybe we want to resurrect something like the old
-;;; SB-SLOT-ACCESSOR-NAME package?
-(defun dsd-name (dsd)
- (intern (dsd-%name dsd)))
\f
;;;; typed (non-class) structures
\f
;;;; typed (non-class) structures
((not (= (cdr inherited) index))
(style-warn "~@<Non-overwritten accessor ~S does not access ~
slot with name ~S (accessing an inherited slot ~
((not (= (cdr inherited) index))
(style-warn "~@<Non-overwritten accessor ~S does not access ~
slot with name ~S (accessing an inherited slot ~
- instead).~:@>" name (dsd-%name slot))))))))
+ instead).~:@>" name (dsd-name slot))))))))
(stuff)))
\f
;;;; parsing
(stuff)))
\f
;;;; parsing
;;; that we modify to get the new slot. This is supplied when handling
;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
;;; that we modify to get the new slot. This is supplied when handling
;;; included slots.
(defun parse-1-dsd (defstruct spec &optional
- (slot (make-defstruct-slot-description :%name ""
+ (slot (make-defstruct-slot-description :name ""
:index 0
:type t)))
(multiple-value-bind (name default default-p type type-p read-only ro-p)
:index 0
:type t)))
(multiple-value-bind (name default default-p type type-p read-only ro-p)
- (when (find name (dd-slots defstruct) :test #'string= :key #'dsd-%name)
+ (when (find name (dd-slots defstruct)
+ :test #'string=
+ :key (lambda (x) (symbol-name (dsd-name x))))
(error 'simple-program-error
:format-control "duplicate slot name ~S"
:format-arguments (list name)))
(error 'simple-program-error
:format-control "duplicate slot name ~S"
:format-arguments (list name)))
- (setf (dsd-%name slot) (string name))
+ (setf (dsd-name slot) name)
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
(let ((accessor-name (if (dd-conc-name defstruct)
(setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list slot)))
(let ((accessor-name (if (dd-conc-name defstruct)
slot with name ~S (accessing an inherited slot ~
instead).~:@>"
accessor-name
slot with name ~S (accessing an inherited slot ~
instead).~:@>"
accessor-name
- (dsd-%name dsd)))))))))
(values))
\f
;;;; redefinition stuff
(values))
\f
;;;; redefinition stuff
(index 1))
(dolist (slot-name slot-names)
(push (make-defstruct-slot-description
(index 1))
(dolist (slot-name slot-names)
(push (make-defstruct-slot-description
- :%name (symbol-name slot-name)
:index index
:accessor-name (symbolicate conc-name slot-name))
reversed-result)
:index index
:accessor-name (symbolicate conc-name slot-name))
reversed-result)
(let ((,object-gensym ,raw-maker-form))
,@(mapcar (lambda (slot-name)
(let ((dsd (find (symbol-name slot-name) dd-slots
(let ((,object-gensym ,raw-maker-form))
,@(mapcar (lambda (slot-name)
(let ((dsd (find (symbol-name slot-name) dd-slots
+ :key (lambda (x)
+ (symbol-name (dsd-name x)))
:test #'string=)))
;; KLUDGE: bug 117 bogowarning. Neither
;; DECLAREing the type nor TRULY-THE cut
:test #'string=)))
;; KLUDGE: bug 117 bogowarning. Neither
;; DECLAREing the type nor TRULY-THE cut
(info (layout-info (sb-kernel:layout-of object))))
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (dd-slots info) (nreverse parts-list))
(info (layout-info (sb-kernel:layout-of object))))
(when (sb-kernel::defstruct-description-p info)
(dolist (dd-slot (dd-slots info) (nreverse parts-list))
- (push (cons (dsd-%name dd-slot)
+ (push (cons (dsd-name dd-slot)
(funcall (dsd-accessor-name dd-slot) object))
parts-list)))))
(funcall (dsd-accessor-name dd-slot) object))
parts-list)))))
(pprint-pop)
(let ((slot (pop remaining-slots)))
(write-char #\: stream)
(pprint-pop)
(let ((slot (pop remaining-slots)))
(write-char #\: stream)
- (output-symbol-name (dsd-%name slot) stream)
+ (output-symbol-name (symbol-name (dsd-name slot)) stream)
(write-char #\space stream)
(pprint-newline :miser stream)
(output-object (funcall (fdefinition (dsd-accessor-name slot))
(write-char #\space stream)
(pprint-newline :miser stream)
(output-object (funcall (fdefinition (dsd-accessor-name slot))
(write-char #\space stream)
(write-char #\: stream)
(let ((slot (first remaining-slots)))
(write-char #\space stream)
(write-char #\: stream)
(let ((slot (first remaining-slots)))
- (output-symbol-name (dsd-%name slot) stream)
+ (output-symbol-name (symbol-name (dsd-name slot)) stream)
(write-char #\space stream)
(output-object
(funcall (fdefinition (dsd-accessor-name slot))
(write-char #\space stream)
(output-object
(funcall (fdefinition (dsd-accessor-name 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".)
;;; 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".)