code.delx.au - gnu-emacs/blob - lisp/emacs-lisp/cl-preloaded.el

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