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

Last change on this file since 14308 was 14308, checked in by rme, 9 years ago

Merge r14305--r14307 from trunk. (Avoid spurious warnings about
unknown/forward-referenced types in DEFSTRUCT.)

See ITA bug 86893.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 12.6 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 accessor-structref-info-p))
38(defun accessor-structref-info-p (object) ;; as opposed to predicate structref-info.
39  (consp object))
40
41(declaim (inline structref-info-type))
42(defun structref-info-type (info)
43  (when (consp info)
44    (if (consp (%car info)) (%caar info) 't)))
45
46(declaim (inline structref-info-refinfo))
47(defun structref-info-refinfo (info)
48  (when (consp info)
49    (if (consp (%car info)) (%cdar info) (%car info))))
50
51(defun structref-set-r/o (sym &optional env)
52  (let ((info (structref-info sym env)))
53    (when (accessor-structref-info-p info)
54      (if (consp (%car info))
55        (setf (%cdar info) (%ilogior2 (%ilsl $struct-r/o 1) (%cdar info)))
56        (setf (%car info) (%ilogior2 (%ilsl $struct-r/o 1) (%car info)))))))
57
58(declaim (inline structref-info-struct))
59(defun structref-info-struct (info)
60  (when (consp info)
61    (%cdr info)))
62
63(defun ssd-set-reftype (ssd reftype)
64  (ssd-update-refinfo (ssd refinfo)
65                      (%ilogior2 (%ilogand2 #x300FFFF refinfo)
66                                 (%ilsl 16 reftype))))
67
68(defun ssd-set-r/o (ssd) 
69  (ssd-update-refinfo (ssd refinfo)
70                      (%ilogior2 (%ilsl $struct-r/o 1) refinfo)))
71
72(defun ssd-set-inherited (ssd)
73  (ssd-update-refinfo (ssd refinfo)
74                       (bitset $struct-inherited refinfo)))
75
76(defun copy-ssd (ssd)
77  (let* ((cdr (cdr ssd))
78         (cddr (cdr cdr)))
79    (list* (%car ssd) (%car cdr)
80           (if (consp cddr)
81             (list* (%car cddr) (%cdr cddr))
82             cddr))))
83
84(declaim (inline ssd-type-and-refinfo))
85(defun ssd-type-and-refinfo (ssd)
86  (cddr ssd))
87
88(defun ssd-type (ssd)
89  (let ((type-and-refinfo (ssd-type-and-refinfo ssd)))
90    (if (consp type-and-refinfo)
91      (%car type-and-refinfo)
92      't)))
93
94(defun ssd-refinfo (ssd)
95  (let ((type-and-refinfo (ssd-type-and-refinfo ssd)))
96    (if (consp type-and-refinfo) (%cdr type-and-refinfo) type-and-refinfo)))
97
98(defun %structure-class-of (thing)
99  (let* ((cell (car (uvref thing 0))))
100    (or (class-cell-class cell)
101        (setf (class-cell-class cell)
102              (find-class (class-cell-name cell))))))
103
104;These might want to compiler-transform into non-typechecking versions...
105(defun struct-ref (struct offset)
106  (if (structurep struct) (uvref struct offset)
107      (report-bad-arg struct 'structure-object)))
108
109(defun struct-set (struct offset value)
110  (if (structurep struct) (uvset struct offset value)
111      (report-bad-arg struct 'structure-object)))
112
113(defsetf struct-ref struct-set)
114
115
116; things for defstruct to do - at load time
117(defun %defstruct-do-load-time (sd predicate &optional doc &aux (name (sd-name sd)))
118  ;(declare (ignore refnames))
119  (when (null (sd-type sd))
120    (%define-structure-class sd))
121  (when (and doc *save-doc-strings*)
122    (set-documentation name 'type doc)) 
123  (puthash name %defstructs% sd)
124  (record-source-file name 'structure)
125  (when (and predicate (null (sd-type sd)))
126    (puthash predicate %structure-refs% name)) 
127  (when *fasload-print* (format t "~&~S~%" name))
128  name)
129
130(defun %defstruct-set-print-function (sd print-function print-object-p)
131  (sd-set-print-function sd (if print-object-p
132                              (list print-function)
133                              print-function)))
134
135(defun sd-refname-in-included-struct-p (sd name &optional env)
136  (dolist (included-type (cdr (sd-superclasses sd)))
137    (let ((sub-sd (or (let ((defenv (definition-environment env)))
138                        (when defenv (%cdr (assq included-type
139                                                 (defenv.structures
140                                                     defenv)))))
141                      (gethash included-type %defstructs%))))
142      (when sub-sd
143        (if (member name (sd-refnames sub-sd) :test 'eq)
144          (return t))))))
145
146(defun sd-refname-pos-in-included-struct (sd name)
147  (dolist (included-type (cdr (sd-superclasses sd)))
148    (let ((sub-sd (gethash included-type %defstructs%)))
149      (when sub-sd
150        (let ((refnames (sd-refnames sub-sd)))
151          (if refnames
152            (let ((pos (position name refnames :test 'eq)))
153              (and pos (1+ pos)))
154            (dolist (slot (sd-slots sub-sd))
155              (let ((ssd-name (ssd-name slot)))
156                (unless (fixnump ssd-name)
157                  (when (eq name ssd-name)
158                    (return-from sd-refname-pos-in-included-struct
159                      (ssd-offset slot))))))))))))
160
161;;; return stuff for defstruct to compile
162(defun %defstruct-compile (sd refnames env)
163  (let ((stuff)
164        (struct (and (not (sd-type sd)) (sd-name sd))))
165    (dolist (slot (sd-slots sd))
166      (unless (fixnump (ssd-name slot))
167        (let* ((accessor (if refnames (pop refnames) (ssd-name slot)))
168               (pos (sd-refname-pos-in-included-struct sd accessor)))
169          (if pos
170            (let ((offset (ssd-offset slot)))
171              (unless (eql pos offset)
172                ;; This should be a style-warning
173                (warn "Accessor ~s at different position than in included structure"
174                      accessor)))
175            (unless (sd-refname-in-included-struct-p sd accessor env)
176              (let ((fn (slot-accessor-fn sd slot accessor env))
177                    (info (cons (ssd-type-and-refinfo slot) struct)))
178                (push
179                 `(progn
180                    ,.fn
181                    (puthash ',accessor %structure-refs% ',info)
182                    (record-source-file ',accessor 'structure-accessor))
183                 stuff)))))))
184    (nreverse stuff)))
185
186(defun defstruct-var (name env)
187  (declare (ignore env))
188  (if (symbolp name)
189    (if (or (constant-symbol-p name) (proclaimed-special-p name))
190      (make-symbol (symbol-name name))
191      name)
192    'object))
193
194(defun slot-accessor-fn (sd slot name env)
195  (let* ((ref (ssd-reftype slot))
196         (offset (ssd-offset slot))
197         (arg (defstruct-var (sd-name sd) env))
198         (value (gensym "VALUE"))
199         (type (defstruct-type-for-typecheck (ssd-type slot) env))
200         (form (cond ((eq ref $defstruct-nth)
201                      `(nth ,offset ,arg))
202                     ((eq ref $defstruct-struct)
203                      `(struct-ref (typecheck ,arg ,(sd-name sd)) ,offset))
204                     ((or (eq ref target::subtag-simple-vector)
205                          (eq ref $defstruct-simple-vector))
206                      `(svref ,arg ,offset))
207                     (t `(uvref ,arg ,offset)))))
208    `((defun ,name (,arg)
209        ,(cond ((eq type t) form)
210               ((nx-declarations-typecheck env)
211                ;; TYPE may be unknown.  For example, it may be
212                ;; forward-referenced.  Insert a run-time check in
213                ;; this case.
214                `(require-type ,form ',type))
215               (t `(the ,type ,form))))
216      ,@(unless (ssd-r/o slot)
217          `((defun (setf ,name) (,value ,arg)
218              ,(cond
219                ((eq type t) `(setf ,form ,value))
220                ((nx-declarations-typecheck env)
221                 ;; Checking the type of SETF's return value seems
222                 ;; kind of pointless here.
223                 `(require-type (setf ,form (typecheck ,value ,type)) ',type))
224                (t
225                 `(the ,type (setf ,form (typecheck ,value ,type)))))))))))
226
227(defun defstruct-reftype (type)
228  (cond ((null type) $defstruct-struct)
229        ((eq type 'list) $defstruct-nth)
230        (t (element-type-subtype (cadr type)))))
231
232(defun defstruct-slot-defs (sd refnames env)
233  (declare (ignore env))
234  (let ((ref (defstruct-reftype (sd-type sd))) name defs)
235    (dolist (slot (sd-slots sd))
236      (ssd-set-reftype slot ref)
237      (unless (fixnump (setq name (ssd-name slot))) ;Ignore fake 'name' slots
238        (when refnames (setq name (pop refnames)))
239        (unless (sd-refname-pos-in-included-struct sd name)
240          (push name defs))))
241    (setq defs (nreverse defs))
242    `((declaim (inline ,@defs)))))
243
244(defun structref-info (sym &optional env)
245  (let ((info (or (and env (environment-structref-info sym env))
246                  (gethash sym %structure-refs%))))
247    ;; This can be removed once $fasl-min-vers is greater than #x5e
248    #-BOOTSTRAPPED
249    (when (or (fixnump info)
250              (and (consp info) (fixnump (%cdr info))))
251      ;; Old style, without struct type info.
252      (setq info (cons info 'structure-object)))
253    info))
254
255(defun defstruct-type-for-typecheck (type env)
256  (if (or (eq type 't)
257          (specifier-type-if-known type env)
258          (nx-declarations-typecheck env))
259    type
260    ;; Else have an unknown type used only for an implicit declaration.
261    ;; Just ignore it, it's most likely a forward reference, and while it
262    ;; means we might be missing out on a possible optimization, most of
263    ;; the time it's not worth warning about.
264    't))
265
266;;;Used by nx-transform, setf, and whatever...
267(defun defstruct-ref-transform (structref-info args env &optional no-type-p)
268  (if (accessor-structref-info-p structref-info)
269    (let* ((type (if no-type-p
270                   't
271                   (defstruct-type-for-typecheck (structref-info-type structref-info) env)))
272           (refinfo (structref-info-refinfo structref-info))
273           (offset (refinfo-offset refinfo))
274           (ref (refinfo-reftype refinfo))
275           (accessor
276            (cond ((eq ref $defstruct-nth)
277                   `(nth ,offset ,@args))
278                  ((eq ref $defstruct-struct)
279                   `(struct-ref (typecheck ,@args ,(structref-info-struct structref-info)) ,offset))
280                  ((eq ref target::subtag-simple-vector)
281                   `(svref ,@args ,offset))
282                  (ref
283                   `(aref (the (simple-array ,(element-subtype-type ref) (*))
284                               ,@args) ,offset))
285                  (t `(uvref ,@args ,offset)))))
286      (if (eq type 't)
287        accessor
288        `(the ,type ,accessor)))
289    `(structure-typep ,@args ',structref-info)))
290
291;;; Should probably remove the constructor, copier, and predicate as
292;;; well. Can't remove the inline proclamations for the refnames,
293;;; as the user may have explicitly said this. Questionable - but surely
294;;; must delete the inline definitions.
295;;; Doesn't remove the copier because we don't know for sure what it's name is
296(defmethod change-class ((from structure-class)
297                         (to class)
298                          &rest initargs &key &allow-other-keys)
299  (declare (dynamic-extent initargs))
300  (let ((class-name (class-name from)))
301    (unless (eq from to)                  ; shouldn't be
302      (remove-structure-defs class-name)
303      (remhash class-name %defstructs%)))
304  (%change-class from to initargs))
305
306;;; if redefining a structure as another structure or redefining a
307;;; structure as a class
308(defun remove-structure-defs (class-name)
309  (let ((sd (gethash class-name %defstructs%)))
310    (when sd
311      (dolist (refname (sd-refnames sd))
312        (let ((def (assq refname *nx-globally-inline*)))
313          (when def (set-function-info refname nil)))
314        (let ((info (structref-info refname)))
315          (when (accessor-structref-info-p info)
316            (unless (refinfo-r/o (structref-info-refinfo info))
317              (fmakunbound (setf-function-name refname)))
318            (fmakunbound refname))))
319      #|
320      ;; The print-function may indeed have become obsolete,
321      ;; but we can't generally remove user-defined code
322      (let ((print-fn (sd-print-function sd)))
323        (when (symbolp print-fn) (fmakunbound print-fn)))
324      |#
325      (let ((constructor (sd-constructor sd)))
326        (when (symbolp constructor) (fmakunbound constructor)))
327      (let ((delete-match #'(lambda (pred struct-name)
328                              (when (eq struct-name class-name)
329                                (remhash pred %structure-refs%)
330                                (fmakunbound pred)))))
331        (declare (dynamic-extent delete-match))
332        ; get rid of the predicate
333        (maphash delete-match %structure-refs%)))))
334
335(defun copy-structure (source)
336  "Return a copy of STRUCTURE with the same (EQL) slot values."
337  (copy-uvector (require-type source 'structure-object)))
338
339(provide 'defstruct)
340
341; End of defstruct.lisp
Note: See TracBrowser for help on using the repository browser.