LCOV - code coverage report
Current view: top level - lisp/emacs-lisp - cl-preloaded.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 49 80 61.2 %
Date: 2017-08-30 10:12:24 Functions: 4 10 40.0 %

          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

Generated by: LCOV version 1.12