1
0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-13 09:32:47 +00:00
emacs/lisp/emacs-lisp/cl-preloaded.el
Paul Eggert 4cd143aded Fix copyright years by hand
These are dates that admin/update-copyright did not update.
2020-01-01 01:01:53 +00:00

320 lines
14 KiB
EmacsLisp

;;; cl-preloaded.el --- Preloaded part of the CL library -*- lexical-binding: t; -*-
;; Copyright (C) 2015-2020 Free Software Foundation, Inc
;; Author: Stefan Monnier <monnier@iro.umontreal.ca>
;; Package: emacs
;; 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 <https://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
(funcall debugger 'error `(cl-assertion-failed (,form ,string ,@sargs)))
(if string
(apply #'error string (append sargs args))
(signal 'cl-assertion-failed `(,form ,@sargs)))))
(defconst cl--typeof-types
;; Hand made from the source code of `type-of'.
'((integer number number-or-marker atom)
(symbol atom) (string array sequence atom)
(cons list sequence)
;; Markers aren't `numberp', yet they are accepted wherever integers are
;; accepted, pretty much.
(marker number-or-marker atom)
(overlay atom) (float number atom) (window-configuration atom)
(process atom) (window atom) (subr atom) (compiled-function function atom)
(module-function function atom)
(buffer atom) (char-table array sequence atom)
(bool-vector array sequence atom)
(frame atom) (hash-table atom) (terminal atom)
(thread atom) (mutex atom) (condvar atom)
(font-spec atom) (font-entity atom) (font-object atom)
(vector array sequence atom)
(user-ptr atom)
;; Plus, really hand made:
(null symbol list sequence atom))
"Alist of supertypes.
Each element has the form (TYPE . SUPERTYPES) where TYPE is one of
the symbols returned by `type-of', and SUPERTYPES is the list of its
supertypes from the most specific to least specific.")
(defconst cl--all-builtin-types
(delete-dups (copy-sequence (apply #'append cl--typeof-types))))
(defun cl--struct-name-p (name)
"Return t if NAME is a valid structure name for `cl-defstruct'."
(and name (symbolp name) (not (keywordp name))
(not (memq name cl--all-builtin-types))))
;; 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)
(record '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 (recordp 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-check-type name cl--struct-name)
(unless type
;; Legacy defstruct, using tagged vectors. Enable backward compatibility.
(cl-old-struct-compat-mode 1))
(if (eq type 'record)
;; Defstruct using record objects.
(setq type nil))
(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 (or (eq named t) (eq tag name))
;; We used to use `defconst' instead of `set' but that
;; has a side-effect of purecopying during the dump, so that the
;; class object stored in the tag ends up being a *copy* of the
;; one stored in the `cl--class' property! We could have fixed
;; this needless duplication by using the purecopied object, but
;; that then breaks down a bit later when we modify the
;; cl-structure-class class object to close the recursion
;; between cl-structure-object and cl-structure-class (because
;; modifying purecopied objects is not allowed. Since this is
;; done during dumping, we could relax this rule and allow the
;; modification, but it's cumbersome).
;; So in the end, it's easier to just avoid the duplication by
;; avoiding the use of the purespace here.
(set tag class)
;; 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