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