/[cmucl]/src/code/defstruct.lisp
ViewVC logotype

Contents of /src/code/defstruct.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7.2.3 - (hide annotations)
Thu Apr 5 23:59:37 1990 UTC (24 years ago) by wlott
Changes since 1.7.2.2: +4 -2 lines
Use vm:vector-structure-type instead of %g-vector-structure-type when under
the new-compiler.
1 ram 1.1 ;;; -*- Log: code.log; Package: C -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;; This code was written as part of the Spice Lisp project at
5     ;;; Carnegie-Mellon University, and has been placed in the public domain.
6     ;;; If you want to use this code or any part of Spice Lisp, please contact
7     ;;; Scott Fahlman (FAHLMAN@CMUC).
8     ;;; **********************************************************************
9     ;;;
10 wlott 1.7.2.3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/code/defstruct.lisp,v 1.7.2.3 1990/04/05 23:59:37 wlott Exp $
11 wlott 1.7.2.1 ;;;
12 ram 1.1 ;;; Defstruct structure definition package (Mark II).
13     ;;; Written by Skef Wholey and Rob MacLachlan.
14     ;;;
15     (in-package 'c)
16     (export '(lisp::defstruct) "LISP")
17    
18     ;;; In Spice Lisp, the default structure representation is a simple-vector with
19     ;;; the subtype field set to 1. The first element is used to hold the name of
20     ;;; the structure. This piece of implementation-dependency resides in the
21     ;;; macros defined here.
22 ram 1.2 ;;;
23     (proclaim '(inline structurify))
24     (defun structurify (structure)
25     "Frobs a vector to turn it into a named structure. Returns the vector."
26 wlott 1.7.2.3 (%primitive set-vector-subtype structure
27     #+new-compiler vm:vector-structure-subtype
28     #-new-compiler %g-vector-structure-subtype))
29 ram 1.1
30    
31     ;;; This version of Defstruct is implemented using Defstruct, and is free of
32     ;;; Maclisp compatability nonsense. For bootstrapping, you're on your own.
33    
34     (defun print-defstruct-description (structure stream depth)
35     (declare (ignore depth))
36     (format stream "#<Defstruct-Description for ~S>" (dd-name structure)))
37    
38     ;;; DSD-Name -- Internal
39     ;;;
40     ;;; Return the the name of a defstruct slot as a symbol. We store it
41     ;;; as a string to avoid creating lots of worthless symbols at load time.
42     ;;;
43     (defun dsd-name (dsd)
44     (intern (string (dsd-%name dsd)) (symbol-package (dsd-accessor dsd))))
45    
46     (defun print-defstruct-slot-description (structure stream depth)
47     (declare (ignore depth))
48     (format stream "#<Defstruct-Slot-Description for ~S>" (dsd-name structure)))
49 ram 1.5
50    
51 ram 1.1
52     ;;; The legendary macro itself.
53    
54     ;;; ### Bootstrap hack...
55     ;;; Install this definition only into the new compiler's environment so that we
56     ;;; don't break the bootstrap environment.
57     ;;;
58     (compiler-let ((lisp::*bootstrap-defmacro* t))
59    
60     (defmacro defstruct (name-and-options &rest slot-descriptions)
61     "Defstruct {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
62     Define the structure type Name. See the manual for details."
63     (let* ((defstruct (parse-name-and-options name-and-options))
64     (name (dd-name defstruct)))
65     (parse-slot-descriptions defstruct slot-descriptions)
66     (if (eq (dd-type defstruct) 'structure)
67     `(progn
68     (%compiler-defstruct ',defstruct)
69     ,@(define-constructor defstruct)
70     ,@(define-boa-constructors defstruct)
71    
72     ;;
73     ;; So the print function is in the right lexical environment, and
74     ;; can be compiled...
75     (let ((new ',defstruct))
76 ram 1.4 ,@(let ((pf (dd-print-function defstruct)))
77     (when pf
78     `((setf (info type printer ',name)
79     ,(if (symbolp pf)
80     `',pf
81     `#',pf)))))
82 ram 1.1 (%defstruct new))
83     ',name)
84     `(progn
85     (eval-when (compile load eval)
86     (setf (info type kind ',name) nil)
87     (setf (info type structure-info ',name) ',defstruct))
88     ,@(define-constructor defstruct)
89     ,@(define-boa-constructors defstruct)
90     ,@(define-predicate defstruct)
91     ,@(define-accessors defstruct)
92     ,@(define-copier defstruct)
93     ',name))))
94    
95     ); Compiler-Let
96    
97    
98     ;;;; Parsing:
99    
100     (defun parse-name-and-options (name-and-options)
101     (if (atom name-and-options)
102     (setq name-and-options (list name-and-options)))
103     (do* ((options (cdr name-and-options) (cdr options))
104     (name (car name-and-options))
105 ram 1.6 (print-function nil)
106 ram 1.5 (pf-supplied-p)
107 ram 1.1 (conc-name (concat-pnames name '-))
108     (constructor (concat-pnames 'make- name))
109     (saw-constructor)
110     (boa-constructors '())
111     (copier (concat-pnames 'copy- name))
112     (predicate (concat-pnames name '-p))
113     (include)
114     (saw-type)
115     (type 'structure)
116     (saw-named)
117     (offset 0))
118     ((null options)
119     (make-defstruct-description
120     :name name
121     :conc-name conc-name
122     :constructor constructor
123     :boa-constructors boa-constructors
124     :copier copier
125     :predicate predicate
126     :include include
127     :print-function print-function
128     :type type
129     :lisp-type (cond ((eq type 'structure) 'simple-vector)
130     ((eq type 'vector) 'simple-vector)
131     ((eq type 'list) 'list)
132     ((and (listp type) (eq (car type) 'vector))
133     (cons 'simple-array (cdr type)))
134     (t (error "~S is a bad :TYPE for Defstruct." type)))
135     :named (if saw-type saw-named t)
136     :offset offset))
137     (if (atom (car options))
138     (case (car options)
139     (:constructor (setq saw-constructor t
140     constructor (concat-pnames 'make- name)))
141     (:copier)
142     (:predicate)
143     (:named (setq saw-named t))
144     (t (error "The Defstruct option ~S cannot be used with 0 arguments."
145     (car options))))
146     (let ((option (caar options))
147     (args (cdar options)))
148     (case option
149     (:conc-name (setq conc-name (car args)))
150     (:constructor (cond ((cdr args)
151     (unless saw-constructor
152     (setq constructor nil))
153     (push args boa-constructors))
154     (t
155     (setq saw-constructor t)
156 ram 1.5 (setq constructor
157     (or (car args)
158     (concat-pnames 'make- name))))))
159 ram 1.1 (:copier (setq copier (car args)))
160     (:predicate (setq predicate (car args)))
161 ram 1.5 (:include
162     (setf include args)
163     (let* ((name (car include))
164     (included-structure
165 ram 1.7 (info type structure-info name))
166 ram 1.5 (included-print-function
167     (if included-structure
168     (dd-print-function included-structure))))
169     (unless included-structure
170     (error "Cannot find description of structure ~S to use for ~
171     inclusion."
172     name))
173     (unless pf-supplied-p
174     (setf print-function included-print-function))))
175     (:print-function
176 ram 1.6 (setf print-function (car args))
177 ram 1.5 (setf pf-supplied-p t))
178     (:type (setf saw-type t type (car args)))
179 ram 1.1 (:named (error "The Defstruct option :NAMED takes no arguments."))
180 ram 1.5 (:initial-offset (setf offset (car args)))
181 ram 1.1 (t (error "~S is an unknown Defstruct option." option)))))))
182 ram 1.5
183    
184 ram 1.1
185 ram 1.5 ;;;; Stuff to parse slot descriptions.
186    
187     ;;; PARSE-SLOT-DESCRIPTIONS parses the slot descriptions (surprise) and does
188 ram 1.1 ;;; any structure inclusion that needs to be done.
189 ram 1.5 ;;;
190 ram 1.1 (defun parse-slot-descriptions (defstruct slots)
191     ;; First strip off any doc string and stash it in the Defstruct.
192     (when (stringp (car slots))
193     (setf (dd-doc defstruct) (car slots))
194     (setq slots (cdr slots)))
195     ;; Then include stuff. We add unparsed items to the start of the Slots.
196     (when (dd-include defstruct)
197     (let* ((included-name (car (dd-include defstruct)))
198     (included-thing (info type structure-info included-name))
199     (modified-slots (cdr (dd-include defstruct))))
200     (unless included-thing
201     (error "Cannot find description of structure ~S to use for inclusion."
202     included-name))
203     (setf (dd-includes defstruct)
204     (cons (dd-name included-thing) (dd-includes included-thing)))
205     (setf (dd-offset defstruct) (dd-offset included-thing))
206     (do* ((islots (mapcar #'(lambda (slot)
207     `(,(dsd-name slot) ,(dsd-default slot)
208     :type ,(dsd-type slot)
209     :read-only ,(dsd-read-only slot)))
210     (dd-slots included-thing)))
211     (islots* islots (cdr islots*)))
212     ((null islots*)
213     (setq slots (nconc islots slots)))
214     (let* ((islot (car islots*))
215     (modifiee (find (car islot) modified-slots
216     :key #'(lambda (x) (if (atom x) x (car x)))
217     :test #'string=)))
218     (when modifiee
219     (cond ((symbolp modifiee)
220     ;; If it's just a symbol, nilify the default.
221     (setf (cadr islot) nil))
222     ((listp modifiee)
223     ;; If it's a list, parse new defaults and options.
224     (setf (cadr islot) (cadr modifiee))
225     (when (cddr modifiee)
226     (do ((options (cddr modifiee) (cddr options)))
227     ((null options))
228     (case (car options)
229     (:type
230     (setf (cadddr islot) (cadr options)))
231     (:read-only
232     (setf (cadr (cddddr islot)) (cadr options)))
233     (t
234     (error "Bad option in included slot spec: ~S."
235     (car options)))))))))))))
236     ;; Finally parse the slots into Slot-Description objects.
237     (do ((slots slots (cdr slots))
238 ram 1.5 (index (+ (dd-offset defstruct) (if (dd-named defstruct) 1 0))
239     (1+ index))
240     (descriptions ()))
241 ram 1.1 ((null slots)
242     (setf (dd-length defstruct) index)
243     (setf (dd-slots defstruct) (nreverse descriptions)))
244 ram 1.5 (let* ((slot (car slots))
245     (name (if (atom slot) slot (car slot))))
246     (when (keywordp name)
247     (warn "Keyword slot name indicates possible syntax error in DEFSTRUCT ~
248     -- ~S."
249     name))
250 ram 1.1 (push
251     (if (atom slot)
252 ram 1.5 (make-defstruct-slot-description
253     :%name (string name)
254     :index index
255     :accessor (concat-pnames (dd-conc-name defstruct) name)
256     :type t)
257 ram 1.1 (do ((options (cddr slot) (cddr options))
258     (default (cadr slot))
259     (type t)
260     (read-only nil))
261     ((null options)
262     (make-defstruct-slot-description
263     :%name (string name)
264     :index index
265     :accessor (concat-pnames (dd-conc-name defstruct) name)
266     :default default
267     :type type
268     :read-only read-only))
269     (case (car options)
270     (:type (setq type (cadr options)))
271     (:read-only (setq read-only (cadr options))))))
272     descriptions))))
273    
274    
275    
276     ;;;; Default structure access and copiers:
277     ;;;
278     ;;; In the normal case of structures that have a real type (i.e. no :Type
279     ;;; option was specified), we want to optimize things for space as well as
280     ;;; speed, since there can be thousands of defined slot accesors.
281     ;;;
282     ;;; What we do is defined the accessors and copier as closures over
283     ;;; general-case code. Since the compiler will normally open-code accesors,
284     ;;; the (minor) efficiency penalty is not a concern.
285    
286     ;;; Typep-To-Structure -- Internal
287     ;;;
288     ;;; Return true if Obj is an object of the structure type specified by Info.
289     ;;; This is called by the accessor closures, which have a handle on the type's
290     ;;; Defstruct-Description.
291     ;;;
292 wlott 1.7.2.1 #+new-compiler
293 ram 1.1 (proclaim '(inline typep-to-structure))
294 wlott 1.7.2.1 #+new-compiler
295 ram 1.1 (defun typep-to-structure (obj info)
296     (declare (type defstruct-description info) (inline member))
297     (and (structurep obj)
298 wlott 1.7.2.1 (let ((name (%primitive structure-ref obj 0)))
299 ram 1.1 (or (eq name (dd-name info))
300     (member name (dd-included-by info) :test #'eq)))))
301    
302     #+new-compiler
303     ;;; %Defstruct -- Internal
304     ;;;
305     ;;; Do miscellaneous load-time actions for the structure described by Info.
306     ;;; Define setters, accessors, copier, predicate, documentation, instantiate
307     ;;; definition in load-time env. This is only called for default structures.
308     ;;;
309     (defun %defstruct (info)
310     (declare (type defstruct-description info))
311 ram 1.3 (setf (info type defined-structure-info (dd-name info)) info)
312    
313 ram 1.1 (dolist (slot (dd-slots info))
314     (let ((dsd slot))
315     (setf (symbol-function (dsd-accessor slot))
316     #'(lambda (structure)
317     (declare (optimize (speed 3) (safety 0)))
318     (unless (typep-to-structure structure info)
319     (error "Structure for accessor ~S is not a ~S:~% ~S"
320     (dsd-accessor dsd) (dd-name info) structure))
321 wlott 1.7.2.1 (%primitive structure-index-ref structure (dsd-index dsd))))
322 ram 1.1
323     (unless (dsd-read-only slot)
324     (setf (fdefinition `(setf ,(dsd-accessor slot)))
325     #'(lambda (structure new-value)
326     (declare (optimize (speed 3) (safety 0)))
327     (unless (typep-to-structure structure info)
328     (error "Structure for setter ~S is not a ~S:~% ~S"
329     `(setf ,(dsd-accessor dsd)) (dd-name info)
330     structure))
331     (unless (typep new-value (dsd-type dsd))
332     (error "New-Value for setter ~S is not a ~S:~% ~S."
333     `(setf ,(dsd-accessor dsd)) (dsd-type dsd)
334     new-value))
335 wlott 1.7.2.1 (%primitive structure-index-set structure (dsd-index dsd)
336 ram 1.1 new-value))))))
337    
338     (when (dd-predicate info)
339     (setf (symbol-function (dd-predicate info))
340     #'(lambda (object)
341     (declare (optimize (speed 3) (safety 0)))
342     (if (typep-to-structure object info) t nil))))
343    
344     (when (dd-copier info)
345     (setf (symbol-function (dd-copier info))
346     #'(lambda (structure)
347     (declare (optimize (speed 3) (safety 0)))
348     (unless (typep-to-structure structure info)
349     (error "Structure for copier ~S is not a ~S:~% ~S"
350     (dd-copier info) (dd-name info) structure))
351    
352     (let ((len (dd-length info)))
353     (declare (fixnum len))
354     (do ((i 1 (1+ i))
355     (res (%primitive alloc-g-vector len nil)))
356     ((= i len)
357 wlott 1.7.2.2 (%primitive structure-set res (dd-name info) 0)
358 ram 1.1 (structurify res))
359     (declare (fixnum i))
360 wlott 1.7.2.1 (%primitive structure-index-set res i
361     (%primitive structure-index-ref structure i)))))))
362 ram 1.1 (when (dd-doc info)
363     (setf (documentation (dd-name info) 'type) (dd-doc info))))
364    
365    
366     ;;; Define-Accessors returns a list of function definitions for accessing and
367     ;;; setting the slots of the a typed Defstruct. The functions are proclaimed
368     ;;; to be inline, and the types of their arguments and results are declared as
369     ;;; well. We count on the compiler to do clever things with Elt.
370    
371     (defun define-accessors (defstruct)
372     (do ((slots (dd-slots defstruct) (cdr slots))
373     (stuff '())
374     (type (dd-lisp-type defstruct)))
375     ((null slots) stuff)
376     (let* ((slot (car slots))
377     (name (dsd-accessor slot))
378     (index (dsd-index slot))
379     (slot-type (dsd-type slot)))
380     (push
381     `(progn
382     (proclaim '(inline ,name (setf ,name)))
383     (defun ,name (structure)
384     (declare (type ,type structure))
385     (the ,slot-type (elt structure ,index)))
386     ,@(unless (dsd-read-only slot)
387     `((defun (setf ,name) (structure new-value)
388     (declare (type ,type structure) (type ,slot-type new-value))
389     (setf (elt structure ,index) new-value)))))
390     stuff))))
391    
392    
393     ;;; Define-Constructor returns a definition for the constructor function of the
394     ;;; given Defstruct. If the structure is implemented as a vector and is named,
395     ;;; we structurify it. If the structure is a vector of some specialized type,
396     ;;; we can't use the Vector function.
397     ;;;
398     ;;; If we are defining safe accessors, we also check the types of the values to
399     ;;; make sure that they are legal.
400     ;;;
401     (defun define-constructor (defstruct)
402     (let ((name (dd-constructor defstruct)))
403     (when name
404     (let* ((initial-cruft
405     (if (dd-named defstruct)
406     (make-list (1+ (dd-offset defstruct))
407     :initial-element `',(dd-name defstruct))
408     (make-list (dd-offset defstruct))))
409     (slots (dd-slots defstruct))
410     (names (mapcar #'dsd-name slots))
411     (args (mapcar #'(lambda (slot)
412     `(,(dsd-name slot) ,(dsd-default slot)))
413     slots)))
414     `((defun ,name ,(if args `(&key ,@args))
415     (declare
416     ,@(mapcar #'(lambda (slot)
417     `(type ,(dsd-type slot) ,(dsd-name slot)))
418     slots))
419     ,(case (dd-type defstruct)
420     (list
421     `(list ,@initial-cruft ,@names))
422     (structure
423     `(truly-the ,(dd-name defstruct)
424     (structurify
425     (vector ,@initial-cruft ,@names))))
426     (vector
427     `(vector ,@initial-cruft ,@names))
428     (t
429     (do ((sluts slots (cdr sluts))
430     (sets '())
431     (temp (gensym)))
432     ((null sluts)
433     `(let ((,temp (make-array
434     ,(dd-length defstruct)
435     :element-type
436     ',(cadr (dd-lisp-type defstruct)))))
437     ,@(when (dd-named defstruct)
438     `(setf (aref ,temp ,(dd-offset defstruct))
439     ',(dd-name defstruct)))
440     ,@sets
441     ,temp))
442     (let ((slot (car sluts)))
443     (push `(setf (aref ,temp ,(dsd-index slot))
444     ,(dsd-name slot))
445     sets)))))))))))
446 ram 1.5
447    
448 ram 1.1
449 ram 1.5 ;;;; Support for By-Order-Argument Constructors.
450    
451     ;;; FIND-LEGAL-SLOT -- Internal
452 ram 1.1 ;;;
453     ;;; Given a defstruct description and a slot name, return the corresponding
454     ;;; slot if it exists, or signal an error if not.
455     ;;;
456     (defun find-legal-slot (defstruct name)
457     (or (find name (dd-slots defstruct) :key #'dsd-name :test #'string=)
458     (error "~S is not a defined slot name in the ~S structure."
459     name (dd-name defstruct))))
460    
461 ram 1.5
462     ;;; Define-Boa-Constructors defines positional constructor functions. We
463     ;;; generate code to set each variable not specified in the arglist to the
464     ;;; default given in the Defstruct. We just slap required args in, as with
465     ;;; rest args and aux args. Optionals are treated a little differently. Those
466     ;;; that aren't supplied with a default in the arg list are mashed so that
467     ;;; their default in the arglist is the corresponding default from the
468     ;;; Defstruct.
469 ram 1.1 ;;;
470     (defun define-boa-constructors (defstruct)
471     (do* ((boas (dd-boa-constructors defstruct) (cdr boas))
472     (name (car (car boas)) (car (car boas)))
473     (args (copy-list (cadr (car boas))) (copy-list (cadr (car boas))))
474     (slots (dd-slots defstruct) (dd-slots defstruct))
475     (slots-in-arglist '() '())
476     (defuns '()))
477     ((null boas) defuns)
478     ;; Find the slots in the arglist and hack the defaultless optionals.
479     (do ((args args (cdr args))
480     (arg-kind 'required))
481     ((null args))
482     (let ((arg (car args)))
483 ram 1.5 (cond ((not (atom arg))
484     (push (find-legal-slot defstruct (car arg)) slots-in-arglist))
485 wlott 1.7.2.2 ((member arg '(&optional &rest &aux &key) :test #'eq)
486 ram 1.5 (setq arg-kind arg))
487     (t
488     (case arg-kind
489     ((required &rest &aux)
490     (push (find-legal-slot defstruct arg) slots-in-arglist))
491     ((&optional &key)
492     (let ((dsd (find-legal-slot defstruct arg)))
493     (push dsd slots-in-arglist)
494     (rplaca args (list arg (dsd-default dsd))))))))))
495 ram 1.1
496 ram 1.5 ;; Then make a list that can be used with a (list ...) or (vector...).
497 ram 1.1 (let ((initial-cruft
498     (if (dd-named defstruct)
499     (make-list (1+ (dd-offset defstruct))
500     :initial-element `',(dd-name defstruct))
501     (make-list (dd-offset defstruct))))
502     (thing (mapcar #'(lambda (slot)
503 wlott 1.7.2.2 (if (member slot slots-in-arglist
504     :test #'eq)
505 ram 1.1 (dsd-name slot)
506     (dsd-default slot)))
507     slots)))
508     (push
509     `(defun ,name ,args
510     (declare
511     ,@(mapcar #'(lambda (slot)
512     `(type ,(dsd-type slot) ,(dsd-name slot)))
513     slots-in-arglist))
514     ,(case (dd-type defstruct)
515     (list
516     `(list ,@initial-cruft ,@thing))
517     (structure
518     `(truly-the ,(dd-name defstruct)
519     (structurify (vector ,@initial-cruft ,@thing))))
520     (vector
521     `(vector ,@initial-cruft ,@thing))
522     (t
523     (do ((things thing (cdr things))
524     (index 0 (1+ index))
525     (sets '())
526     (temp (gensym)))
527     ((null things)
528     `(let ((,temp (make-array
529     ,(dd-length defstruct)
530     :element-type
531     ',(cadr (dd-lisp-type defstruct)))))
532     ,@(when (dd-named defstruct)
533     `(setf (aref ,temp ,(dd-offset defstruct))
534     ',(dd-name defstruct)))
535     ,@sets
536     ,temp))
537     (push `(setf (aref ,temp index) ,(car things))
538     sets)))))
539     defuns))))
540    
541     ;;; Define-Copier returns the definition for a copier function of a typed
542     ;;; Defstruct if one is desired.
543    
544     (defun define-copier (defstruct)
545     (when (dd-copier defstruct)
546     `((defun ,(dd-copier defstruct) (structure)
547     (declare (type ,(dd-lisp-type defstruct) structure))
548     (subseq structure 0 ,(dd-length defstruct))))))
549    
550    
551     ;;; Define-Predicate returns a definition for a predicate function if one is
552     ;;; desired. This is only called for typed structures, since the default
553     ;;; structure predicate is implemented as a closure.
554    
555 ram 1.7 (defun define-predicate (defstruct)
556 ram 1.1 (let ((name (dd-name defstruct))
557     (pred (dd-predicate defstruct)))
558     (when (and pred (dd-named defstruct))
559     (let ((ltype (dd-lisp-type defstruct)))
560     `((defun ,pred (object)
561     (and (typep object ',ltype)
562     (eq (elt (the ,ltype object) ,(dd-offset defstruct))
563     ',name))))))))
564    
565    
566     ;;; Structure-Predicate -- Internal
567     ;;;
568     ;;; The typep transform in typetran calls this function when it encounters
569     ;;; an unknown symbol type specifier. If the referred-to type is in fact a
570     ;;; structure type that has a predicate, then we open-code the normal case of
571     ;;; an exact match, and otherwise call the predicate.
572     ;;;
573     (defun structure-predicate (object type)
574     (let ((def (info type structure-info type)))
575     (if (and def (eq (dd-type def) 'structure) (dd-predicate def))
576     `(and (structurep ,object)
577 wlott 1.7.2.1 (or (eq (%primitive structure-ref ,object 0) ',type)
578 ram 1.1 (,(dd-predicate def) ,object)))
579     `(lisp::structure-typep ,object ',type))))
580    
581    
582     ;;; Random sorts of stuff.
583    
584     (defun default-structure-print (structure stream depth)
585     (declare (ignore depth))
586     (write-string "#S(" stream)
587     (prin1 (svref structure 0) stream)
588     (do ((index 1 (1+ index))
589     (length (length structure))
590 ram 1.3 (slots (dd-slots (info type defined-structure-info (svref structure 0)))
591 ram 1.1 (cdr slots)))
592     ((or (= index length)
593     (and *print-length*
594     (= index *print-length*)))
595     (if (= index length)
596     (write-string ")" stream)
597     (write-string "...)" stream)))
598     (write-char #\space stream)
599     (prin1 (dsd-name (car slots)) stream)
600     (write-char #\space stream)
601     (prin1 (svref structure index) stream)))

  ViewVC Help
Powered by ViewVC 1.1.5