source: branches/working-0711/ccl/lib/defstruct.lisp @ 13363

Last change on this file since 13363 was 13363, checked in by gz, 10 years ago

defstruct fixes from trunk (r13344/r13358)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.9 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
114(defun sd-refname-pos-in-included-struct (sd name)
115  (dolist (included-type (cdr (sd-superclasses sd)))
116    (let ((sub-sd (gethash included-type %defstructs%)))
117      (when sub-sd
118        (let ((refnames (sd-refnames sub-sd)))
119          (if refnames
120            (let ((pos (position name refnames :test 'eq)))
121              (and pos (1+ pos)))
122            (dolist (slot (sd-slots sub-sd))
123              (let ((ssd-name (ssd-name slot)))
124                (unless (fixnump ssd-name)
125                  (when (eq name ssd-name)
126                    (return-from sd-refname-pos-in-included-struct
127                      (ssd-offset slot))))))))))))
128
129;;; return stuff for defstruct to compile
130(defun %defstruct-compile (sd refnames env)
131  (let ((stuff))   
132    (dolist (slot (sd-slots sd))
133      (unless (fixnump (ssd-name slot))
134        (let* ((accessor (if refnames (pop refnames) (ssd-name slot)))
135               (pos (sd-refname-pos-in-included-struct sd accessor)))
136          (if pos
137            (let ((offset (ssd-offset slot)))
138              (unless (eql pos offset)
139                ; This should be a style-warning
140                (warn "Accessor ~s at different position than in included structure"
141                      accessor)))
142            (let ((fn (slot-accessor-fn slot accessor env)))
143              (push
144               `(progn
145                  ,.fn
146                  (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
147                  (record-source-file ',accessor 'structure-accessor))
148               stuff))))))
149    (nreverse stuff)))
150
151
152; no #. for cross compile
153(defvar *struct-ref-vector* 
154  (vector #'(lambda (x) (struct-ref x 0))
155          #'(lambda (x) (struct-ref x 1))
156          #'(lambda (x) (struct-ref x 2))
157          #'(lambda (x) (struct-ref x 3))
158          #'(lambda (x) (struct-ref x 4))
159          #'(lambda (x) (struct-ref x 5))
160          #'(lambda (x) (struct-ref x 6))
161          #'(lambda (x) (struct-ref x 7))
162          #'(lambda (x) (struct-ref x 8))
163          #'(lambda (x) (struct-ref x 9))))
164
165(defvar *svref-vector*
166  (vector #'(lambda (x) (svref x 0))
167          #'(lambda (x) (svref x 1))
168          #'(lambda (x) (svref x 2))
169          #'(lambda (x) (svref x 3))
170          #'(lambda (x) (svref x 4))
171          #'(lambda (x) (svref x 5))
172          #'(lambda (x) (svref x 6))
173          #'(lambda (x) (svref x 7))
174          #'(lambda (x) (svref x 8))
175          #'(lambda (x) (svref x 9))))
176
177
178;;; too bad there isnt a way to suppress generating these darn
179;;; functions when you dont want them.  Makes no sense to fetch
180;;; functions from a vector of 68K functions and send them over to
181;;; PPC.  So can use that space optimization iff host and target are
182;;; the same.
183
184
185(defparameter *defstruct-share-accessor-functions* t)   ;; TODO: isn't it time to get rid of this?
186
187(defun slot-accessor-fn (slot name env &aux (ref (ssd-reftype slot)) (offset (ssd-offset slot)))
188  (cond ((eq ref $defstruct-nth)
189         (if (and  (%i< offset 10) *defstruct-share-accessor-functions*)
190           `((eval-when (:compile-toplevel)
191               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
192              (fset ',name
193                    ,(symbol-function
194                      (%svref '#(first second third fourth fifth
195                                 sixth seventh eighth ninth tenth) offset))))
196           `((defun ,name (x)  (nth ,offset x)))))
197        ((eq ref $defstruct-struct)
198         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
199           `((eval-when (:compile-toplevel)
200               (record-function-info ',name ',*one-arg-defun-def-info* ,env))               
201             (fset ',name , (%svref *struct-ref-vector* offset)))
202           `((defun ,name (x)  (struct-ref x ,offset)))))
203        ((or (eq ref target::subtag-simple-vector)
204             (eq ref $defstruct-simple-vector))
205         (if (and (%i< offset 10) *defstruct-share-accessor-functions*)
206           `((eval-when (:compile-toplevel)
207               (record-function-info ',name ',*one-arg-defun-def-info* ,env))
208             (fset ',name ,(%svref *svref-vector* offset)))
209           `((defun ,name (x)  (svref x ,offset)))))
210        (t `((defun ,name (x) (uvref x ,offset))))))
211
212(defun defstruct-reftype (type)
213  (cond ((null type) $defstruct-struct)
214        ((eq type 'list) $defstruct-nth)
215        (t (element-type-subtype (cadr type)))))
216
217(defun defstruct-slot-defs (sd refnames env)
218  (declare (ignore env))
219  (let ((ref (defstruct-reftype (sd-type sd))) name defs)
220    (dolist (slot (sd-slots sd))
221      (ssd-set-reftype slot ref)
222      (unless (fixnump (setq name (ssd-name slot))) ;Ignore fake 'name' slots
223        (when refnames (setq name (pop refnames)))
224        (unless (sd-refname-pos-in-included-struct sd name)
225          (push name defs))))
226    (setq defs (nreverse defs))
227    `((declaim (inline ,@defs)))))
228
229;;;Used by nx-transform, setf, and whatever...
230(defun defstruct-ref-transform (predicate-or-type-and-refinfo args &optional env)
231  (if (type-and-refinfo-p predicate-or-type-and-refinfo)
232    (multiple-value-bind (type refinfo)
233                         (if (consp predicate-or-type-and-refinfo)
234                           (values (%car predicate-or-type-and-refinfo)
235                                   (%cdr predicate-or-type-and-refinfo))
236                           (values 't predicate-or-type-and-refinfo))
237      (let* ((offset (refinfo-offset refinfo))
238             (ref (refinfo-reftype refinfo))
239             (accessor
240              (cond ((eq ref $defstruct-nth)
241                     `(nth ,offset ,@args))
242                    ((eq ref $defstruct-struct)
243                     `(struct-ref ,@args ,offset))
244                    ((eq ref target::subtag-simple-vector)
245                     `(svref ,@args ,offset))
246                    (ref
247                     `(aref (the (simple-array ,(element-subtype-type ref) (*))
248                                 ,@args) ,offset))
249                    (t `(uvref ,@args ,offset)))))
250        (if (eq type 't)
251          accessor
252          (if (specifier-type-if-known type env)
253            `(the ,type ,accessor)
254            (if (nx-declarations-typecheck env)
255              `(require-type ,accessor ',type)
256              ;; Otherwise just ignore the type, it's most likely a forward reference,
257              ;; and while it means we might be missing out on a possible optimization,
258              ;; most of the time it's not worth warning about.
259              accessor)))))
260    `(structure-typep ,@args ',predicate-or-type-and-refinfo)))
261
262;;; Should probably remove the constructor, copier, and predicate as
263;;; well. Can't remove the inline proclamations for the refnames,
264;;; as the user may have explicitly said this. Questionable - but surely
265;;; must delete the inline definitions.
266;;; Doesn't remove the copier because we don't know for sure what it's name is
267(defmethod change-class ((from structure-class)
268                         (to class)
269                          &rest initargs &key &allow-other-keys)
270  (declare (dynamic-extent initargs))
271  (let ((class-name (class-name from)))
272    (unless (eq from to)                  ; shouldn't be
273      (remove-structure-defs class-name)
274      (remhash class-name %defstructs%)))
275  (%change-class from to initargs))
276
277;;; if redefining a structure as another structure or redefining a
278;;; structure as a class
279(defun remove-structure-defs (class-name)
280  (let ((sd (gethash class-name %defstructs%)))
281    (when sd
282      (dolist (refname (sd-refnames sd))
283        (remhash refname %structure-refs%)
284        (let ((def (assq refname *nx-globally-inline*)))
285          (when def (set-function-info refname nil)))
286        (when (symbolp refname)(fmakunbound refname)))
287      #|
288      ;; The print-function may indeed have become obsolete,
289      ;; but we can't generally remove user-defined code
290      (let ((print-fn (sd-print-function sd)))
291        (when (symbolp print-fn) (fmakunbound print-fn)))
292      |#
293      (let ((constructor (sd-constructor sd)))
294        (when (symbolp constructor) (fmakunbound constructor)))
295      (let ((delete-match #'(lambda (pred struct-name)
296                              (when (eq struct-name class-name)
297                                (remhash pred %structure-refs%)
298                                (fmakunbound pred)))))
299        (declare (dynamic-extent delete-match))
300        ; get rid of the predicate
301        (maphash delete-match %structure-refs%)))))
302
303(defun copy-structure (source)
304  "Return a copy of STRUCTURE with the same (EQL) slot values."
305  (copy-uvector (require-type source 'structure-object)))
306
307(provide 'defstruct)
308
309; End of defstruct.lisp
Note: See TracBrowser for help on using the repository browser.