1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
|
;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*-
;; Copyright (C) 2015 Free Software Foundation, Inc
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; This file is part of GNU Emacs.
;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; The cl-defstruct macro is full of circularities, since it uses the
;; cl-structure-class type (and its accessors) which is defined with itself,
;; and it setups a default parent (cl-structure-object) which is also defined
;; with cl-defstruct, and to make things more interesting, the class of
;; cl-structure-object is of course an object of type cl-structure-class while
;; cl-structure-class's parent is cl-structure-object.
;; Furthermore, the code generated by cl-defstruct generally assumes that the
;; parent will be loaded when the child is loaded. But at the same time, the
;; expectation is that structs defined with cl-defstruct do not need cl-lib at
;; run-time, which means that the `cl-structure-object' parent can't be in
;; cl-lib but should be preloaded. So here's this preloaded circular setup.
;;; Code:
(eval-when-compile (require 'cl-lib))
(eval-when-compile (require 'cl-macs)) ;For cl--struct-class.
;; The `assert' macro from the cl package signals
;; `cl-assertion-failed' at runtime so always define it.
(define-error 'cl-assertion-failed (purecopy "Assertion failed"))
(defun cl--assertion-failed (form &optional string sargs args)
(if debug-on-error
(debug `(cl-assertion-failed ,form ,string ,@sargs))
(if string
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
;; When we load this (compiled) file during pre-loading, the cl--struct-class
;; code below will need to access the `cl-struct' info, since it's considered
;; already as its parent (because `cl-struct' was defined while the file was
;; compiled). So let's temporarily setup a fake.
(defvar cl-struct-cl-structure-object-tags nil)
(unless (cl--find-class 'cl-structure-object)
(setf (cl--find-class 'cl-structure-object) 'dummy))
(fset 'cl--make-slot-desc
;; To break circularity, we pre-define the slot constructor by hand.
;; It's redefined a bit further down as part of the cl-defstruct of
;; cl--slot-descriptor.
;; BEWARE: Obviously, it's important to keep the two in sync!
(lambda (name &optional initform type props)
(vector 'cl-struct-cl-slot-descriptor
name initform type props)))
(defun cl--struct-get-class (name)
(or (if (not (symbolp name)) name)
(cl--find-class name)
(if (not (get name 'cl-struct-type))
;; FIXME: Add a conversion for `eieio--class' so we can
;; create a cl-defstruct that inherits from an eieio class?
(error "%S is not a struct name" name)
;; Backward compatibility with a defstruct compiled with a version
;; cl-defstruct from Emacs<25. Convert to new format.
(let ((tag (intern (format "cl-struct-%s" name)))
(type-and-named (get name 'cl-struct-type))
(descs (get name 'cl-struct-slots)))
(cl-struct-define name nil (get name 'cl-struct-include)
(unless (and (eq (car type-and-named) 'vector)
(null (cadr type-and-named))
(assq 'cl-tag-slot descs))
(car type-and-named))
(cadr type-and-named)
descs
(intern (format "cl-struct-%s-tags" name))
tag
(get name 'cl-struct-print))
(cl--find-class name)))))
(defun cl--plist-remove (plist member)
(cond
((null plist) nil)
((null member) plist)
((eq plist member) (cddr plist))
(t `(,(car plist) ,(cadr plist) ,@(cl--plist-remove (cddr plist) member)))))
(defun cl--struct-register-child (parent tag)
;; Can't use (cl-typep parent 'cl-structure-class) at this stage
;; because `cl-structure-class' is defined later.
(while (vectorp parent)
(add-to-list (cl--struct-class-children-sym parent) tag)
;; Only register ourselves as a child of the leftmost parent since structs
;; can only only have one parent.
(setq parent (car (cl--struct-class-parents parent)))))
;;;###autoload
(defun cl-struct-define (name docstring parent type named slots children-sym
tag print)
(cl-assert (or type (not named)))
(if (boundp children-sym)
(add-to-list children-sym tag)
(set children-sym (list tag)))
(and (null type) (eq (caar slots) 'cl-tag-slot)
;; Hide the tag slot from "standard" (i.e. non-`type'd) structs.
(setq slots (cdr slots)))
(let* ((parent-class (when parent (cl--struct-get-class parent)))
(n (length slots))
(index-table (make-hash-table :test 'eq :size n))
(vslots (let ((v (make-vector n nil))
(i 0)
(offset (if type 0 1)))
(dolist (slot slots)
(let* ((props (cddr slot))
(typep (plist-member props :type))
(type (if typep (cadr typep) t)))
(aset v i (cl--make-slot-desc
(car slot) (nth 1 slot)
type (cl--plist-remove props typep))))
(puthash (car slot) (+ i offset) index-table)
(cl-incf i))
v))
(class (cl--struct-new-class
name docstring
(unless (symbolp parent-class) (list parent-class))
type named vslots index-table children-sym tag print)))
(unless (symbolp parent-class)
(let ((pslots (cl--struct-class-slots parent-class)))
(or (>= n (length pslots))
(let ((ok t))
(dotimes (i (length pslots))
(unless (eq (cl--slot-descriptor-name (aref pslots i))
(cl--slot-descriptor-name (aref vslots i)))
(setq ok nil)))
ok)
(error "Included struct %S has changed since compilation of %S"
parent name))))
(add-to-list 'current-load-list `(define-type . ,name))
(cl--struct-register-child parent-class tag)
(unless (eq named t)
(eval `(defconst ,tag ',class) t)
;; In the cl-generic support, we need to be able to check
;; if a vector is a cl-struct object, without knowing its particular type.
;; So we use the (otherwise) unused function slots of the tag symbol
;; to put a special witness value, to make the check easy and reliable.
(fset tag :quick-object-witness-check))
(setf (cl--find-class name) class)))
(cl-defstruct (cl-structure-class
(:conc-name cl--struct-class-)
(:predicate cl--struct-class-p)
(:constructor nil)
(:constructor cl--struct-new-class
(name docstring parents type named slots index-table
children-sym tag print))
(:copier nil))
"The type of CL structs descriptors."
;; The first few fields here are actually inherited from cl--class, but we
;; have to define this one before, to break the circularity, so we manually
;; list the fields here and later "backpatch" cl--class as the parent.
;; BEWARE: Obviously, it's indispensable to keep these two structs in sync!
(name nil :type symbol) ;The type name.
(docstring nil :type string)
(parents nil :type (list-of cl--class)) ;The included struct.
(slots nil :type (vector cl--slot-descriptor))
(index-table nil :type hash-table)
(tag nil :type symbol) ;Placed in cl-tag-slot. Holds the struct-class object.
(type nil :type (memq (vector list)))
(named nil :type bool)
(print nil :type bool)
(children-sym nil :type symbol) ;This sym's value holds the tags of children.
)
(cl-defstruct (cl-structure-object
(:predicate cl-struct-p)
(:constructor nil)
(:copier nil))
"The root parent of all \"normal\" CL structs")
(setq cl--struct-default-parent 'cl-structure-object)
(cl-defstruct (cl-slot-descriptor
(:conc-name cl--slot-descriptor-)
(:constructor nil)
(:constructor cl--make-slot-descriptor
(name &optional initform type props))
(:copier cl--copy-slot-descriptor-1))
;; FIXME: This is actually not used yet, for circularity reasons!
"Descriptor of structure slot."
name ;Attribute name (symbol).
initform
type
;; Extra properties, kept in an alist, can include:
;; :documentation, :protection, :custom, :label, :group, :printer.
(props nil :type alist))
(defun cl--copy-slot-descriptor (slot)
(let ((new (cl--copy-slot-descriptor-1 slot)))
(cl-callf copy-alist (cl--slot-descriptor-props new))
new))
(cl-defstruct (cl--class
(:constructor nil)
(:copier nil))
"Type of descriptors for any kind of structure-like data."
;; Intended to be shared between defstruct and defclass.
(name nil :type symbol) ;The type name.
(docstring nil :type string)
;; For structs there can only be one parent, but when EIEIO classes inherit
;; from cl--class, we'll need this to hold a list.
(parents nil :type (list-of cl--class))
(slots nil :type (vector cl-slot-descriptor))
(index-table nil :type hash-table))
(cl-assert
(let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class)))
(c-slots (cl--struct-class-slots (cl--find-class 'cl--class)))
(eq t))
(dotimes (i (length c-slots))
(let ((sc-slot (aref sc-slots i))
(c-slot (aref c-slots i)))
(unless (eq (cl--slot-descriptor-name sc-slot)
(cl--slot-descriptor-name c-slot))
(setq eq nil))))
eq))
;; Close the recursion between cl-structure-object and cl-structure-class.
(setf (cl--struct-class-parents (cl--find-class 'cl-structure-class))
(list (cl--find-class 'cl--class)))
(cl--struct-register-child
(cl--find-class 'cl--class)
(cl--struct-class-tag (cl--find-class 'cl-structure-class)))
(cl-assert (cl--find-class 'cl-structure-class))
(cl-assert (cl--find-class 'cl-structure-object))
(cl-assert (cl-struct-p (cl--find-class 'cl-structure-class)))
(cl-assert (cl-struct-p (cl--find-class 'cl-structure-object)))
(cl-assert (cl--class-p (cl--find-class 'cl-structure-class)))
(cl-assert (cl--class-p (cl--find-class 'cl-structure-object)))
;; Make sure functions defined with cl-defsubst can be inlined even in
;; packages which do not require CL. We don't put an autoload cookie
;; directly on that function, since those cookies only go to cl-loaddefs.
(autoload 'cl--defsubst-expand "cl-macs")
;; Autoload, so autoload.el and font-lock can use it even when CL
;; is not loaded.
(put 'cl-defun 'doc-string-elt 3)
(put 'cl-defmacro 'doc-string-elt 3)
(put 'cl-defsubst 'doc-string-elt 3)
(put 'cl-defstruct 'doc-string-elt 2)
(provide 'cl-preloaded)
;;; cl-preloaded.el ends here
|
