From f97a81e98db1346fee06527a32fdb0664b0598b7 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Thu, 11 Feb 1993 14:00:59 +0000 Subject: [PATCH] Fixed #S and removed a residual reference to the STRUCTURE type. --- code/sharpm.lisp | 41 ++++++++++++++++++----------------------- 1 file changed, 18 insertions(+), 23 deletions(-) diff --git a/code/sharpm.lisp b/code/sharpm.lisp index 5704fc29e..6952fe94e 100644 --- a/code/sharpm.lisp +++ b/code/sharpm.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.10.1.1 1993/01/23 13:43:47 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.10.1.2 1993/02/11 14:00:59 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -213,27 +213,22 @@ (let ((body (if (char= (read-char stream t) #\( ) (read-list stream nil) (%reader-error stream "Non-list following #S")))) - (cond ((listp body) - (unless (symbolp (car body)) - (%reader-error stream - "Structure type is not a symbol: ~S" (car body))) - (let ((defstruct (info type defined-structure-info (car body)))) - (unless defstruct - (%reader-error stream - "~S is not a defined structure type." - (car body))) - (unless (c::dd-constructors defstruct) - (%reader-error - stream "The ~S structure does not have a default constructor." - (car body))) - (do ((arg (cdr body) (cddr arg)) - (res ())) - ((endp arg) - (apply (car (c::dd-constructors defstruct)) res)) - (push (cadr arg) res) - (push (intern (string (car arg)) *keyword-package*) res)))) - (t (%reader-error stream "Non-list following #S: ~S" body))))) - + (unless (listp body) + (%reader-error stream "Non-list following #S: ~S" body)) + (unless (symbolp (car body)) + (%reader-error stream "Structure type is not a symbol: ~S" (car body))) + (let ((class (find-class (car body) nil))) + (unless (typep class 'structure-class) + (%reader-error stream "~S is not a defined structure type." + (car body))) + (let ((def-con (dd-default-constructor + (layout-info + (class-layout class))))) + (unless def-con + (%reader-error + stream "The ~S structure does not have a default constructor." + (car body))) + (apply (fdefinition def-cont) (rest body)))))) ;;;; #=/## @@ -247,7 +242,7 @@ ;; alist of the things to be replaced assoc'd with the things to replace them. ;; (defun circle-subst (old-new-alist tree) - (cond ((not (typep tree '(or cons (array t) structure))) + (cond ((not (typep tree '(or cons (array t) structure-object))) (let ((entry (find tree old-new-alist :key #'second))) (if entry (third entry) tree))) ((null (gethash tree *sharp-equal-circle-table*)) -- GitLab