Skip to content

Commit

Permalink
0.8alpha.0.41:
Browse files Browse the repository at this point in the history
	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.
  • Loading branch information
csrhodes committed May 20, 2003
1 parent 3a10f89 commit 8af1983
Show file tree
Hide file tree
Showing 4 changed files with 16 additions and 24 deletions.
32 changes: 12 additions & 20 deletions src/code/defstruct.lisp
Expand Up @@ -174,8 +174,8 @@
(:conc-name dsd-)
(:copier nil)
#-sb-xc-host (:pure t))
;; string name of slot
%name
;; name of slot
name
;; its position in the implementation sequence
(index (missing-arg) :type fixnum)
;; the name of the accessor function
Expand Down Expand Up @@ -204,17 +204,6 @@
(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)))

;;;; typed (non-class) structures

Expand Down Expand Up @@ -482,7 +471,7 @@
((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)))

;;;; parsing
Expand Down Expand Up @@ -611,7 +600,7 @@
;;; 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)
Expand All @@ -633,11 +622,13 @@
spec))
spec))

(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)))
(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)
Expand Down Expand Up @@ -1035,7 +1026,7 @@
slot with name ~S (accessing an inherited slot ~
instead).~:@>"
accessor-name
(dsd-%name dsd)))))))))
(dsd-name dsd)))))))))
(values))

;;;; redefinition stuff
Expand Down Expand Up @@ -1501,7 +1492,7 @@
(index 1))
(dolist (slot-name slot-names)
(push (make-defstruct-slot-description
:%name (symbol-name slot-name)
:name slot-name
:index index
:accessor-name (symbolicate conc-name slot-name))
reversed-result)
Expand Down Expand Up @@ -1591,7 +1582,8 @@
(let ((,object-gensym ,raw-maker-form))
,@(mapcar (lambda (slot-name)
(let ((dsd (find (symbol-name slot-name) dd-slots
:key #'dsd-%name
:key (lambda (x)
(symbol-name (dsd-name x)))
:test #'string=)))
;; KLUDGE: bug 117 bogowarning. Neither
;; DECLAREing the type nor TRULY-THE cut
Expand Down
2 changes: 1 addition & 1 deletion src/code/inspect.lisp
Expand Up @@ -172,7 +172,7 @@ evaluated expressions.
(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)))))

Expand Down
4 changes: 2 additions & 2 deletions src/code/target-defstruct.lisp
Expand Up @@ -422,7 +422,7 @@
(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))
Expand Down Expand Up @@ -452,7 +452,7 @@
(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))
Expand Down
2 changes: 1 addition & 1 deletion version.lisp-expr
Expand Up @@ -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.8alpha.0.40"
"0.8alpha.0.41"

0 comments on commit 8af1983

Please sign in to comment.