source: branches/qres/ccl/lib/defstruct.lisp @ 14057

Last change on this file since 14057 was 14057, checked in by gz, 9 years ago

Couple defstruct fixes from trunk (r13590, r13788)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;;; Defstruct.lisp
21
22(eval-when (eval compile)
23  (require 'defstruct-macros)
24
25)
26
27(defvar %structure-refs% (make-hash-table :test #'eq))
28(defvar %defstructs% (make-hash-table :test #'eq))
29
30(defun make-ssd (name initform offset r/o &optional (type t))
31  (let ((refinfo (%ilogior2 offset (if r/o #x1000000 0))))
32    (list* name initform
33           (if (eq type 't)
34             refinfo
35             (cons type refinfo)))))
36
37(declaim (inline type-and-refinfo-p))
38(defun type-and-refinfo-p (object)
39  (or (fixnump object) (consp object)))
40
41(defun ssd-set-reftype (ssd reftype)
42  (ssd-update-refinfo (ssd refinfo)
43                      (%ilogior2 (%ilogand2 #x300FFFF refinfo)
44                                 (%ilsl 16 reftype))))
45
46(defun ssd-set-r/o (ssd) 
47  (ssd-update-refinfo (ssd refinfo)
48                      (%ilogior2 #x1000000 refinfo)))
49
50(defun ssd-set-inherited (ssd)
51  (ssd-update-refinfo (ssd refinfo)
52                       (bitset $struct-inherited refinfo)))
53
54(defun copy-ssd (ssd)
55  (let* ((cdr (cdr ssd))
56         (cddr (cdr cdr)))
57    (list* (%car ssd) (%car cdr)
58           (if (consp cddr)
59             (list* (%car cddr) (%cdr cddr))
60             cddr))))
61
62(declaim (inline ssd-type-and-refinfo))
63(defun ssd-type-and-refinfo (ssd)
64  (cddr ssd))
65
66(defun ssd-type (ssd)
67  (let ((type-and-refinfo (ssd-type-and-refinfo ssd)))
68    (if (consp type-and-refinfo)
69      (%car type-and-refinfo)
70      't)))
71
72(defun ssd-refinfo (ssd)
73  (let ((type-and-refinfo (ssd-type-and-refinfo ssd)))
74    (if (consp type-and-refinfo) (%cdr type-and-refinfo) type-and-refinfo)))
75
76(defun %structure-class-of (thing)
77  (let* ((cell (car (uvref thing 0))))
78    (or (class-cell-class cell)
79        (setf (class-cell-class cell)
80              (find-class (class-cell-name cell))))))
81
82;These might want to compiler-transform into non-typechecking versions...
83(defun struct-ref (struct offset)
84  (if (structurep struct) (uvref struct offset)
85      (report-bad-arg struct 'structure-object)))
86
87(defun struct-set (struct offset value)
88  (if (structurep struct) (uvset struct offset value)
89      (report-bad-arg struct 'structure-object)))
90
91(defsetf struct-ref struct-set)
92
93
94; things for defstruct to do - at load time
95(defun %defstruct-do-load-time (sd predicate &optional doc &aux (name (sd-name sd)))
96  ;(declare (ignore refnames))
97  (when (null (sd-type sd))
98    (%define-structure-class sd))
99  (when (and doc *save-doc-strings*)
100    (set-documentation name 'type doc)) 
101  (puthash name %defstructs% sd)
102  (record-source-file name 'structure)
103  (when (and predicate (null (sd-type sd)))
104    (puthash predicate %structure-refs% name)) 
105  (when *fasload-print* (format t "~&~S~%" name))
106  name)
107
108(defun %defstruct-set-print-function (sd print-function print-object-p)
109  (sd-set-print-function sd (if print-object-p
110                              (list print-function)
111                              print-function)))
112
113(defun sd-refname-in-included-struct-p (sd name &optional env)
114  (dolist (included-type (cdr (sd-superclasses sd)))
115    (let ((sub-sd (or (let ((defenv (definition-environment env)))
116                        (when defenv (%cdr (assq included-type
117                                                 (defenv.structures
118                                                     defenv)))))
119                      (gethash included-type %defstructs%))))
120      (when sub-sd
121        (if (member name (sd-refnames sub-sd) :test 'eq)
122          (return t))))))
123
124(defun sd-refname-pos-in-included-struct (sd name)
125  (dolist (included-type (cdr (sd-superclasses sd)))
126    (let ((sub-sd (gethash included-type %defstructs%)))
127      (when sub-sd
128        (let ((refnames (sd-refnames sub-sd)))
129          (if refnames
130            (let ((pos (position name refnames :test 'eq)))
131              (and pos (1+ pos)))
132            (dolist (slot (sd-slots sub-sd))
133              (let ((ssd-name (ssd-name slot)))
134                (unless (fixnump ssd-name)
135                  (when (eq name ssd-name)
136                    (return-from sd-refname-pos-in-included-struct
137                      (ssd-offset slot))))))))))))
138
139;;; return stuff for defstruct to compile
140(defun %defstruct-compile (sd refnames env)
141  (let ((stuff))   
142    (dolist (slot (sd-slots sd))
143      (unless (fixnump (ssd-name slot))
144        (let* ((accessor (if refnames (pop refnames) (ssd-name slot)))
145               (pos (sd-refname-pos-in-included-struct sd accessor)))
146          (if pos
147            (let ((offset (ssd-offset slot)))
148              (unless (eql pos offset)
149                ;; This should be a style-warning
150                (warn "Accessor ~s at different position than in included structure"
151                      accessor)))
152            (unless (sd-refname-in-included-struct-p sd accessor env)
153              (let ((fn (slot-accessor-fn slot accessor env)))
154                (push
155                 `(progn
156                    ,.fn
157                    (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
158                    (record-source-file ',accessor 'structure-accessor))
159                 stuff)))))))
160    (nreverse stuff)))
161
162
163; no #. for cross compile
164(defvar *struct-ref-vector* 
165  (vector #'(lambda (x) (struct-ref x 0))
166          #'(lambda (x) (struct-ref x 1))
167          #'(lambda (x) (struct-ref x 2))
168          #'(lambda (x) (struct-ref x 3))
169          #'(lambda (x) (struct-ref x 4))
170          #'(lambda (x) (struct-ref x 5))
171          #'(lambda (x) (struct-ref x 6))
172          #'(lambda (x) (struct-ref x 7))
173          #'(lambda (x) (struct-ref x 8))
174          #'(lambda (x) (struct-ref x 9))))
175
176(defvar *svref-vector*
177  (vector #'(lambda (x) (svref x 0))
178          #'(lambda (x) (svref x 1))
179          #'(lambda (x) (svref x 2))
180          #'(lambda (x) (svref x 3))
181          #'(lambda (x) (svref x 4))
182          #'(lambda (x) (svref x 5))
183          #'(lambda (x) (svref x 6))
184          #'(lambda (x) (svref x 7))
185          #'(lambda (x) (svref x 8))
186          #'(lambda (x) (svref x 9))))
187
188
189;;; too bad there isnt a way to suppress generating these darn
190;;; functions when you dont want them.  Makes no sense to fetch
191;;; functions from a vector of 68K functions and send them over to
192;;; PPC.  So can use that space optimization iff host and target are
193;;; the same.
194
195
196(defparameter *defstruct-share-accessor-functions* t)   ;; TODO: isn't it time to get rid of this?
197
198(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot)))
199  (cond ((eq ref $defstruct-nth)
200         (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
201           `((eval-when (:compile-toplevel)
202               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
203              (fset ',name
204                    ,(symbol-function
205                      (%svref '#(first second third fourth fifth
206                                 sixth seventh eighth ninth tenth) offset))))
207           `((defun ,name (x)  (nth ,offset x)))))
208        ((eq ref $defstruct-struct)
209         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
210           `((eval-when (:compile-toplevel)
211               (record-function-info ',name ',*one-arg-defun-def-info* ,env))               
212             (fset ',name , (%svref *struct-ref-vector* offset)))
213           `((defun ,name (x)  (struct-ref x ,offset)))))
214        ((or (eq ref target::subtag-simple-vector)
215             (eq ref $defstruct-simple-vector))
216         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
217           `((eval-when (:compile-toplevel)
218               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
219             (fset ',name ,(%svref *svref-vector* offset)))
220           `((defun ,name (x)  (svref x ,offset)))))
221        (t `((defun ,name (x) (uvref x ,offset))))))
222
223(defun defstruct-reftype (type)
224  (cond ((null type) $defstruct-struct)
225        ((eq type 'list) $defstruct-nth)
226        (t (element-type-subtype (cadr type)))))
227
228(defun defstruct-slot-defs (sd refnames env)
229  (declare (ignore env))
230  (let ((ref (defstruct-reftype (sd-type sd))) name defs)
231    (dolist (slot (sd-slots sd))
232      (ssd-set-reftype slot ref)
233      (unless (fixnump (setq name (ssd-name slot))) ;Ignore fake 'name' slots
234        (when refnames (setq name (pop refnames)))
235        (unless (sd-refname-pos-in-included-struct sd name)
236          (push name defs))))
237    (setq defs (nreverse defs))
238    `((declaim (inline ,@defs)))))
239
240;;;Used by nx-transform, setf, and whatever...
241(defun defstruct-ref-transform (predicate-or-type-and-refinfo args &optional env)
242  (if (type-and-refinfo-p predicate-or-type-and-refinfo)
243    (multiple-value-bind (type refinfo)
244                         (if (consp predicate-or-type-and-refinfo)
245                           (values (%car predicate-or-type-and-refinfo)
246                                   (%cdr predicate-or-type-and-refinfo))
247                           (values 't predicate-or-type-and-refinfo))
248      (let* ((offset (refinfo-offset refinfo))
249             (ref (refinfo-reftype refinfo))
250             (accessor
251              (cond ((eq ref $defstruct-nth)
252                     `(nth ,offset ,@args))
253                    ((eq ref $defstruct-struct)
254                     `(struct-ref ,@args ,offset))
255                    ((eq ref target::subtag-simple-vector)
256                     `(svref ,@args ,offset))
257                    (ref
258                     `(aref (the (simple-array ,(element-subtype-type ref) (*))
259                                 ,@args) ,offset))
260                    (t `(uvref ,@args ,offset)))))
261        (if (eq type 't)
262          accessor
263          (if (specifier-type-if-known type env)
264            `(the ,type ,accessor)
265            (if (nx-declarations-typecheck env)
266              `(require-type ,accessor ',type)
267              ;; Otherwise just ignore the type, it's most likely a forward reference,
268              ;; and while it means we might be missing out on a possible optimization,
269              ;; most of the time it's not worth warning about.
270              accessor)))))
271    `(structure-typep ,@args ',predicate-or-type-and-refinfo)))
272
273;;; Should probably remove the constructor, copier, and predicate as
274;;; well. Can't remove the inline proclamations for the refnames,
275;;; as the user may have explicitly said this. Questionable - but surely
276;;; must delete the inline definitions.
277;;; Doesn't remove the copier because we don't know for sure what it's name is
278(defmethod change-class ((from structure-class)
279                         (to class)
280                          &rest initargs &key &allow-other-keys)
281  (declare (dynamic-extent initargs))
282  (let ((class-name (class-name from)))
283    (unless (eq from to)                  ; shouldn't be
284      (remove-structure-defs class-name)
285      (remhash class-name %defstructs%)))
286  (%change-class from to initargs))
287
288;;; if redefining a structure as another structure or redefining a
289;;; structure as a class
290(defun remove-structure-defs (class-name)
291  (let ((sd (gethash class-name %defstructs%)))
292    (when sd
293      (dolist (refname (sd-refnames sd))
294        (remhash refname %structure-refs%)
295        (let ((def (assq refname *nx-globally-inline*)))
296          (when def (set-function-info refname nil)))
297        (when (symbolp refname)(fmakunbound refname)))
298      #|
299      ;; The print-function may indeed have become obsolete,
300      ;; but we can't generally remove user-defined code
301      (let ((print-fn (sd-print-function sd)))
302        (when (symbolp print-fn) (fmakunbound print-fn)))
303      |#
304      (let ((constructor (sd-constructor sd)))
305        (when (symbolp constructor) (fmakunbound constructor)))
306      (let ((delete-match #'(lambda (pred struct-name)
307                              (when (eq struct-name class-name)
308                                (remhash pred %structure-refs%)
309                                (fmakunbound pred)))))
310        (declare (dynamic-extent delete-match))
311        ; get rid of the predicate
312        (maphash delete-match %structure-refs%)))))
313
314(defun copy-structure (source)
315  "Return a copy of STRUCTURE with the same (EQL) slot values."
316  (copy-uvector (require-type source 'structure-object)))
317
318(provide 'defstruct)
319
320; End of defstruct.lisp
Note: See TracBrowser for help on using the repository browser.