1;;; Sources for CLISP DEFSTRUCT macro 2;;; Bruno Haible 1988-2005 3;;; Sam Steingold 1998-2010, 2017 4;;; German comments translated into English: Stefan Kain 2003-01-14 5 6(in-package "SYSTEM") 7 8#| Explanation of the appearing data types: 9 10 For structure types (but not for structure classes!): 11 12 (get name 'DEFSTRUCT-DESCRIPTION) = 13 #(type size keyword-constructor effective-slotlist direct-slotlist 14 boa-constructors copier predicate defaultfun0 defaultfun1 ...) 15 16 type (if the type of the whole structure is meant): 17 = LIST storage as list 18 = VECTOR storage as (simple-)vector 19 = (VECTOR element-type) storage as vector with element-type 20 21 size is the list length / vector length. 22 23 keyword-constructor = NIL or the name of the keyword-constructor 24 boa-constructors = list of names of BOA constructors 25 copier = NIL or the name of the copier function 26 predicate = NIL or the name of the predicate function 27 28 effective-slotlist is a packed description of the slots of a structure: 29 effective-slotlist = ({slot}*) 30 slot = an instance of structure-effective-slot-definition, containing: 31 name - the slotname, 32 initargs - a list containing the initialization argument, 33 or NIL for the pseudo-slot containing the structure name in 34 named structures, 35 offset - the location of the slot in any instance, 36 initer = (initform . initfunction) - as usual, 37 init-function-form - 38 a form (a symbol or a list (SVREF ...)), that yields 39 upon evaluation in an arbitrary environment a function, 40 that returns the default value, when called. 41 type - the declared type for this slot, 42 readonly = NIL or = T specifying, if this slot is readonly, i.e. 43 after the construction of the Structure the slot cannot be 44 changed with (setf ...) anymore. 45 (See also pr_structure_default() in io.d.) 46 direct-slotlist is the list of slots defined together with the structure: 47 direct-slotlist = ({slot*}) 48 slot = an instance of structure-direct-slot-definition, containing: 49 name, initform, initfunction, initargs, type, initer - see above 50 writers - list of setters: ((setf struct-slot-name)) 51 readers - list of getters: (struct-slot-name) 52 The initializations are specified as follows: 53 - not real slot (i.e. initargs = ()): 54 initform = `(QUOTE ,name) 55 initfunction = a constant-initfunction for name 56 init-function-form = `(MAKE-CONSTANT-INITFUNCTION ',name) 57 - real slot with constant initform: 58 initform = as specified by the user 59 initfunction = a constant-initfunction for the initform's value 60 init-function-form = `(MAKE-CONSTANT-INITFUNCTION ,initform) 61 - real slot with non-constant initform: 62 initform = as specified by the user 63 initfunction = a closure taking 0 arguments, or nil 64 init-function-form = for inherited slots: `(SVREF ...) 65 for direct slots: `(FUNCTION (LAMBDA () ,initform)) 66 In both cases, after some processing: a gensym 67 referring to a binding. 68 69 For structure classes, i.e. if type = T, all this information is contained 70 in the CLOS class (get name 'CLOS::CLOSCLASS). In this case, all slots are 71 real slots: the names list is stored in the first memory word already by 72 ALLOCATE-INSTANCE, without need for corresponding effective-slot-definition. 73|# 74 75;; Indices of the fixed elements of a defstruct-description: 76;; if you add a slot, you need to modify io.d:SYS::STRUCTURE-READER 77(defconstant *defstruct-description-type-location* 0) 78(defconstant *defstruct-description-size-location* 1) 79(defconstant *defstruct-description-kconstructor-location* 2) 80(defconstant *defstruct-description-slots-location* 3) 81(defconstant *defstruct-description-direct-slots-location* 4) 82(defconstant *defstruct-description-boa-constructors-location* 5) 83(defconstant *defstruct-description-copier-location* 6) 84(defconstant *defstruct-description-predicate-location* 7) 85(proclaim '(constant-inline *defstruct-description-type-location* 86 *defstruct-description-size-location* 87 *defstruct-description-kconstructor-location* 88 *defstruct-description-slots-location* 89 *defstruct-description-direct-slots-location* 90 *defstruct-description-boa-constructors-location* 91 *defstruct-description-copier-location* 92 *defstruct-description-predicate-location*)) 93 94(defun make-ds-slot (name initargs offset initer type readonly) 95 (clos::make-instance-<structure-effective-slot-definition> 96 clos::<structure-effective-slot-definition> 97 :name name 98 :initargs initargs 99 :initform (car initer) :initfunction (cdr initer) 'clos::inheritable-initer initer 100 :type type 101 'clos::readonly readonly 102 'clos::location offset)) 103(defun copy-<structure-effective-slot-definition> (slot) 104 (make-ds-slot 105 (clos:slot-definition-name slot) 106 (clos:slot-definition-initargs slot) 107 (clos:slot-definition-location slot) 108 (clos::slot-definition-inheritable-initer slot) 109 (clos:slot-definition-type slot) 110 (clos::structure-effective-slot-definition-readonly slot))) 111(defmacro ds-real-slot-p (slot) 112 `(not (null (clos:slot-definition-initargs ,slot)))) 113(defmacro ds-pseudo-slot-default (slot) 114 ;; The pseudo-slots have an initform = (QUOTE name) and an initfunction which 115 ;; returns the name. 116 `(funcall (clos:slot-definition-initfunction ,slot))) 117 118#| The type test comes in 4 variants. Keep them in sync! |# 119 120#| Type test, for TYPEP. 121 Must be equivalent to (typep object (ds-canonicalize-type symbol)). 122|# 123(defun ds-typep (object symbol desc) 124 (declare (ignore symbol)) 125 (let ((type (svref desc *defstruct-description-type-location*)) 126 (size (svref desc *defstruct-description-size-location*))) 127 (if (eq type 'LIST) 128 (and (conses-p size object) 129 (dolist (slot (svref desc *defstruct-description-slots-location*) t) 130 (unless (ds-real-slot-p slot) 131 (unless (eq (nth (clos:slot-definition-location slot) object) 132 (ds-pseudo-slot-default slot)) 133 (return nil))))) 134 (and (vectorp object) (simple-array-p object) 135 (>= (length object) size) 136 (equal (array-element-type object) 137 (if (consp type) 138 (upgraded-array-element-type (second type)) 139 'T)) 140 (dolist (slot (svref desc *defstruct-description-slots-location*) t) 141 (unless (ds-real-slot-p slot) 142 (unless (and (simple-vector-p object) 143 (eq (svref object (clos:slot-definition-location slot)) 144 (ds-pseudo-slot-default slot))) 145 (return nil)))))))) 146 147#| Type test expansion, for TYPEP compiler macro. |# 148(defun ds-typep-expansion (objform symbol desc) 149 (declare (ignore symbol)) 150 (let ((type (svref desc *defstruct-description-type-location*)) 151 (size (svref desc *defstruct-description-size-location*)) 152 (tmp (gensym))) 153 `(LET ((,tmp ,objform)) 154 ,(if (eq type 'LIST) 155 `(AND ,@(case size 156 (0 '()) 157 (1 `((CONSP ,tmp))) 158 (t `((CONSES-P ,size ,tmp)))) 159 ,@(mapcan #'(lambda (slot) 160 (unless (ds-real-slot-p slot) 161 `((EQ (NTH ,(clos:slot-definition-location slot) ,tmp) 162 ',(ds-pseudo-slot-default slot))))) 163 (svref desc *defstruct-description-slots-location*))) 164 (let ((eltype (if (consp type) 165 (upgraded-array-element-type (second type)) 166 'T))) 167 `(AND ,@(if (eq eltype 'T) 168 `((SIMPLE-VECTOR-P ,tmp)) 169 `((VECTORP ,tmp) 170 (SIMPLE-ARRAY-P ,tmp) 171 (EQUAL (ARRAY-ELEMENT-TYPE ,tmp) ',eltype))) 172 ,(case size 173 (0 'T) 174 (t `(>= (LENGTH ,tmp) ,size))) 175 ,@(mapcan #'(lambda (slot) 176 (unless (ds-real-slot-p slot) 177 `((EQ (SVREF ,tmp ,(clos:slot-definition-location slot)) 178 ',(ds-pseudo-slot-default slot))))) 179 (svref desc *defstruct-description-slots-location*)))))))) 180 181#| Type canonicalization, for SUBTYPEP. |# 182(defun ds-canonicalize-type (symbol) 183 (let ((desc (get symbol 'DEFSTRUCT-DESCRIPTION))) 184 (if desc 185 (let ((type (svref desc *defstruct-description-type-location*)) 186 (size (svref desc *defstruct-description-size-location*)) 187 (slotlist (svref desc *defstruct-description-slots-location*))) 188 (if (eq type 'LIST) 189 (let ((resulttype 'T)) 190 ;; Start with T, not (MEMBER NIL), because of the possibility 191 ;; of subclasses. 192 (dotimes (i size) (setq resulttype (list 'CONS 'T resulttype))) 193 (dolist (slot slotlist) 194 (unless (ds-real-slot-p slot) 195 (let ((resttype resulttype)) 196 (dotimes (j (clos:slot-definition-location slot)) 197 (setq resttype (third resttype))) 198 (setf (second resttype) `(EQL ,(ds-pseudo-slot-default slot)))))) 199 resulttype) 200 `(AND (SIMPLE-ARRAY ,(if (consp type) (second type) 'T) (*)) 201 ;; Constraints that cannot be represented through ANSI CL 202 ;; type specifiers. We use SATISFIES types with uninterned 203 ;; symbols. This is possible because this function is only 204 ;; used for SUBTYPEP. 205 ,@(when (or (plusp size) 206 (some #'(lambda (slot) (not (ds-real-slot-p slot))) 207 slotlist)) 208 (let ((constraint-name (gensym))) 209 (setf (symbol-function constraint-name) 210 #'(lambda (x) (typep x symbol))) 211 `((SATISFIES ,constraint-name))))))) 212 ; The DEFSTRUCT-DESCRIPTION was lost. 213 'NIL))) 214 215#| (ds-make-pred predname type name slotlist size) 216 returns the form, that creates the type-test-predicate for 217 the structure name. 218 219 type the type of the structure, 220 name the name of the structure, 221 predname the name of the type-test-predicate, 222 slotlist (only used when type /= T) list of slots 223 size instance size 224|# 225(defun ds-make-pred (predname type name slotlist size) 226 `(,@(if (eq type 'T) `((PROCLAIM '(INLINE ,predname))) '()) 227 (DEFUN ,predname (OBJECT) 228 ,(if (eq type 'T) 229 `(%STRUCTURE-TYPE-P ',name OBJECT) 230 (let ((max-offset -1) 231 (max-name-offset -1)) 232 (dolist (slot+initff slotlist) 233 (let ((slot (car slot+initff))) 234 (setq max-offset (max max-offset (clos:slot-definition-location slot))) 235 (unless (ds-real-slot-p slot) 236 (setq max-name-offset (max max-name-offset (clos:slot-definition-location slot)))))) 237 ; This code is only used when there is at least one named slot. 238 (assert (<= 0 max-name-offset max-offset)) 239 (assert (< max-offset size)) 240 (if (eq type 'LIST) 241 `(AND ,@(case size 242 (0 '()) 243 (1 `((CONSP OBJECT))) 244 (t `((CONSES-P ,size OBJECT)))) 245 ,@(mapcan #'(lambda (slot+initff) 246 (let ((slot (car slot+initff))) 247 (unless (ds-real-slot-p slot) 248 `((EQ (NTH ,(clos:slot-definition-location slot) OBJECT) 249 ',(ds-pseudo-slot-default slot)))))) 250 slotlist)) 251 ; This code is only used when there is at least one named slot. 252 ; Therefore the vector's upgraded element type must contain 253 ; SYMBOL, i.e. it must be a general vector. 254 `(AND (SIMPLE-VECTOR-P OBJECT) 255 (>= (LENGTH OBJECT) ,size) 256 ,@(mapcan #'(lambda (slot+initff) 257 (let ((slot (car slot+initff))) 258 (unless (ds-real-slot-p slot) 259 `((EQ (SVREF OBJECT ,(clos:slot-definition-location slot)) 260 ',(ds-pseudo-slot-default slot)))))) 261 slotlist)))))))) 262 263#| auxiliary function for both constructors: 264 (ds-arg-default arg slot+initff) 265 returns for an argument arg (part of the argument list) the part of 266 the argument list, that binds this argument with the default for slot. 267|# 268 269(defun ds-arg-default (arg slot+initff) 270 (let* ((slot (car slot+initff)) 271 (initer (clos::slot-definition-inheritable-initer slot)) 272 (initfunction (clos::inheritable-slot-definition-initfunction initer))) 273 `(,arg 274 ;; Initial value: If it is not a constant form, must funcall the 275 ;; initfunction. If it is a constant, we can use the initform directly. 276 ;; If no initform has been provided, ANSI CL says that "the consequences 277 ;; are undefined if an attempt is later made to read the slot's value 278 ;; before a value is explicitly assigned", i.e. we could leave the slot 279 ;; uninitialized (= #<UNBOUND> in the structure case). But CLtL2 says 280 ;; "the element's initial value is undefined", which implies that the 281 ;; slot is initialized to an arbitrary value. We use NIL as this value. 282 ,(if ; equivalent to (constantp (clos::inheritable-slot-definition-initform initer)) 283 (or (null initfunction) (constant-initfunction-p initfunction)) 284 (clos::inheritable-slot-definition-initform initer) 285 `(FUNCALL ,(cdr slot+initff)))))) 286 287#| auxiliary function for both constructors: 288 (ds-make-constructor-body type name names size slotlist get-var) 289 returns the expression, that creates and fills a structure 290 of given type. 291|# 292(defun ds-make-constructor-body (type name names size slotlist varlist) 293 (if (and (or (eq type 'VECTOR) (eq type 'LIST)) 294 (do ((slotlistr slotlist (cdr slotlistr)) 295 (index 0 (1+ index))) 296 ((null slotlistr) (eql index size)) 297 (let* ((slot+initff (car slotlistr)) 298 (slot (car slot+initff))) 299 (unless (eq (clos:slot-definition-location slot) index) 300 (return nil))))) 301 ;; optimize the simple case 302 `(,type ,@(mapcar #'(lambda (slot+initff var) 303 (let ((slot (car slot+initff))) 304 (if (ds-real-slot-p slot) 305 `(THE ,(clos:slot-definition-type slot) ,var) 306 `(QUOTE ,(ds-pseudo-slot-default slot))))) 307 slotlist varlist)) 308 `(LET ((OBJECT 309 ,(cond ((eq type 'T) `(%MAKE-STRUCTURE ,names ,size)) 310 ((eq type 'LIST) `(MAKE-LIST ,size)) 311 ((consp type) 312 `(MAKE-ARRAY ,size :ELEMENT-TYPE ',(second type))) 313 (t `(MAKE-ARRAY ,size))))) 314 ,@(mapcar 315 #'(lambda (slot+initff var) 316 (let* ((slot (car slot+initff)) 317 (offset (clos:slot-definition-location slot))) 318 `(SETF 319 ,(cond ((eq type 'T) 320 `(%STRUCTURE-REF ',name OBJECT ,offset)) 321 ((eq type 'LIST) 322 `(NTH ,offset OBJECT)) 323 ((eq type 'VECTOR) 324 `(SVREF OBJECT ,offset)) 325 (t `(AREF OBJECT ,offset))) 326 ,(if (or (eq type 'T) (ds-real-slot-p slot)) 327 `(THE ,(clos:slot-definition-type slot) ,var) 328 `(QUOTE ,(ds-pseudo-slot-default slot)))))) 329 slotlist varlist) 330 OBJECT))) 331 332#| auxiliary function for ds-make-boa-constructor: 333 334 (ds-arg-with-default arg slotlist) 335 returns for an argument arg (part of the argument list) the part of 336 the argument list, that binds this argument with the correct default value. 337|# 338 339(defun ds-arg-with-default (arg slotlist) 340 (if (and (listp arg) (consp (cdr arg))) 341 ;; default value is already supplied 342 arg 343 ;; no default value in the lambda-list 344 (let* ((var (if (listp arg) (first arg) arg)) 345 (slot+initff (find (if (consp var) (second var) var) slotlist 346 :key #'(lambda (slot+initff) 347 (clos:slot-definition-name (car slot+initff))) 348 :test #'eq))) 349 (if slot+initff 350 ;; slot found -> take its default value 351 (ds-arg-default var slot+initff) 352 ;; slot not found, no default value 353 arg)))) 354 355#| (ds-make-boa-constructor descriptor type name names size slotlist whole-form) 356 returns the form that defines the BOA-constructor. 357|# 358(defun ds-make-boa-constructor (descriptor type name names size slotlist whole-form) 359 (let ((constructorname (first descriptor)) 360 (arglist (second descriptor))) 361 (multiple-value-bind (reqs optvars optinits optsvars rest 362 keyflag keywords keyvars keyinits keysvars 363 allow-other-keys auxvars auxinits) 364 (analyze-lambdalist arglist 365 #'(lambda (lalist detail errorstring &rest arguments) 366 (declare (ignore lalist)) ; use WHOLE-FORM instead 367 (sys::lambda-list-error whole-form detail 368 (TEXT "~S ~S: In ~S argument list: ~?") 369 'defstruct name ':constructor errorstring arguments))) 370 (let* ((argnames 371 ; The list of all arguments that are already supplied with 372 ; values through the parameter list. 373 (append reqs optvars (if (not (eql rest 0)) (list rest)) 374 keyvars auxvars)) 375 (new-arglist ; new argument list 376 `(;; required args: 377 ,@reqs 378 ;; optional args: 379 ,@(if optvars 380 (cons '&optional 381 (mapcar #'(lambda (arg var init svar) 382 (declare (ignore var init svar)) 383 (ds-arg-with-default arg slotlist)) 384 (cdr (memq '&optional arglist)) 385 optvars optinits optsvars)) 386 '()) 387 ;; &rest arg: 388 ,@(if (not (eql rest 0)) 389 (list '&rest rest) 390 '()) 391 ;; &key args: 392 ,@(if keyflag 393 (cons '&key 394 (append 395 (mapcar #'(lambda (arg symbol var init svar) 396 (declare (ignore symbol var init svar)) 397 (ds-arg-with-default arg slotlist)) 398 (cdr (memq '&key arglist)) 399 keywords keyvars keyinits keysvars) 400 (if allow-other-keys '(&allow-other-keys) '()))) 401 '()) 402 ;; &aux args: 403 &aux 404 ,@(mapcar #'(lambda (arg var init) 405 (declare (ignore var init)) 406 (ds-arg-with-default arg slotlist)) 407 (cdr (memq '&aux arglist)) 408 auxvars auxinits) 409 ,@(let ((slotinitlist nil)) 410 (dolist (slot+initff slotlist) 411 (let ((slot (car slot+initff))) 412 (when (or (eq type 'T) (ds-real-slot-p slot)) 413 (unless (memq (clos:slot-definition-name slot) argnames) 414 (push (ds-arg-with-default 415 (clos:slot-definition-name slot) slotlist) 416 slotinitlist))))) 417 (nreverse slotinitlist))))) 418 `(DEFUN ,constructorname ,new-arglist 419 ,(ds-make-constructor-body type name names size slotlist 420 (mapcar #'(lambda (slot+initff) 421 (clos:slot-definition-name (car slot+initff))) 422 slotlist))))))) 423 424#| (ds-make-keyword-constructor descriptor type name names size slotlist) 425 returns the form, that defines the keyword-constructor. |# 426(defun ds-make-keyword-constructor (descriptor type name names size slotlist) 427 (let ((varlist 428 (mapcar #'(lambda (slot+initff) 429 (let ((slot (car slot+initff))) 430 (if (or (eq type 'T) (ds-real-slot-p slot)) 431 (make-symbol 432 (symbol-name (clos:slot-definition-name slot))) 433 nil))) 434 slotlist))) 435 `(DEFUN ,descriptor 436 (&KEY 437 ,@(mapcan 438 #'(lambda (slot+initff var) 439 (let ((slot (car slot+initff))) 440 (if (or (eq type 'T) (ds-real-slot-p slot)) 441 (list (ds-arg-default var slot+initff)) 442 '()))) 443 slotlist varlist)) 444 ,(ds-make-constructor-body type name names size slotlist varlist)))) 445 446(defun ds-make-copier (copiername name type) 447 (declare (ignore name)) 448 `(,@(if (or (eq type 'T) (eq type 'LIST)) 449 `((PROCLAIM '(INLINE ,copiername))) 450 '()) 451 (DEFUN ,copiername (STRUCTURE) 452 ,(if (eq type 'T) 453 '(COPY-STRUCTURE STRUCTURE) 454 (if (eq type 'LIST) 455 '(COPY-LIST STRUCTURE) 456 (if (consp type) 457 `(LET* ((OBJ-LENGTH (ARRAY-TOTAL-SIZE STRUCTURE)) 458 (OBJECT (MAKE-ARRAY OBJ-LENGTH :ELEMENT-TYPE 459 (QUOTE ,(second type))))) 460 (DOTIMES (I OBJ-LENGTH OBJECT) 461 (SETF (AREF OBJECT I) (AREF STRUCTURE I)))) 462 '(%COPY-SIMPLE-VECTOR STRUCTURE))))))) 463 464(defun ds-accessor-name (slotname concname) 465 (if concname 466 (concat-pnames concname slotname) 467 slotname)) 468 469(defun ds-make-readers (name names type concname slotlist) 470 (mapcap 471 #'(lambda (slot+initff) 472 (let ((slot (car slot+initff))) 473 (when (or (eq type 'T) (ds-real-slot-p slot)) 474 (let ((accessorname (ds-accessor-name (clos:slot-definition-name slot) concname)) 475 (offset (clos:slot-definition-location slot)) 476 (slottype (clos:slot-definition-type slot))) 477 ;; This makes the macroexpansion depend on the current state 478 ;; of the compilation environment, but it doesn't hurt because 479 ;; the included structure's definition must already be 480 ;; present in the compilation environment anyway. We don't expect 481 ;; people to re-DEFUN defstruct accessors. 482 (unless (memq (get accessorname 'SYSTEM::DEFSTRUCT-READER name) 483 (cdr names)) 484 `((PROCLAIM '(FUNCTION ,accessorname (,name) ,slottype)) 485 (PROCLAIM '(INLINE ,accessorname)) 486 (DEFUN ,accessorname (OBJECT) 487 (THE ,slottype 488 ,(cond ((eq type 'T) 489 `(%STRUCTURE-REF ',name OBJECT ,offset)) 490 ((eq type 'LIST) `(NTH ,offset OBJECT)) 491 ((consp type) `(AREF OBJECT ,offset)) 492 (t `(SVREF OBJECT ,offset))))) 493 (SYSTEM::%PUT ',accessorname 'SYSTEM::DEFSTRUCT-READER 494 ',name))))))) 495 slotlist)) 496 497(defun ds-make-writers (name names type concname slotlist) 498 (mapcap 499 #'(lambda (slot+initff) 500 (let ((slot (car slot+initff))) 501 (when (and (or (eq type 'T) (ds-real-slot-p slot)) 502 (not (clos::structure-effective-slot-definition-readonly slot))) 503 (let ((accessorname (ds-accessor-name (clos:slot-definition-name slot) concname)) 504 (offset (clos:slot-definition-location slot)) 505 (slottype (clos:slot-definition-type slot))) 506 ;; This makes the macroexpansion depend on the current state 507 ;; of the compilation environment, but it doesn't hurt because 508 ;; the included structure's definition must already be 509 ;; present in the compilation environment anyway. We don't expect 510 ;; people to re-DEFUN or re-DEFSETF defstruct accessors. 511 (unless (memq (get accessorname 'SYSTEM::DEFSTRUCT-WRITER name) 512 (cdr names)) 513 `((PROCLAIM '(FUNCTION (SETF ,accessorname) (,slottype ,name) ,slottype)) 514 (PROCLAIM '(INLINE (SETF ,accessorname))) 515 (DEFUN (SETF ,accessorname) (VALUE OBJECT) 516 ,(if (eq type 'T) 517 `(%STRUCTURE-STORE ',name 518 OBJECT 519 ,offset 520 ,(if (eq 'T slottype) 521 `VALUE 522 `(THE ,slottype VALUE))) 523 (if (eq type 'LIST) 524 `(SETF (NTH ,offset OBJECT) VALUE) 525 (if (consp type) 526 `(SETF (AREF OBJECT ,offset) VALUE) 527 `(SETF (SVREF OBJECT ,offset) VALUE))))) 528 (SYSTEM::%PUT ',accessorname 'SYSTEM::DEFSTRUCT-WRITER 529 ',name))))))) 530 slotlist)) 531 532(defun find-structure-class-slot-initfunction (classname slotname) ; ABI 533 (let ((class (find-class classname))) 534 (unless (clos::structure-class-p class) 535 (error (TEXT "The class ~S is not a structure class: ~S") 536 classname class)) 537 (let* ((slots (clos:class-slots class)) 538 (slot 539 ; (find slotname (the list) slots :test #'clos:slot-definition-name) 540 (dolist (s slots) 541 (when (eql (clos:slot-definition-name s) slotname) (return s))))) 542 (unless slot 543 (error (TEXT "The class ~S has no slot named ~S.") 544 classname slotname)) 545 (clos:slot-definition-initfunction slot)))) 546 547(defun find-structure-slot-initfunction (name slotname) ; ABI 548 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 549 (unless desc 550 (if (clos::defined-class-p (get name 'CLOS::CLOSCLASS)) 551 (error (TEXT "The structure type ~S has been defined as a class.") 552 name) 553 (error (TEXT "The structure type ~S has not been defined.") 554 name))) 555 (let* ((slots (svref desc *defstruct-description-slots-location*)) 556 (slot 557 ; (find slotname (the list) slots :test #'clos:slot-definition-name) 558 (dolist (s slots) 559 (when (eql (clos:slot-definition-name s) slotname) (return s))))) 560 (unless slot 561 (error (TEXT "The structure type ~S has no slot named ~S.") 562 name slotname)) 563 (clos:slot-definition-initfunction slot)))) 564 565(defun ds-initfunction-fetcher (name type slotname) 566 (if (eq type 'T) 567 `(FIND-STRUCTURE-CLASS-SLOT-INITFUNCTION ',name ',slotname) 568 `(FIND-STRUCTURE-SLOT-INITFUNCTION ',name ',slotname))) 569 570;; A hook for CLOS 571(predefun clos::defstruct-remove-print-object-method (name) ; preliminary 572 (declare (ignore name)) 573 nil) 574 575(defun make-load-form-slot-list (slotlist default-slots default-vars mlf) 576 (mapcar #'(lambda (slot+initff) 577 (let ((slot (car slot+initff))) 578 (funcall mlf 579 slot 580 (let ((i (position slot+initff default-slots))) 581 (if i (nth i default-vars) (cdr slot+initff)))))) 582 slotlist)) 583 584(defmacro defstruct (&whole whole-form 585 name-and-options . docstring-and-slotargs) 586 (let ((name name-and-options) 587 (options nil) 588 (conc-name-option t) 589 (constructor-option-list nil) 590 (keyword-constructor nil) 591 (boa-constructors '()) 592 (copier-option t) 593 (predicate-option 0) 594 (include-option nil) 595 names 596 namesform 597 (namesbinding nil) 598 (print-object-option nil) 599 (type-option t) 600 (named-option 0) 601 (initial-offset-option 0) 602 (initial-offset 0) 603 (docstring nil) 604 (slotargs docstring-and-slotargs) 605 (directslotlist nil) ; list of (slot . initff) 606 size 607 (include-skip 0) 608 (inherited-slot-count 0) 609 (slotlist nil) ; list of (slot . initff) 610 (slotdefaultvars nil) 611 (slotdefaultfuns nil) 612 (slotdefaultslots nil) ; list of (slot . initff) 613 (slotdefaultdirectslots nil) ; list of (slot . initff) 614 constructor-forms ) 615 ;; check name-and-options: 616 (when (listp name-and-options) 617 (setq name (first name-and-options)) 618 (setq options (rest name-and-options))) 619 ;; otherwise, name and options are already correct. 620 (setq name (check-not-declaration name 'defstruct)) 621 ;; name is a symbol, options is the list of options. 622 ;; processing the options: 623 (dolist (option options) 624 (when (keywordp option) (setq option (list option))) ; option without arguments 625 (if (listp option) 626 (if (keywordp (car option)) 627 (case (first option) 628 (:CONC-NAME 629 (setq conc-name-option (second option))) 630 (:CONSTRUCTOR 631 (if (atom (cdr option)) 632 ;; default-keyword-constructor 633 (push (concat-pnames "MAKE-" name) constructor-option-list) 634 (let ((arg (second option))) 635 (setq arg (check-symbol arg 'defstruct)) 636 (push 637 (if (atom (cddr option)) 638 arg ; keyword-constructor 639 (if (not (listp (third option))) 640 (error-of-type 'source-program-error 641 :form whole-form 642 :detail (third option) 643 (TEXT "~S ~S: argument list should be a list: ~S") 644 'defstruct name (third option)) 645 (rest option))) ; BOA-constructor 646 constructor-option-list)))) 647 (:COPIER 648 (when (consp (cdr option)) 649 (let ((arg (second option))) 650 (setq arg (check-symbol arg 'defstruct)) 651 (setq copier-option arg)))) 652 (:PREDICATE 653 (when (consp (cdr option)) 654 (let ((arg (second option))) 655 (setq arg (check-symbol arg 'defstruct)) 656 (setq predicate-option arg)))) 657 ((:INCLUDE :INHERIT) 658 (if (null include-option) 659 (setq include-option option) 660 (error-of-type 'source-program-error 661 :form whole-form 662 :detail options 663 (TEXT "~S ~S: At most one :INCLUDE argument may be specified: ~S") 664 'defstruct name options))) 665 ((:PRINT-FUNCTION :PRINT-OBJECT) 666 (if (null (cdr option)) 667 (setq print-object-option '(PRINT-STRUCTURE STRUCT STREAM)) 668 (let ((arg (second option))) 669 (when (and (consp arg) (eq (first arg) 'FUNCTION)) 670 (warn (TEXT "~S: Use of ~S implicitly applies FUNCTION.~@ 671 Therefore using ~S instead of ~S.") 672 'defstruct (first option) (second arg) arg) 673 (setq arg (second arg))) 674 (setq print-object-option 675 `(,arg STRUCT STREAM 676 ,@(if (eq (first option) ':PRINT-FUNCTION) 677 '(*PRIN-LEVEL*) '())))))) 678 (:TYPE (setq type-option (second option))) 679 (:NAMED (setq named-option t)) 680 (:INITIAL-OFFSET (setq initial-offset-option (or (second option) 0))) 681 (T (error-of-type 'source-program-error 682 :form whole-form 683 :detail (first option) 684 (TEXT "~S ~S: unknown option ~S") 685 'defstruct name (first option)))) 686 (error-of-type 'source-program-error 687 :form whole-form 688 :detail option 689 (TEXT "~S ~S: invalid syntax in ~S option: ~S") 690 'defstruct name 'defstruct option)) 691 (error-of-type 'source-program-error 692 :form whole-form 693 :detail option 694 (TEXT "~S ~S: not a ~S option: ~S") 695 'defstruct name 'defstruct option))) 696 ;;; conc-name-option is either T or NIL or the :CONC-NAME argument. 697 ;; constructor-option-list is a list of all :CONSTRUCTOR-arguments, 698 ;; each in the form symbol or (symbol arglist . ...). 699 ;; copier-option is either T or the :COPIER-argument. 700 ;; predicate-option is either 0 or the :PREDICATE-argument. 701 ;; include-option is either NIL or the entire 702 ;; :INCLUDE/:INHERIT-option. 703 ;; print-object-option is NIL or a form for the body of the PRINT-OBJECT 704 ;; method. 705 ;; type-option is either T or the :TYPE-argument. 706 ;; named-option is either 0 or T. 707 ;; initial-offset-option is either 0 or the :INITIAL-OFFSET-argument. 708 ;;; inspection of the options: 709 (setq named-option (or (eq type-option 'T) (eq named-option 'T))) 710 ;; named-option (NIL or T) specifies, if the name is in the structure. 711 (if named-option 712 (when (eql predicate-option 0) 713 (setq predicate-option (concat-pnames name "-P"))) ; defaultname 714 (if (or (eql predicate-option 0) (eq predicate-option 'NIL)) 715 (setq predicate-option 'NIL) 716 (error-of-type 'source-program-error 717 :form whole-form 718 :detail predicate-option 719 (TEXT "~S ~S: There is no ~S for unnamed structures.") 720 'defstruct name :predicate))) 721 ;; predicate-option is 722 ;; if named-option=T: either NIL or the name of the type-test-predicate, 723 ;; if named-option=NIL meaningless. 724 (when (eq conc-name-option 'T) 725 (setq conc-name-option (string-concat (string name) "-"))) 726 ;; conc-name-option is the name prefix. 727 (if constructor-option-list 728 (setq constructor-option-list (remove 'NIL constructor-option-list)) 729 (setq constructor-option-list (list (concat-pnames "MAKE-" name)))) 730 ;; constructor-option-list is a list of all constructors that have to be 731 ;; created, each in the form symbol or (symbol arglist . ...). 732 (if (eq copier-option 'T) 733 (setq copier-option (concat-pnames "COPY-" name))) 734 ;; copier-option is either NIL or the name of the copy function. 735 (unless (or (eq type-option 'T) 736 (eq type-option 'VECTOR) 737 (eq type-option 'LIST) 738 (and (consp type-option) (eq (first type-option) 'VECTOR))) 739 (error-of-type 'source-program-error 740 :form whole-form 741 :detail type-option 742 (TEXT "~S ~S: invalid :TYPE option ~S") 743 'defstruct name type-option)) 744 ;; type-option is either T or LIST or VECTOR or (VECTOR ...) 745 (unless (and (integerp initial-offset-option) (>= initial-offset-option 0)) 746 (error-of-type 'source-program-error 747 :form whole-form 748 :detail initial-offset-option 749 (TEXT "~S ~S: The :INITIAL-OFFSET must be a nonnegative integer, not ~S") 750 'defstruct name initial-offset-option)) 751 ;; initial-offset-option is an Integer >=0. 752 (when (and (plusp initial-offset-option) (eq type-option 'T)) 753 (error-of-type 'source-program-error 754 :form whole-form 755 :detail options 756 (TEXT "~S ~S: :INITIAL-OFFSET must not be specified without :TYPE : ~S") 757 'defstruct name options)) 758 ;; if type-option=T, then initial-offset-option=0. 759 (when (eq type-option 'T) (setq include-skip 1)) 760 ;; if type-option=T, include-skip is 1, else 0. 761 (when (stringp (first docstring-and-slotargs)) 762 (setq docstring (first docstring-and-slotargs)) 763 (setq slotargs (rest docstring-and-slotargs))) 764 ;; else, docstring and slotargs are already correct. 765 ;; docstring is either NIL or a String. 766 ;; slotargs are the remaining arguments. 767 (if include-option 768 (let* ((option (rest include-option)) 769 (subname (first option)) 770 (incl-class (get subname 'CLOS::CLOSCLASS)) 771 (incl-desc (get subname 'DEFSTRUCT-DESCRIPTION))) 772 (unless (clos::defined-class-p incl-class) 773 (setq incl-class nil)) 774 (when (and (null incl-class) (null incl-desc)) 775 (error-of-type 'source-program-error 776 :form whole-form 777 :detail subname 778 (TEXT "~S ~S: included structure ~S has not been defined.") 779 'defstruct name subname)) 780 (when (and incl-class (not (clos::structure-class-p incl-class))) 781 (error-of-type 'source-program-error 782 :form whole-form 783 :detail subname 784 (TEXT "~S ~S: included structure ~S is not a structure type.") 785 'defstruct name subname)) 786 (when incl-class 787 (setq names (cons name (clos::class-names incl-class))) 788 (setq namesbinding 789 (list 790 (list 791 (setq namesform (gensym)) 792 `(CONS ',name (CLOS::CLASS-NAMES (GET ',subname 'CLOS::CLOSCLASS))))))) 793 (unless (equalp (if incl-class 't (svref incl-desc *defstruct-description-type-location*)) type-option) 794 (error-of-type 'source-program-error 795 :form whole-form 796 :detail subname 797 (TEXT "~S ~S: included structure ~S must be of the same type ~S.") 798 'defstruct name subname type-option)) 799 (setq slotlist 800 (nreverse 801 (mapcar #'(lambda (slot) 802 (cons (copy-<structure-effective-slot-definition> slot) 803 (ds-initfunction-fetcher subname type-option 804 (clos:slot-definition-name slot)))) 805 (if incl-class 806 (clos:class-slots incl-class) 807 (svref incl-desc *defstruct-description-slots-location*))))) 808 ;; slotlist is the reversed list of the inherited slots. 809 (setq include-skip (if incl-class 810 (clos::class-instance-size incl-class) 811 (svref incl-desc *defstruct-description-size-location*))) 812 (when slotlist 813 (assert (> include-skip (clos:slot-definition-location (car (first slotlist)))))) 814 ;; include-skip >=0 is the number of slots that are already consumend 815 ;; by the substructure, the "size" of the substructure. 816 ;; Process further arguments of the :INCLUDE-option: 817 (dolist (slotarg (rest option)) 818 (let* ((slotname (if (atom slotarg) slotarg (first slotarg))) 819 (slot+initff (find slotname slotlist 820 :key #'(lambda (slot+initff) 821 (clos:slot-definition-name (car slot+initff))) 822 :test #'eq))) 823 (when (null slot+initff) 824 (error-of-type 'source-program-error 825 :form whole-form 826 :detail slotname 827 (TEXT "~S ~S: included structure ~S has no component with name ~S.") 828 'defstruct name subname slotname)) 829 (let ((slot (car slot+initff))) 830 (if (atom slotarg) 831 ; overwrite default to NIL 832 (progn 833 (setf (clos::slot-definition-inheritable-initer slot) 834 (cons 'NIL (make-constant-initfunction 'NIL))) 835 (setf (cdr slot+initff) `(MAKE-CONSTANT-INITFUNCTION NIL))) 836 (progn 837 (let ((initform (second slotarg))) 838 (if (constantp initform) 839 (progn 840 (setf (clos::slot-definition-inheritable-initer slot) 841 (cons initform (make-constant-initfunction (eval initform)))) 842 (setf (cdr slot+initff) `(MAKE-CONSTANT-INITFUNCTION ,initform))) 843 (progn 844 (setf (clos::slot-definition-inheritable-initer slot) 845 (cons initform nil)) ; FIXME 846 (setf (cdr slot+initff) 847 `(FUNCTION ,(concat-pnames "DEFAULT-" slotname) 848 (LAMBDA () ,initform)))))) 849 ;; Process the slot-options of this Slot-Specifier: 850 (do ((slot-arglistr (cddr slotarg) (cddr slot-arglistr))) 851 ((endp slot-arglistr)) 852 (let ((slot-keyword (first slot-arglistr)) 853 (slot-key-value (second slot-arglistr))) 854 (cond ((eq slot-keyword ':READ-ONLY) 855 (if slot-key-value 856 (setf (clos::structure-effective-slot-definition-readonly slot) t) 857 (if (clos::structure-effective-slot-definition-readonly slot) 858 (error-of-type 'source-program-error 859 :form whole-form 860 :detail subname 861 (TEXT "~S ~S: The READ-ONLY slot ~S of the included structure ~S must remain READ-ONLY in ~S.") 862 'defstruct name slotname subname name) 863 (setf (clos::structure-effective-slot-definition-readonly slot) nil)))) 864 ((eq slot-keyword ':TYPE) 865 (unless 866 (subtypep 867 (type-for-discrimination slot-key-value) 868 (type-for-discrimination (clos:slot-definition-type slot))) 869 (error-of-type 'source-program-error 870 :form whole-form 871 :detail subname 872 (TEXT "~S ~S: The type ~S of slot ~S should be a subtype of the type defined for the included strucure ~S, namely ~S.") 873 'defstruct name slot-key-value slotname subname 874 (clos:slot-definition-type slot))) 875 (setf (clos:slot-definition-type slot) slot-key-value)) 876 (t (error-of-type 'source-program-error 877 :form whole-form 878 :detail slot-keyword 879 (TEXT "~S ~S: ~S is not a slot option.") 880 'defstruct name slot-keyword))))))) 881 (push (cons 882 (clos::make-instance-<structure-direct-slot-definition> 883 clos::<structure-direct-slot-definition> 884 :name slotname 885 :initform (clos:slot-definition-initform slot) 886 :initfunction (clos:slot-definition-initfunction slot) 887 :initargs (clos:slot-definition-initargs slot) 888 :type (clos:slot-definition-type slot) 889 'clos::inheritable-initer (clos::slot-definition-inheritable-initer slot) 890 ;; no readers/writers: these are inherited slots 891 :readers '() 892 :writers '()) 893 (cdr slot+initff)) 894 directslotlist)))) 895 (dolist (slot+initff slotlist) 896 (let* ((slot (car slot+initff)) 897 (initfunction (clos:slot-definition-initfunction slot))) 898 (unless (or (null initfunction) (constant-initfunction-p initfunction)) 899 (let ((variable (gensym))) 900 (push (cdr slot+initff) slotdefaultfuns) 901 (push variable slotdefaultvars) 902 (push slot+initff slotdefaultslots) 903 (push nil slotdefaultdirectslots) 904 (setf (cdr slot+initff) variable))))) 905 (when (eq (first include-option) ':INHERIT) 906 (setq inherited-slot-count (length slotlist)))) 907 (if (eq name 'STRUCTURE-OBJECT) 908 (setq names (list name) 909 namesform `',names) 910 (setq names (cons name (clos::class-names (get 'STRUCTURE-OBJECT 'CLOS::CLOSCLASS))) 911 namesbinding 912 (list 913 (list 914 (setq namesform (gensym)) 915 `(CONS ',name (CLOS::CLASS-NAMES (GET 'STRUCTURE-OBJECT 'CLOS::CLOSCLASS)))))))) 916 ;; names is the include-nesting, namesform is the form belonging to it. 917 ;; slotlist is the former slot list, reversed. 918 ;; inherited-slot-count is the number of slots, that have to be ignored 919 ;; when the accessors are created. 920 (when (and named-option ; named structure 921 (consp type-option) ; of type (VECTOR ...) 922 ;; must be able to contain the name(s): 923 (not (typep names (type-for-discrimination (second type-option))))) 924 (error-of-type 'source-program-error 925 :form whole-form 926 :detail type-option 927 (TEXT "~S ~S: structure of type ~S cannot hold the name.") 928 'defstruct name type-option)) 929 ;; layout of the structure: 930 ;; names, poss. include-slots, initial-offset-option times NIL, slots. 931 ;; layout of vector or list: 932 ;; include-part, initial-offset-option times NIL, poss. name, slots. 933 (setq initial-offset (+ include-skip initial-offset-option)) 934 (unless (eq type-option 'T) 935 (when named-option 936 (push 937 ; the type recognition pseudo-slot 938 (cons 939 (make-ds-slot nil 940 '() 941 initial-offset 942 (cons `(QUOTE ,name) (make-constant-initfunction name)) 943 'SYMBOL ; type = symbol 944 T) ; read-only 945 `(MAKE-CONSTANT-INITFUNCTION ',name)) 946 slotlist) 947 (incf initial-offset))) 948 ;; the slots are situated behind initial-offset. 949 ;; If type/=T (i.e vector or list) and named-option, the name is situated 950 ;; in Slot number (1- initial-offset). 951 ;; processing the slots: 952 (let ((offset initial-offset)) 953 (dolist (slotarg slotargs) 954 (let (slotname 955 initform 956 initfunction 957 initfunctionform) 958 (if (atom slotarg) 959 (setq slotname slotarg initform nil) 960 (setq slotname (first slotarg) initform (second slotarg))) 961 ;; Here we compare slot names through their symbol-names, not through 962 ;; #'eq, because if we have two slots P::X and Q::X, the two accessor 963 ;; functions would have the same name FOO-X. 964 (when (find (symbol-name slotname) slotlist 965 :test #'(lambda (name slot+initff) 966 (let ((slot (car slot+initff))) 967 (and (or (eq type-option 'T) (ds-real-slot-p slot)) 968 (string= (clos:slot-definition-name slot) name))))) 969 (error-of-type 'source-program-error 970 :form whole-form 971 :detail slotname 972 (TEXT "~S ~S: There may be only one slot with the name ~S.") 973 'defstruct name slotname)) 974 (let ((type t) (read-only nil)) 975 (when (consp slotarg) 976 (do ((slot-arglistr (cddr slotarg) (cddr slot-arglistr))) 977 ((endp slot-arglistr)) 978 (let ((slot-keyword (first slot-arglistr)) 979 (slot-key-value (second slot-arglistr))) 980 (cond ((eq slot-keyword ':READ-ONLY) 981 (setq read-only (if slot-key-value t nil))) 982 ((eq slot-keyword ':TYPE) (setq type slot-key-value)) 983 (t (error-of-type 'source-program-error 984 :form whole-form 985 :detail slot-keyword 986 (TEXT "~S ~S: ~S is not a slot option.") 987 'defstruct name slot-keyword)))))) 988 (if (constantp initform) 989 (setq initfunction (make-constant-initfunction (eval initform)) 990 initfunctionform `(MAKE-CONSTANT-INITFUNCTION ,initform)) 991 (let ((variable (gensym))) 992 (push 993 `(FUNCTION ,(concat-pnames "DEFAULT-" slotname) 994 (LAMBDA () ,initform)) 995 slotdefaultfuns) 996 (push variable slotdefaultvars) 997 (setq initfunction nil ; FIXME 998 initfunctionform variable))) 999 (let ((initer (cons initform initfunction)) 1000 (initargs (list (symbol-to-keyword slotname))) 1001 (accessorname (ds-accessor-name slotname conc-name-option))) 1002 (when (eq predicate-option accessorname) 1003 (warn 1004 (TEXT "~S ~S: Slot ~S accessor will shadow the predicate ~S.") 1005 'defstruct name slotname predicate-option) 1006 (setq predicate-option nil)) 1007 (push (cons 1008 (clos::make-instance-<structure-direct-slot-definition> 1009 clos::<structure-direct-slot-definition> 1010 :name slotname 1011 :initform initform 1012 :initfunction initfunction 1013 :initargs initargs 1014 :type type 1015 'clos::inheritable-initer initer 1016 ;; we cannot recover accessor names later 1017 ;; because of the :CONC-NAME option 1018 :writers (if read-only '() (list `(SETF ,accessorname))) 1019 :readers (list accessorname)) 1020 initfunctionform) 1021 directslotlist) 1022 (push (cons 1023 (make-ds-slot slotname 1024 initargs 1025 offset ; location 1026 initer 1027 ;; The following are defstruct specific. 1028 type read-only) 1029 initfunctionform) 1030 slotlist) 1031 (unless (constantp initform) 1032 (push (car slotlist) slotdefaultslots) 1033 (push (car directslotlist) slotdefaultdirectslots))))) 1034 (incf offset)) 1035 (setq size offset)) 1036 ;; size = total length of the structure 1037 (setq slotlist (nreverse slotlist)) 1038 (setq directslotlist (nreverse directslotlist)) 1039 (setq slotdefaultfuns (nreverse slotdefaultfuns)) 1040 (setq slotdefaultvars (nreverse slotdefaultvars)) 1041 (setq slotdefaultslots (nreverse slotdefaultslots)) 1042 (setq slotdefaultdirectslots (nreverse slotdefaultdirectslots)) 1043 ;; the slots in slotlist are now sorted in ascending order again. 1044 (setq constructor-forms 1045 (mapcar 1046 #'(lambda (constructor-option) 1047 (if (consp constructor-option) 1048 (ds-make-boa-constructor 1049 constructor-option type-option name namesform size slotlist whole-form) 1050 (progn 1051 (when (null keyword-constructor) 1052 (setq keyword-constructor constructor-option)) 1053 (ds-make-keyword-constructor 1054 constructor-option type-option name namesform size 1055 slotlist)))) 1056 constructor-option-list)) 1057 (setq boa-constructors 1058 (mapcan #'(lambda (constructor-option) 1059 (when (consp constructor-option) 1060 (list (first constructor-option)))) 1061 constructor-option-list)) 1062 ;; constructor-forms = list of forms, that define the constructors. 1063 (mapc #'(lambda (slot+initff directslot+initff) 1064 (let* ((slot (car slot+initff)) 1065 (initfunctionform 1066 (ds-initfunction-fetcher name type-option (clos:slot-definition-name slot)))) 1067 (setf (cdr slot+initff) initfunctionform) 1068 (when directslot+initff 1069 (setf (cdr directslot+initff) initfunctionform)))) 1070 slotdefaultslots slotdefaultdirectslots) 1071 ;; now, slotlist contains no more slotdefaultvars. 1072 `(EVAL-WHEN (LOAD COMPILE EVAL) 1073 (LET () 1074 (LET ,(append namesbinding (mapcar #'list slotdefaultvars slotdefaultfuns)) 1075 ;; ANSI CL doesn't specify what happens when a structure is 1076 ;; redefined with different specification. We do here what DEFCLASS 1077 ;; also does: remove the accessory functions defined by the previous 1078 ;; specification. 1079 (STRUCTURE-UNDEFINE-ACCESSORIES ',name) 1080 ,(if (eq type-option 'T) 1081 `(REMPROP ',name 'DEFSTRUCT-DESCRIPTION) 1082 `(%PUT ',name 'DEFSTRUCT-DESCRIPTION 1083 (VECTOR ',type-option 1084 ,size 1085 ',keyword-constructor 1086 (LIST ,@(make-load-form-slot-list 1087 slotlist slotdefaultslots slotdefaultvars 1088 'clos::make-load-form-<structure-effective-slot-definition>)) 1089 (LIST ,@(make-load-form-slot-list 1090 directslotlist slotdefaultdirectslots 1091 slotdefaultvars 1092 'clos::make-load-form-<structure-direct-slot-definition>)) 1093 ',boa-constructors 1094 ',copier-option 1095 ',predicate-option))) 1096 ,@(if (eq type-option 'T) 1097 `((CLOS::DEFINE-STRUCTURE-CLASS ',name 1098 ,namesform 1099 ',keyword-constructor 1100 ',boa-constructors 1101 ',copier-option 1102 ',predicate-option 1103 (LIST ,@(make-load-form-slot-list 1104 slotlist slotdefaultslots slotdefaultvars 1105 'clos::make-load-form-<structure-effective-slot-definition>)) 1106 (LIST ,@(make-load-form-slot-list 1107 directslotlist slotdefaultdirectslots slotdefaultvars 1108 'clos::make-load-form-<structure-direct-slot-definition>)) 1109 ',docstring)) 1110 `((CLOS::UNDEFINE-STRUCTURE-CLASS ',name) 1111 ;; see documentation.lisp: we map STRUCTURE to TYPE 1112 (sys::%set-documentation ',name 'TYPE ',docstring))) 1113 ,@constructor-forms) 1114 ,@(if (and named-option predicate-option) 1115 (ds-make-pred predicate-option type-option name slotlist size)) 1116 ,@(if copier-option (ds-make-copier copier-option name type-option)) 1117 ,@(let ((directslotlist (nthcdr inherited-slot-count slotlist))) 1118 `(,@(ds-make-readers name names type-option conc-name-option 1119 directslotlist) 1120 ,@(ds-make-writers name names type-option conc-name-option 1121 directslotlist))) 1122 ,@(when (eq type-option 'T) 1123 (list 1124 (if print-object-option 1125 `(CLOS:DEFMETHOD CLOS:PRINT-OBJECT ((STRUCT ,name) STREAM) 1126 (PROGN ,print-object-option)) 1127 `(CLOS::DEFSTRUCT-REMOVE-PRINT-OBJECT-METHOD ',name)))) 1128 ',name)))) 1129 1130 1131;; A kind of Meta-Object Protocol for structures. 1132;; These function apply to structures of any representation 1133;; (structure classes as well as subtypes of LIST or VECTOR). 1134;; This differs from the CLOS MOP 1135;; 1. in the use of a structure name (symbol) instead of a class, 1136;; 2. in the different set of available operations: classes in general 1137;; don't have kconstructors, boa-constructors, copier, predicate, 1138;; whereas on the other hand structures in general don't have a prototype 1139;; and finalization. 1140 1141(defun structure-slots (name) 1142 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1143 (if desc 1144 (svref desc *defstruct-description-slots-location*) 1145 (let ((class (find-class name))) 1146 (clos::accessor-typecheck class 'structure-class 'structure-slots) 1147 (clos::class-slots class))))) 1148#| 1149 (defun (setf structure-slots) (new-value name) 1150 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1151 (if desc 1152 (setf (svref desc *defstruct-description-slots-location*) new-value) 1153 (let ((class (find-class name))) 1154 (clos::accessor-typecheck class 'structure-class '(setf structure-slots)) 1155 (setf (clos::class-slots class) new-value))))) 1156|# 1157 1158(defun structure-direct-slots (name) 1159 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1160 (if desc 1161 (svref desc *defstruct-description-direct-slots-location*) 1162 (let ((class (find-class name))) 1163 (clos::accessor-typecheck class 'structure-class 'structure-direct-slots) 1164 (clos::class-direct-slots class))))) 1165#| 1166 (defun (setf structure-slots) (new-value name) 1167 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1168 (if desc 1169 (setf (svref desc *defstruct-description-direct-slots-location*) new-value) 1170 (let ((class (find-class name))) 1171 (clos::accessor-typecheck class 'structure-class '(setf structure-direct-slots)) 1172 (setf (clos::class-direct-slots class) new-value))))) 1173|# 1174 1175(defun structure-instance-size (name) 1176 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1177 (if desc 1178 (svref desc *defstruct-description-size-location*) 1179 (let ((class (find-class name))) 1180 (clos::accessor-typecheck class 'structure-class 'structure-instance-size) 1181 (clos::class-instance-size class))))) 1182#| 1183 (defun (setf structure-instance-size) (new-value name) 1184 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1185 (if desc 1186 (setf (svref desc *defstruct-description-size-location*) new-value) 1187 (let ((class (find-class name))) 1188 (clos::accessor-typecheck class 'structure-class '(setf structure-instance-size)) 1189 (setf (clos::class-instance-size class) new-value))))) 1190|# 1191 1192(defun structure-keyword-constructor (name) 1193 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1194 (if desc 1195 (svref desc *defstruct-description-kconstructor-location*) 1196 (clos::class-kconstructor (find-class name))))) 1197#| 1198 (defun (setf structure-keyword-constructor) (new-value name) 1199 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1200 (if desc 1201 (setf (svref desc *defstruct-description-kconstructor-location*) new-value) 1202 (setf (clos::class-kconstructor (find-class name)) new-value)))) 1203|# 1204 1205(defun structure-boa-constructors (name) 1206 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1207 (if desc 1208 (svref desc *defstruct-description-boa-constructors-location*) 1209 (clos::class-boa-constructors (find-class name))))) 1210#| 1211 (defun (setf structure-boa-constructors) (new-value name) 1212 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1213 (if desc 1214 (setf (svref desc *defstruct-description-boa-constructors-location*) new-value) 1215 (setf (clos::class-boa-constructors (find-class name)) new-value)))) 1216|# 1217 1218(defun structure-copier (name) 1219 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1220 (if desc 1221 (svref desc *defstruct-description-copier-location*) 1222 (clos::class-copier (find-class name))))) 1223#| 1224 (defun (setf structure-copier) (new-value name) 1225 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1226 (if desc 1227 (setf (svref desc *defstruct-description-copier-location*) new-value) 1228 (setf (clos::class-copier (find-class name)) new-value)))) 1229|# 1230 1231(defun structure-predicate (name) 1232 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1233 (if desc 1234 (svref desc *defstruct-description-predicate-location*) 1235 (clos::class-predicate (find-class name))))) 1236#| 1237 (defun (setf structure-predicate) (new-value name) 1238 (let ((desc (get name 'DEFSTRUCT-DESCRIPTION))) 1239 (if desc 1240 (setf (svref desc *defstruct-description-predicate-location*) new-value) 1241 (setf (clos::class-predicate (find-class name)) new-value)))) 1242|# 1243 1244(defun structure-undefine-accessories (name) ; ABI 1245 (when (or (get name 'DEFSTRUCT-DESCRIPTION) 1246 (clos::structure-class-p (find-class name nil))) 1247 (macrolet ((fmakunbound-if-present (symbol-form) 1248 `(let ((symbol ,symbol-form)) 1249 (when symbol (fmakunbound symbol))))) 1250 (fmakunbound-if-present (structure-keyword-constructor name)) 1251 (mapc #'fmakunbound (structure-boa-constructors name)) 1252 (fmakunbound-if-present (structure-copier name)) 1253 (fmakunbound-if-present (structure-predicate name)) 1254 (dolist (slot (structure-direct-slots name)) 1255 (mapc #'fmakunbound (clos::slot-definition-readers slot)) 1256 (mapc #'fmakunbound (clos::slot-definition-writers slot)))))) 1257