1 ;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*-
3 ;; Copyright (C) 2015-2018 Free Software Foundation, Inc
5 ;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
8 ;; This file is part of GNU Emacs.
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.
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.
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
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.
39 (eval-when-compile (require 'cl-lib
))
40 (eval-when-compile (require 'cl-macs
)) ;For cl--struct-class.
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"))
46 (defun cl--assertion-failed (form &optional string sargs args
)
48 (funcall debugger
'error
`(cl-assertion-failed (,form
,string
,@sargs
)))
50 (apply #'error string
(append sargs args
))
51 (signal 'cl-assertion-failed
`(,form
,@sargs
)))))
53 (defconst cl--typeof-types
54 ;; Hand made from the source code of `type-of'.
55 '((integer number number-or-marker atom
)
56 (symbol atom
) (string array sequence atom
)
58 ;; Markers aren't `numberp', yet they are accepted wherever integers are
59 ;; accepted, pretty much.
60 (marker number-or-marker atom
)
61 (overlay atom
) (float number atom
) (window-configuration atom
)
62 (process atom
) (window atom
) (subr atom
) (compiled-function function atom
)
63 (buffer atom
) (char-table array sequence atom
)
64 (bool-vector array sequence atom
)
65 (frame atom
) (hash-table atom
) (terminal atom
)
66 (thread atom
) (mutex atom
) (condvar atom
)
67 (font-spec atom
) (font-entity atom
) (font-object atom
)
68 (vector array sequence atom
)
69 ;; Plus, really hand made:
70 (null symbol list sequence atom
))
72 Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
73 the symbols returned by `type-of', and SUPERTYPES is the list of its
74 supertypes from the most specific to least specific.")
76 (defconst cl--all-builtin-types
77 (delete-dups (copy-sequence (apply #'append cl--typeof-types
))))
79 (defun cl--struct-name-p (name)
80 "Return t if NAME is a valid structure name for `cl-defstruct'."
81 (and name
(symbolp name
) (not (keywordp name
))
82 (not (memq name cl--all-builtin-types
))))
84 ;; When we load this (compiled) file during pre-loading, the cl--struct-class
85 ;; code below will need to access the `cl-struct' info, since it's considered
86 ;; already as its parent (because `cl-struct' was defined while the file was
87 ;; compiled). So let's temporarily setup a fake.
88 (defvar cl-struct-cl-structure-object-tags nil
)
89 (unless (cl--find-class 'cl-structure-object
)
90 (setf (cl--find-class 'cl-structure-object
) 'dummy
))
92 (fset 'cl--make-slot-desc
93 ;; To break circularity, we pre-define the slot constructor by hand.
94 ;; It's redefined a bit further down as part of the cl-defstruct of
95 ;; cl-slot-descriptor.
96 ;; BEWARE: Obviously, it's important to keep the two in sync!
97 (lambda (name &optional initform type props
)
98 (record 'cl-slot-descriptor
99 name initform type props
)))
101 (defun cl--struct-get-class (name)
102 (or (if (not (symbolp name
)) name
)
103 (cl--find-class name
)
104 (if (not (get name
'cl-struct-type
))
105 ;; FIXME: Add a conversion for `eieio--class' so we can
106 ;; create a cl-defstruct that inherits from an eieio class?
107 (error "%S is not a struct name" name
)
108 ;; Backward compatibility with a defstruct compiled with a version
109 ;; cl-defstruct from Emacs<25. Convert to new format.
110 (let ((tag (intern (format "cl-struct-%s" name
)))
111 (type-and-named (get name
'cl-struct-type
))
112 (descs (get name
'cl-struct-slots
)))
113 (cl-struct-define name nil
(get name
'cl-struct-include
)
114 (unless (and (eq (car type-and-named
) 'vector
)
115 (null (cadr type-and-named
))
116 (assq 'cl-tag-slot descs
))
117 (car type-and-named
))
118 (cadr type-and-named
)
120 (intern (format "cl-struct-%s-tags" name
))
122 (get name
'cl-struct-print
))
123 (cl--find-class name
)))))
125 (defun cl--plist-remove (plist member
)
128 ((null member
) plist
)
129 ((eq plist member
) (cddr plist
))
130 (t `(,(car plist
) ,(cadr plist
) ,@(cl--plist-remove (cddr plist
) member
)))))
132 (defun cl--struct-register-child (parent tag
)
133 ;; Can't use (cl-typep parent 'cl-structure-class) at this stage
134 ;; because `cl-structure-class' is defined later.
135 (while (recordp parent
)
136 (add-to-list (cl--struct-class-children-sym parent
) tag
)
137 ;; Only register ourselves as a child of the leftmost parent since structs
138 ;; can only only have one parent.
139 (setq parent
(car (cl--struct-class-parents parent
)))))
142 (defun cl-struct-define (name docstring parent type named slots children-sym
144 (cl-check-type name cl--struct-name
)
146 ;; Legacy defstruct, using tagged vectors. Enable backward compatibility.
147 (cl-old-struct-compat-mode 1))
148 (if (eq type
'record
)
149 ;; Defstruct using record objects.
151 (cl-assert (or type
(not named
)))
152 (if (boundp children-sym
)
153 (add-to-list children-sym tag
)
154 (set children-sym
(list tag
)))
155 (and (null type
) (eq (caar slots
) 'cl-tag-slot
)
156 ;; Hide the tag slot from "standard" (i.e. non-`type'd) structs.
157 (setq slots
(cdr slots
)))
158 (let* ((parent-class (when parent
(cl--struct-get-class parent
)))
160 (index-table (make-hash-table :test
'eq
:size n
))
161 (vslots (let ((v (make-vector n nil
))
163 (offset (if type
0 1)))
165 (let* ((props (cddr slot
))
166 (typep (plist-member props
:type
))
167 (type (if typep
(cadr typep
) t
)))
168 (aset v i
(cl--make-slot-desc
169 (car slot
) (nth 1 slot
)
170 type
(cl--plist-remove props typep
))))
171 (puthash (car slot
) (+ i offset
) index-table
)
174 (class (cl--struct-new-class
176 (unless (symbolp parent-class
) (list parent-class
))
177 type named vslots index-table children-sym tag print
)))
178 (unless (symbolp parent-class
)
179 (let ((pslots (cl--struct-class-slots parent-class
)))
180 (or (>= n
(length pslots
))
182 (dotimes (i (length pslots
))
183 (unless (eq (cl--slot-descriptor-name (aref pslots i
))
184 (cl--slot-descriptor-name (aref vslots i
)))
187 (error "Included struct %S has changed since compilation of %S"
189 (add-to-list 'current-load-list
`(define-type .
,name
))
190 (cl--struct-register-child parent-class tag
)
191 (unless (or (eq named t
) (eq tag name
))
192 ;; We used to use `defconst' instead of `set' but that
193 ;; has a side-effect of purecopying during the dump, so that the
194 ;; class object stored in the tag ends up being a *copy* of the
195 ;; one stored in the `cl--class' property! We could have fixed
196 ;; this needless duplication by using the purecopied object, but
197 ;; that then breaks down a bit later when we modify the
198 ;; cl-structure-class class object to close the recursion
199 ;; between cl-structure-object and cl-structure-class (because
200 ;; modifying purecopied objects is not allowed. Since this is
201 ;; done during dumping, we could relax this rule and allow the
202 ;; modification, but it's cumbersome).
203 ;; So in the end, it's easier to just avoid the duplication by
204 ;; avoiding the use of the purespace here.
206 ;; In the cl-generic support, we need to be able to check
207 ;; if a vector is a cl-struct object, without knowing its particular type.
208 ;; So we use the (otherwise) unused function slots of the tag symbol
209 ;; to put a special witness value, to make the check easy and reliable.
210 (fset tag
:quick-object-witness-check
))
211 (setf (cl--find-class name
) class
)))
213 (cl-defstruct (cl-structure-class
214 (:conc-name cl--struct-class-
)
215 (:predicate cl--struct-class-p
)
217 (:constructor cl--struct-new-class
218 (name docstring parents type named slots index-table
219 children-sym tag print
))
221 "The type of CL structs descriptors."
222 ;; The first few fields here are actually inherited from cl--class, but we
223 ;; have to define this one before, to break the circularity, so we manually
224 ;; list the fields here and later "backpatch" cl--class as the parent.
225 ;; BEWARE: Obviously, it's indispensable to keep these two structs in sync!
226 (name nil
:type symbol
) ;The type name.
227 (docstring nil
:type string
)
228 (parents nil
:type
(list-of cl--class
)) ;The included struct.
229 (slots nil
:type
(vector cl-slot-descriptor
))
230 (index-table nil
:type hash-table
)
231 (tag nil
:type symbol
) ;Placed in cl-tag-slot. Holds the struct-class object.
232 (type nil
:type
(memq (vector list
)))
233 (named nil
:type bool
)
234 (print nil
:type bool
)
235 (children-sym nil
:type symbol
) ;This sym's value holds the tags of children.
238 (cl-defstruct (cl-structure-object
239 (:predicate cl-struct-p
)
242 "The root parent of all \"normal\" CL structs")
244 (setq cl--struct-default-parent
'cl-structure-object
)
246 (cl-defstruct (cl-slot-descriptor
247 (:conc-name cl--slot-descriptor-
)
249 (:constructor cl--make-slot-descriptor
250 (name &optional initform type props
))
251 (:copier cl--copy-slot-descriptor-1
))
252 ;; FIXME: This is actually not used yet, for circularity reasons!
253 "Descriptor of structure slot."
254 name
;Attribute name (symbol).
257 ;; Extra properties, kept in an alist, can include:
258 ;; :documentation, :protection, :custom, :label, :group, :printer.
259 (props nil
:type alist
))
261 (defun cl--copy-slot-descriptor (slot)
262 (let ((new (cl--copy-slot-descriptor-1 slot
)))
263 (cl-callf copy-alist
(cl--slot-descriptor-props new
))
266 (cl-defstruct (cl--class
269 "Type of descriptors for any kind of structure-like data."
270 ;; Intended to be shared between defstruct and defclass.
271 (name nil
:type symbol
) ;The type name.
272 (docstring nil
:type string
)
273 ;; For structs there can only be one parent, but when EIEIO classes inherit
274 ;; from cl--class, we'll need this to hold a list.
275 (parents nil
:type
(list-of cl--class
))
276 (slots nil
:type
(vector cl-slot-descriptor
))
277 (index-table nil
:type hash-table
))
280 (let ((sc-slots (cl--struct-class-slots (cl--find-class 'cl-structure-class
)))
281 (c-slots (cl--struct-class-slots (cl--find-class 'cl--class
)))
283 (dotimes (i (length c-slots
))
284 (let ((sc-slot (aref sc-slots i
))
285 (c-slot (aref c-slots i
)))
286 (unless (eq (cl--slot-descriptor-name sc-slot
)
287 (cl--slot-descriptor-name c-slot
))
291 ;; Close the recursion between cl-structure-object and cl-structure-class.
292 (setf (cl--struct-class-parents (cl--find-class 'cl-structure-class
))
293 (list (cl--find-class 'cl--class
)))
294 (cl--struct-register-child
295 (cl--find-class 'cl--class
)
296 (cl--struct-class-tag (cl--find-class 'cl-structure-class
)))
298 (cl-assert (cl--find-class 'cl-structure-class
))
299 (cl-assert (cl--find-class 'cl-structure-object
))
300 (cl-assert (cl-struct-p (cl--find-class 'cl-structure-class
)))
301 (cl-assert (cl-struct-p (cl--find-class 'cl-structure-object
)))
302 (cl-assert (cl--class-p (cl--find-class 'cl-structure-class
)))
303 (cl-assert (cl--class-p (cl--find-class 'cl-structure-object
)))
305 ;; Make sure functions defined with cl-defsubst can be inlined even in
306 ;; packages which do not require CL. We don't put an autoload cookie
307 ;; directly on that function, since those cookies only go to cl-loaddefs.
308 (autoload 'cl--defsubst-expand
"cl-macs")
309 ;; Autoload, so autoload.el and font-lock can use it even when CL
311 (put 'cl-defun
'doc-string-elt
3)
312 (put 'cl-defmacro
'doc-string-elt
3)
313 (put 'cl-defsubst
'doc-string-elt
3)
314 (put 'cl-defstruct
'doc-string-elt
2)
316 (provide 'cl-preloaded
)
317 ;;; cl-preloaded.el ends here