diff --git a/lisp/ChangeLog b/lisp/ChangeLog index d61a0a67673..2db0f9a349a 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,31 @@ +2015-03-18 Stefan Monnier + + Add classes as run-time descriptors of cl-structs. + * emacs-lisp/cl-preloaded.el (cl--struct-get-class): New function. + (cl--make-slot-desc): New constructor. + (cl--plist-remove, cl--struct-register-child): New functions. + (cl-struct-define): Rewrite. + (cl-structure-class, cl-structure-object, cl-slot-descriptor) + (cl--class): New structs. + (cl--struct-default-parent): Initialize it here. + * emacs-lisp/cl-macs.el (cl--find-class): New macro. + (cl-defsubst, cl--defsubst-expand, cl--sublis): Move before first use. + (cl--struct-default-parent): New var. + (cl-defstruct): Adjust to new representation of classes; add + default parent. In accessors, signal `wrong-type-argument' rather than + a generic error. + (cl-struct-sequence-type, cl-struct-slot-info) + (cl-struct-slot-offset): Rewrite. + * emacs-lisp/cl-generic.el (cl--generic-struct-specializers) + (cl-generic-generalizers): Rewrite. + + * emacs-lisp/macroexp.el (macroexp--debug-eager): New var. + (internal-macroexpand-for-load): Use it. + + * emacs-lisp/debug.el (debug--implement-debug-on-entry): + Bind inhibit-debug-on-entry here... + (debug): Instead of here. + 2015-03-18 Dima Kogan Have gud-display-line not display source buffer in gud window. @@ -6,13 +34,13 @@ 2015-03-17 Tassilo Horn - * emacs-lisp/byte-run.el (macro-declarations-alist): New - declaration no-font-lock-keyword. + * emacs-lisp/byte-run.el (macro-declarations-alist): + New declaration no-font-lock-keyword. (defmacro): Flush font-lock in existing elisp buffers. * emacs-lisp/lisp-mode.el (lisp--el-update-after-load) - (lisp--el-update-macro-regexp, lisp--el-macro-regexp): Delete - functions and defconst. + (lisp--el-update-macro-regexp, lisp--el-macro-regexp): + Delete functions and defconst. (lisp--el-match-keyword): Rename from lisp--el-match-macro. (lisp--el-font-lock-flush-elisp-buffers): New function. (lisp-mode-variables): Remove code for updating @@ -21,23 +49,17 @@ 2015-03-17 Simen Heggestøyl - * textmodes/css-mode.el (css--font-lock-keywords): Discriminate - between pseudo-classes and pseudo-elements. + * textmodes/css-mode.el (css--font-lock-keywords): + Discriminate between pseudo-classes and pseudo-elements. (css-pseudo-ids): Remove. - (css-pseudo-class-ids): New variable. - (css-pseudo-element-ids): New variable. - (css--complete-property): New function for completing CSS - properties. - (css--complete-pseudo-element-or-class): New function for + (css-pseudo-class-ids, css-pseudo-element-ids): New variables. + (css--complete-property): New function for completing CSS properties. + (css--complete-pseudo-element-or-class): New function completing CSS pseudo-elements and pseudo-classes. (css--complete-at-rule): New function for completing CSS at-rules. - (css-completion-at-point): New function providing completion for - `css-mode'. + (css-completion-at-point): New function. (css-mode): Add support for completion. - (css-extract-keyword-list): Remove function in favor of manual - extraction. - (css-extract-parse-val-grammar): Remove function in favor of - manual extraction. + (css-extract-keyword-list, css-extract-parse-val-grammar) (css-extract-props-and-vals): Remove function in favor of manual extraction. (css-at-ids): Update list of CSS at-rule ids. @@ -163,7 +185,7 @@ * progmodes/sql.el: Version 3.5 (sql-starts-with-prompt-re, sql-ends-with-prompt-re): Match password prompts. - (sql-interactive-remove-continuation-prompt): Fixed regression. (Bug#6686) + (sql-interactive-remove-continuation-prompt): Fix regression. (Bug#6686) 2015-03-14 Daniel Colascione @@ -178,8 +200,8 @@ info-look fixes for Texinfo 5 * info-look.el (c-mode, bison-mode, makefile-mode) (makefile-automake-mode, texinfo-mode, autoconf-mode, awk-mode) - (latex-mode, emacs-lisp-mode, sh-mode, cfengine-mode): Match - `foo' and 'foo' and ‘foo’ for @item and similar. + (latex-mode, emacs-lisp-mode, sh-mode, cfengine-mode): + Match `foo' and 'foo' and ‘foo’ for @item and similar. (latex-mode): Match multi-arg \frac{num}{den} or \sqrt[root]{n} in suffix regexp. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 41c760e960e..c9ca92d7c09 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -857,6 +857,18 @@ Can only be used from within the lexical body of a primary or around method." ;;; Support for cl-defstructs specializers. (defun cl--generic-struct-tag (name) + ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) + ;; but that would suffer from some problems: + ;; - the vector may have size 0. + ;; - when called on an actual vector (rather than an object), we'd + ;; end up returning an arbitrary value, possibly colliding with + ;; other tagcode's values. + ;; - it can also result in returning all kinds of irrelevant + ;; values which would end up filling up the method-cache with + ;; lots of irrelevant/redundant entries. + ;; FIXME: We could speed this up by introducing a dedicated + ;; vector type at the C level, so we could do something like + ;; (and (vector-objectp ,name) (aref ,name 0)) `(and (vectorp ,name) (> (length ,name) 0) (let ((tag (aref ,name 0))) @@ -864,14 +876,18 @@ Can only be used from within the lexical body of a primary or around method." tag)))) (defun cl--generic-struct-specializers (tag) - (and (symbolp tag) - ;; A method call shouldn't itself mess with the match-data. - (string-match-p "\\`cl-struct-\\(.*\\)" (symbol-name tag)) - (let ((types (list (intern (substring (symbol-name tag) 10))))) - (while (get (car types) 'cl-struct-include) - (push (get (car types) 'cl-struct-include) types)) - (push 'cl-structure-object types) ;The "parent type" of all cl-structs. - (nreverse types)))) + (and (symbolp tag) (boundp tag) + (let ((class (symbol-value tag))) + (when (cl-typep class 'cl-structure-class) + (let ((types ()) + (classes (list class))) + ;; BFS precedence. + (while (let ((class (pop classes))) + (push (cl--class-name class) types) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse types)))))) (defconst cl--generic-struct-generalizer (cl-generic-make-generalizer @@ -881,27 +897,17 @@ Can only be used from within the lexical body of a primary or around method." (cl-defmethod cl-generic-generalizers :extra "cl-struct" (type) "Support for dispatch on cl-struct types." (or - (and (symbolp type) - (get type 'cl-struct-type) - (or (null (car (get type 'cl-struct-type))) - (error "Can't dispatch on cl-struct %S: type is %S" - type (car (get type 'cl-struct-type)))) - (or (equal '(cl-tag-slot) (car (get type 'cl-struct-slots))) - (error "Can't dispatch on cl-struct %S: no tag in slot 0" - type)) - ;; It's tempting to use (and (vectorp ,name) (aref ,name 0)) - ;; but that would suffer from some problems: - ;; - the vector may have size 0. - ;; - when called on an actual vector (rather than an object), we'd - ;; end up returning an arbitrary value, possibly colliding with - ;; other tagcode's values. - ;; - it can also result in returning all kinds of irrelevant - ;; values which would end up filling up the method-cache with - ;; lots of irrelevant/redundant entries. - ;; FIXME: We could speed this up by introducing a dedicated - ;; vector type at the C level, so we could do something like - ;; (and (vector-objectp ,name) (aref ,name 0)) - (list cl--generic-struct-generalizer)) + (when (symbolp type) + ;; Use the "cl--struct-class*" (inlinable) functions/macros rather than + ;; the "cl-struct-*" variants which aren't inlined, so that dispatch can + ;; take place without requiring cl-lib. + (let ((class (cl--find-class type))) + (and (cl-typep class 'cl-structure-class) + (when (cl--struct-class-type class) + (error "Can't dispatch on cl-struct %S: type is %S" + type (cl--struct-class-type class))) + (progn (cl-assert (null (cl--struct-class-named class))) t) + (list cl--generic-struct-generalizer)))) (cl-call-next-method))) ;;; Dispatch on "system types". diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 56fbcf0b2fd..d3866783447 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2434,8 +2434,79 @@ Like `cl-callf', but PLACE is the second argument of FUNC, not the first. (if (symbolp func) (cons func rargs) `(funcall #',func ,@rargs)))))))) +;;;###autoload +(defmacro cl-defsubst (name args &rest body) + "Define NAME as a function. +Like `defun', except the function is automatically declared `inline' and +the arguments are immutable. +ARGLIST allows full Common Lisp conventions, and BODY is implicitly +surrounded by (cl-block NAME ...). +The function's arguments should be treated as immutable. + +\(fn NAME ARGLIST [DOCSTRING] BODY...)" + (declare (debug cl-defun) (indent 2)) + (let* ((argns (cl--arglist-args args)) + (p argns) + ;; (pbody (cons 'progn body)) + ) + (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) + `(progn + ,(if p nil ; give up if defaults refer to earlier args + `(cl-define-compiler-macro ,name + ,(if (memq '&key args) + `(&whole cl-whole &cl-quote ,@args) + (cons '&cl-quote args)) + (cl--defsubst-expand + ',argns '(cl-block ,name ,@body) + ;; We used to pass `simple' as + ;; (not (or unsafe (cl-expr-access-order pbody argns))) + ;; But this is much too simplistic since it + ;; does not pay attention to the argvs (and + ;; cl-expr-access-order itself is also too naive). + nil + ,(and (memq '&key args) 'cl-whole) nil ,@argns))) + (cl-defun ,name ,args ,@body)))) + +(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) + (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole + (if (cl--simple-exprs-p argvs) (setq simple t)) + (let* ((substs ()) + (lets (delq nil + (cl-mapcar (lambda (argn argv) + (if (or simple (macroexp-const-p argv)) + (progn (push (cons argn argv) substs) + nil) + (list argn argv))) + argns argvs)))) + ;; FIXME: `sublis/subst' will happily substitute the symbol + ;; `argn' in places where it's not used as a reference + ;; to a variable. + ;; FIXME: `sublis/subst' will happily copy `argv' to a different + ;; scope, leading to name capture. + (setq body (cond ((null substs) body) + ((null (cdr substs)) + (cl-subst (cdar substs) (caar substs) body)) + (t (cl--sublis substs body)))) + (if lets `(let ,lets ,body) body)))) + +(defun cl--sublis (alist tree) + "Perform substitutions indicated by ALIST in TREE (non-destructively)." + (let ((x (assq tree alist))) + (cond + (x (cdr x)) + ((consp tree) + (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) + (t tree)))) + ;;; Structures. +(defmacro cl--find-class (type) + `(get ,type 'cl--class)) + +;; Rather than hard code cl-structure-object, we indirect through this variable +;; for bootstrapping reasons. +(defvar cl--struct-default-parent nil) + ;;;###autoload (defmacro cl-defstruct (struct &rest descs) "Define a struct type. @@ -2491,6 +2562,7 @@ non-nil value, that slot cannot be set via `setf'. (tag (intern (format "cl-struct-%s" name))) (tag-symbol (intern (format "cl-struct-%s-tags" name))) (include-descs nil) + (include-name nil) (type nil) (named nil) (forms nil) @@ -2520,12 +2592,14 @@ non-nil value, that slot cannot be set via `setf'. ((eq opt :predicate) (if args (setq predicate (car args)))) ((eq opt :include) - (when include (error "Can't :include more than once")) - (setq include (car args) - include-descs (mapcar (function - (lambda (x) - (if (consp x) x (list x)))) - (cdr args)))) + ;; FIXME: Actually, we can include more than once as long as + ;; we include EIEIO classes rather than cl-structs! + (when include-name (error "Can't :include more than once")) + (setq include-name (car args)) + (setq include-descs (mapcar (function + (lambda (x) + (if (consp x) x (list x)))) + (cdr args)))) ((eq opt :print-function) (setq print-func (car args))) ((eq opt :type) @@ -2537,19 +2611,21 @@ non-nil value, that slot cannot be set via `setf'. descs))) (t (error "Slot option %s unrecognized" opt))))) + (unless (or include-name type) + (setq include-name cl--struct-default-parent)) + (when include-name (setq include (cl--struct-get-class include-name))) (if print-func (setq print-func `(progn (funcall #',print-func cl-x cl-s cl-n) t)) - (or type (and include (not (get include 'cl-struct-print))) + (or type (and include (not (cl--struct-class-print include))) (setq print-auto t print-func (and (or (not (or include type)) (null print-func)) `(progn (princ ,(format "#S(%s" name) cl-s)))))) (if include - (let ((inc-type (get include 'cl-struct-type)) - (old-descs (get include 'cl-struct-slots))) - (or inc-type (error "%s is not a struct name" include)) - (and type (not (eq (car inc-type) type)) + (let* ((inc-type (cl--struct-class-type include)) + (old-descs (cl-struct-slot-info include))) + (and type (not (eq inc-type type)) (error ":type disagrees with :include for %s" name)) (while include-descs (setcar (memq (or (assq (caar include-descs) old-descs) @@ -2558,9 +2634,9 @@ non-nil value, that slot cannot be set via `setf'. old-descs) (pop include-descs))) (setq descs (append old-descs (delq (assq 'cl-tag-slot descs) descs)) - type (car inc-type) - named (assq 'cl-tag-slot descs)) - (if (cadr inc-type) (setq tag name named t))) + type inc-type + named (if type (assq 'cl-tag-slot descs) 'true)) + (if (cl--struct-class-named include) (setq tag name named t))) (if type (progn (or (memq type '(vector list)) @@ -2605,8 +2681,8 @@ non-nil value, that slot cannot be set via `setf'. (declare (side-effect-free t)) ,@(and pred-check (list `(or ,pred-check - (error "%s accessing a non-%s" - ',accessor ',name)))) + (signal 'wrong-type-argument + (list ',name cl-x))))) ,(if (memq type '(nil vector)) `(aref cl-x ,pos) (if (= pos 0) '(car cl-x) `(nth ,pos cl-x)))) @@ -2682,8 +2758,11 @@ non-nil value, that slot cannot be set via `setf'. `(progn (defvar ,tag-symbol) ,@(nreverse forms) + ;; Call cl-struct-define during compilation as well, so that + ;; a subsequent cl-defstruct in the same file can correctly include this + ;; struct as a parent. (eval-and-compile - (cl-struct-define ',name ,docstring ',include + (cl-struct-define ',name ,docstring ',include-name ',type ,(eq named t) ',descs ',tag-symbol ',tag ',print-auto)) ',name))) @@ -2693,7 +2772,7 @@ non-nil value, that slot cannot be set via `setf'. STRUCT-TYPE is a symbol naming a struct type. Return 'vector or 'list, or nil if STRUCT-TYPE is not a struct type. " (declare (side-effect-free t) (pure t)) - (car (get struct-type 'cl-struct-type))) + (cl--struct-class-type (cl--struct-get-class struct-type))) (defun cl-struct-slot-info (struct-type) "Return a list of slot names of struct STRUCT-TYPE. @@ -2702,7 +2781,19 @@ slot name symbol and OPTS is a list of slot options given to `cl-defstruct'. Dummy slots that represent the struct name and slots skipped by :initial-offset may appear in the list." (declare (side-effect-free t) (pure t)) - (get struct-type 'cl-struct-slots)) + (let* ((class (cl--struct-get-class struct-type)) + (slots (cl--struct-class-slots class)) + (type (cl--struct-class-type class)) + (descs (if type () (list '(cl-tag-slot))))) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (push `(,(cl--slot-descriptor-name slot) + ,(cl--slot-descriptor-initform slot) + ,@(if (not (eq (cl--slot-descriptor-type slot) t)) + `(:type ,(cl--slot-descriptor-type slot))) + ,@(cl--slot-descriptor-props slot)) + descs))) + (nreverse descs))) (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. @@ -2711,9 +2802,8 @@ the structure data type and is adjusted for any structure name and :initial-offset slots. Signal error if struct STRUCT-TYPE does not contain SLOT-NAME." (declare (side-effect-free t) (pure t)) - (or (cl-position slot-name - (cl-struct-slot-info struct-type) - :key #'car :test #'eq) + (or (gethash slot-name + (cl--class-index-table (cl--struct-get-class struct-type))) (error "struct %s has no slot %s" struct-type slot-name))) (defvar byte-compile-function-environment) @@ -2898,70 +2988,6 @@ macro that returns its `&whole' argument." (if cl-found (setcdr cl-found t))) `(throw ,cl-tag ,cl-value)) -;;;###autoload -(defmacro cl-defsubst (name args &rest body) - "Define NAME as a function. -Like `defun', except the function is automatically declared `inline' and -the arguments are immutable. -ARGLIST allows full Common Lisp conventions, and BODY is implicitly -surrounded by (cl-block NAME ...). -The function's arguments should be treated as immutable. - -\(fn NAME ARGLIST [DOCSTRING] BODY...)" - (declare (debug cl-defun) (indent 2)) - (let* ((argns (cl--arglist-args args)) - (p argns) - ;; (pbody (cons 'progn body)) - ) - (while (and p (eq (cl--expr-contains args (car p)) 1)) (pop p)) - `(progn - ,(if p nil ; give up if defaults refer to earlier args - `(cl-define-compiler-macro ,name - ,(if (memq '&key args) - `(&whole cl-whole &cl-quote ,@args) - (cons '&cl-quote args)) - (cl--defsubst-expand - ',argns '(cl-block ,name ,@body) - ;; We used to pass `simple' as - ;; (not (or unsafe (cl-expr-access-order pbody argns))) - ;; But this is much too simplistic since it - ;; does not pay attention to the argvs (and - ;; cl-expr-access-order itself is also too naive). - nil - ,(and (memq '&key args) 'cl-whole) nil ,@argns))) - (cl-defun ,name ,args ,@body)))) - -(defun cl--defsubst-expand (argns body simple whole _unsafe &rest argvs) - (if (and whole (not (cl--safe-expr-p (cons 'progn argvs)))) whole - (if (cl--simple-exprs-p argvs) (setq simple t)) - (let* ((substs ()) - (lets (delq nil - (cl-mapcar (lambda (argn argv) - (if (or simple (macroexp-const-p argv)) - (progn (push (cons argn argv) substs) - nil) - (list argn argv))) - argns argvs)))) - ;; FIXME: `sublis/subst' will happily substitute the symbol - ;; `argn' in places where it's not used as a reference - ;; to a variable. - ;; FIXME: `sublis/subst' will happily copy `argv' to a different - ;; scope, leading to name capture. - (setq body (cond ((null substs) body) - ((null (cdr substs)) - (cl-subst (cdar substs) (caar substs) body)) - (t (cl--sublis substs body)))) - (if lets `(let ,lets ,body) body)))) - -(defun cl--sublis (alist tree) - "Perform substitutions indicated by ALIST in TREE (non-destructively)." - (let ((x (assq tree alist))) - (cond - (x (cdr x)) - ((consp tree) - (cons (cl--sublis alist (car tree)) (cl--sublis alist (cdr tree)))) - (t tree)))) - ;; Compile-time optimizations for some functions defined in this package. (defun cl--compiler-macro-member (form a list &rest keys) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 401d34b449e..a18e0e57b05 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -21,36 +21,22 @@ ;;; Commentary: -;; The expectation is that structs defined with cl-defstruct do not -;; need cl-lib at run-time, but we'd like to hide the details of the -;; cl-struct metadata behind the cl-struct-define function, so we put -;; it in this pre-loaded file. +;; 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)) - -(defun cl-struct-define (name docstring parent type named slots children-sym - tag print-auto) - (cl-assert (or type (equal '(cl-tag-slot) (car slots)))) - (cl-assert (or type (not named))) - (if (boundp children-sym) - (add-to-list children-sym tag) - (set children-sym (list tag))) - (let* ((parent-class parent)) - (while parent-class - (add-to-list (intern (format "cl-struct-%s-tags" parent-class)) tag) - (setq parent-class (get parent-class 'cl-struct-include)))) - ;; If 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. - (unless named (fset tag :quick-object-witness-check)) - (put name 'cl-struct-slots slots) - (put name 'cl-struct-type (list type named)) - (if parent (put name 'cl-struct-include parent)) - (if print-auto (put name 'cl-struct-print print-auto)) - (if docstring (put name 'structure-documentation docstring))) +(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. @@ -63,6 +49,199 @@ (apply #'error string (append sargs args)) (signal 'cl-assertion-failed `(,form ,@sargs))))) +;; 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) + (vector 'cl-struct-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 (vectorp 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-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)))) + (cl--struct-register-child parent-class tag) + (unless (eq named t) + (eval `(defconst ,tag ',class) t) + ;; 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)) + ;; 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)) + +(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) + (parents nil :type (or cl--class (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. diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 8c1440d02f3..83213285d4e 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -106,10 +106,10 @@ This is to optimize `debugger-make-xrefs'.") "Non-nil if we expect to get back in the debugger soon.") (defvar inhibit-debug-on-entry nil - "Non-nil means that debug-on-entry is disabled.") + "Non-nil means that `debug-on-entry' is disabled.") (defvar debugger-jumping-flag nil - "Non-nil means that debug-on-entry is disabled. + "Non-nil means that `debug-on-entry' is disabled. This variable is used by `debugger-jump', `debugger-step-through', and `debugger-reenable' to temporarily disable debug-on-entry.") @@ -165,7 +165,6 @@ first will be printed into the backtrace buffer." ;; Don't let these magic variables affect the debugger itself. (let ((last-command nil) this-command track-mouse (inhibit-trace t) - (inhibit-debug-on-entry t) unread-command-events unread-post-input-method-events last-input-event last-command-event last-nonmenu-event @@ -763,7 +762,8 @@ A call to this function is inserted by `debug-on-entry' to cause functions to break on entry." (if (or inhibit-debug-on-entry debugger-jumping-flag) nil - (funcall debugger 'debug))) + (let ((inhibit-debug-on-entry t)) + (funcall debugger 'debug)))) ;;;###autoload (defun debug-on-entry (function) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 68bf4f62c34..f0410f87447 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -465,6 +465,8 @@ itself or not." (defvar macroexp--pending-eager-loads nil "Stack of files currently undergoing eager macro-expansion.") +(defvar macroexp--debug-eager nil) + (defun internal-macroexpand-for-load (form full-p) ;; Called from the eager-macroexpansion in readevalloop. (cond @@ -480,8 +482,10 @@ itself or not." (tail (member elem (cdr (member elem bt))))) (if tail (setcdr tail (list '…))) (if (eq (car-safe (car bt)) 'macroexpand-all) (setq bt (cdr bt))) - (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" - (mapconcat #'prin1-to-string (nreverse bt) " => ")) + (if macroexp--debug-eager + (debug 'eager-macroexp-cycle) + (message "Warning: Eager macro-expansion skipped due to cycle:\n %s" + (mapconcat #'prin1-to-string (nreverse bt) " => "))) (push 'skip macroexp--pending-eager-loads) form)) (t diff --git a/lwlib/ChangeLog b/lwlib/ChangeLog index c98d72575a8..e5dfed2342a 100644 --- a/lwlib/ChangeLog +++ b/lwlib/ChangeLog @@ -1,3 +1,7 @@ +2015-03-18 Stefan Monnier + + * xlwmenu.c (pop_up_menu): Remove debugging code. + 2015-02-28 Jan Djärv * xlwmenu.c (remap_menubar): Re-realize menu to force move under diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c index f781b7ee54c..9317dea02b0 100644 --- a/lwlib/xlwmenu.c +++ b/lwlib/xlwmenu.c @@ -1719,7 +1719,7 @@ make_shadow_gcs (XlwMenuWidget mw) 1.2, 0x8000)) #else XQueryColor (dpy, cmap, &topc); - /* don't overflow/wrap! */ + /* Don't overflow/wrap! */ topc.red = MINL (65535, topc.red * 1.2); topc.green = MINL (65535, topc.green * 1.2); topc.blue = MINL (65535, topc.blue * 1.2); @@ -1780,8 +1780,8 @@ make_shadow_gcs (XlwMenuWidget mw) } } - if (!mw->menu.top_shadow_pixmap && - mw->menu.top_shadow_color == mw->core.background_pixel) + if (!mw->menu.top_shadow_pixmap + && mw->menu.top_shadow_color == mw->core.background_pixel) { mw->menu.top_shadow_pixmap = mw->menu.gray_pixmap; if (mw->menu.free_top_shadow_color_p) @@ -1791,8 +1791,8 @@ make_shadow_gcs (XlwMenuWidget mw) } mw->menu.top_shadow_color = mw->menu.foreground; } - if (!mw->menu.bottom_shadow_pixmap && - mw->menu.bottom_shadow_color == mw->core.background_pixel) + if (!mw->menu.bottom_shadow_pixmap + && mw->menu.bottom_shadow_color == mw->core.background_pixel) { mw->menu.bottom_shadow_pixmap = mw->menu.gray_pixmap; if (mw->menu.free_bottom_shadow_color_p) @@ -1856,7 +1856,7 @@ openXftFont (XlwMenuWidget mw) if (fname && strcmp (fname, "none") != 0) { int screen = XScreenNumberOfScreen (mw->core.screen); - int len = strlen (fname), i = len-1; + int len = strlen (fname), i = len - 1; /* Try to convert Gtk-syntax (Sans 9) to Xft syntax Sans-9. */ while (i > 0 && '0' <= fname[i] && fname[i] <= '9') --i; @@ -1880,7 +1880,7 @@ openXftFont (XlwMenuWidget mw) static void XlwMenuInitialize (Widget request, Widget w, ArgList args, Cardinal *num_args) { - /* Get the GCs and the widget size */ + /* Get the GCs and the widget size. */ XlwMenuWidget mw = (XlwMenuWidget) w; Window window = RootWindowOfScreen (DefaultScreenOfDisplay (XtDisplay (mw))); Display* display = XtDisplay (mw); @@ -2014,7 +2014,7 @@ XlwMenuRealize (Widget w, Mask *valueMask, XSetWindowAttributes *attributes) /* Only the toplevel menubar/popup is a widget so it's the only one that receives expose events through Xt. So we repaint all the other panes - when receiving an Expose event. */ + when receiving an Expose event. */ static void XlwMenuRedisplay (Widget w, XEvent *ev, Region region) { @@ -2056,14 +2056,14 @@ XlwMenuDestroy (Widget w) release_drawing_gcs (mw); release_shadow_gcs (mw); - /* this doesn't come from the resource db but is created explicitly - so we must free it ourselves. */ + /* This doesn't come from the resource db but is created explicitly + so we must free it ourselves. */ XFreePixmap (XtDisplay (mw), mw->menu.gray_pixmap); mw->menu.gray_pixmap = (Pixmap) -1; /* Don't free mw->menu.contents because that comes from our creator. The `*_stack' elements are just pointers into `contents' so leave - that alone too. But free the stacks themselves. */ + that alone too. But free the stacks themselves. */ if (mw->menu.old_stack) XtFree ((char *) mw->menu.old_stack); if (mw->menu.new_stack) XtFree ((char *) mw->menu.new_stack); @@ -2093,7 +2093,7 @@ XlwMenuDestroy (Widget w) if (mw->menu.windows [0].pixmap != None) XFreePixmap (XtDisplay (mw), mw->menu.windows [0].pixmap); - /* start from 1 because the one in slot 0 is w->core.window */ + /* Start from 1 because the one in slot 0 is w->core.window. */ for (i = 1; i < mw->menu.windows_length; i++) { if (mw->menu.windows [i].pixmap != None) @@ -2170,7 +2170,7 @@ XlwMenuSetValues (Widget current, Widget request, Widget new, XSetWindowBackground (XtDisplay (oldmw), oldmw->menu.windows [i].window, newmw->core.background_pixel); - /* clear windows and generate expose events */ + /* Clear windows and generate expose events. */ XClearArea (XtDisplay (oldmw), oldmw->menu.windows[i].window, 0, 0, 0, 0, True); } @@ -2244,7 +2244,7 @@ handle_single_motion_event (XlwMenuWidget mw, XMotionEvent *ev) set_new_state (mw, val, level); remap_menubar (mw); - /* Sync with the display. Makes it feel better on X terms. */ + /* Sync with the display. Makes it feel better on X terms. */ XSync (XtDisplay (mw), False); } @@ -2256,7 +2256,7 @@ handle_motion_event (XlwMenuWidget mw, XMotionEvent *ev) int state = ev->state; XMotionEvent oldev = *ev; - /* allow motion events to be generated again */ + /* Allow motion events to be generated again. */ if (ev->is_hint && XQueryPointer (XtDisplay (mw), ev->window, &ev->root, &ev->subwindow, @@ -2293,11 +2293,11 @@ Start (Widget w, XEvent *ev, String *params, Cardinal *num_params) releasing the button should always pop the menu down. */ next_release_must_exit = 1; - /* notes the absolute position of the menubar window */ + /* Notes the absolute position of the menubar window. */ mw->menu.windows [0].x = ev->xmotion.x_root - ev->xmotion.x; mw->menu.windows [0].y = ev->xmotion.y_root - ev->xmotion.y; - /* handles the down like a move, slots are compatible */ + /* Handles the down like a move, slots are compatible. */ ev->xmotion.is_hint = 0; handle_motion_event (mw, &ev->xmotion); } @@ -2327,7 +2327,7 @@ find_first_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) while (lw_separator_p (current->name, &separator, 0) || !current->enabled || (skip_titles && !current->call_data && !current->contents)) if (current->next) - current=current->next; + current = current->next; else return NULL; @@ -2340,9 +2340,9 @@ find_next_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) widget_value *current = item; enum menu_separator separator; - while (current->next && (current=current->next) && - (lw_separator_p (current->name, &separator, 0) || !current->enabled - || (skip_titles && !current->call_data && !current->contents))) + while (current->next && (current = current->next) + && (lw_separator_p (current->name, &separator, 0) || !current->enabled + || (skip_titles && !current->call_data && !current->contents))) ; if (current == item) @@ -2357,7 +2357,7 @@ find_next_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) && !current->contents)) { if (current->next) - current=current->next; + current = current->next; if (current == item) break; @@ -2374,12 +2374,12 @@ find_prev_selectable (XlwMenuWidget mw, widget_value *item, int skip_titles) widget_value *current = item; widget_value *prev = item; - while ((current=find_next_selectable (mw, current, skip_titles)) + while ((current = find_next_selectable (mw, current, skip_titles)) != item) { if (prev == current) break; - prev=current; + prev = current; } return prev; @@ -2560,7 +2560,7 @@ Select (Widget w, XEvent *ev, String *params, Cardinal *num_params) < XtGetMultiClickTime (XtDisplay (w)))) return; - /* pop down everything. */ + /* Pop down everything. */ mw->menu.new_depth = 1; remap_menubar (mw); @@ -2582,7 +2582,7 @@ Select (Widget w, XEvent *ev, String *params, Cardinal *num_params) } - /* Special code to pop-up a menu */ + /* Special code to pop-up a menu. */ static void pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) { @@ -2619,14 +2619,14 @@ pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) mw->menu.popped_up = True; if (XtIsShell (XtParent ((Widget)mw))) { - fprintf(stderr, "Config %d %d\n", x, y); + /* fprintf (stderr, "Config %d %d\n", x, y); */ XtConfigureWidget (XtParent ((Widget)mw), x, y, w, h, XtParent ((Widget)mw)->core.border_width); XtPopup (XtParent ((Widget)mw), XtGrabExclusive); display_menu (mw, 0, False, NULL, NULL, NULL); mw->menu.windows [0].x = x + borderwidth; mw->menu.windows [0].y = y + borderwidth; - mw->menu.top_depth = 1; /* Popup menus don't have a bar so top is 1 */ + mw->menu.top_depth = 1; /* Popup menus don't have a bar so top is 1. */ } else { @@ -2634,7 +2634,7 @@ pop_up_menu (XlwMenuWidget mw, XButtonPressedEvent *event) XtAddGrab ((Widget) mw, True, True); - /* notes the absolute position of the menubar window */ + /* Notes the absolute position of the menubar window. */ mw->menu.windows [0].x = ev->xmotion.x_root - ev->xmotion.x; mw->menu.windows [0].y = ev->xmotion.y_root - ev->xmotion.y; mw->menu.top_depth = 2; diff --git a/src/ChangeLog b/src/ChangeLog index fbf8fb452fc..1b1a9c59033 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,7 @@ +2015-03-18 Stefan Monnier + + * alloc.c (purecopy): Handle hash-tables. + 2015-03-16 Stefan Monnier * minibuf.c (Fread_buffer): Add `predicate' argument. @@ -6,13 +10,11 @@ 2015-03-15 Eli Zaretskii * xdisp.c (handle_invisible_prop): Fix up it->position even when - we are going to load overlays at the beginning of the invisible - text. + we are going to load overlays at the beginning of the invisible text. (setup_for_ellipsis): Reset the ignore_overlay_strings_at_pos_p flag also here. (next_overlay_string): Set the overlay_strings_at_end_processed_p - flag only if the overlays just processed were actually loaded at - EOB. + flag only if the overlays just processed were actually loaded at EOB. 2015-03-14 Daniel Colascione @@ -183,8 +185,8 @@ 2015-02-28 Martin Rudalics - * frame.c (make_initial_frame, Fmake_terminal_frame): Set - can_x_set_window_size and after_make_frame (Bug#19962). + * frame.c (make_initial_frame, Fmake_terminal_frame): + Set can_x_set_window_size and after_make_frame (Bug#19962). 2015-02-28 Eli Zaretskii @@ -454,8 +456,8 @@ * indent.c (Fvertical_motion): Accept an additional argument CUR-COL and use it as the starting screen coordinate. - * window.c (window_scroll_line_based, Fmove_to_window_line): All - callers of vertical-motion changed. + * window.c (window_scroll_line_based, Fmove_to_window_line): + All callers of vertical-motion changed. 2015-02-09 Dima Kogan diff --git a/src/alloc.c b/src/alloc.c index 022782504f1..1f4b1a4694e 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -3423,7 +3423,7 @@ union aligned_Lisp_Misc }; /* Allocation of markers and other objects that share that structure. - Works like allocation of conses. */ + Works like allocation of conses. */ #define MARKER_BLOCK_SIZE \ ((1020 - sizeof (struct marker_block *)) / sizeof (union aligned_Lisp_Misc)) @@ -4744,7 +4744,7 @@ mark_maybe_pointer (void *p) #endif /* Mark Lisp objects referenced from the address range START+OFFSET..END - or END+OFFSET..START. */ + or END+OFFSET..START. */ static void ATTRIBUTE_NO_SANITIZE_ADDRESS mark_memory (void *start, void *end) @@ -5356,7 +5356,6 @@ make_pure_vector (ptrdiff_t len) return new; } - DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, doc: /* Make a copy of object OBJ in pure storage. Recursively copies contents of vectors and cons cells. @@ -5391,28 +5390,26 @@ purecopy (Lisp_Object obj) else if (FLOATP (obj)) obj = make_pure_float (XFLOAT_DATA (obj)); else if (STRINGP (obj)) - obj = make_pure_string (SSDATA (obj), SCHARS (obj), - SBYTES (obj), - STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj)) { - register struct Lisp_Vector *vec; + if (XSTRING (obj)->intervals) + message ("Dropping text-properties when making string pure"); + obj = make_pure_string (SSDATA (obj), SCHARS (obj), + SBYTES (obj), + STRING_MULTIBYTE (obj)); + } + else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj)) + { + struct Lisp_Vector *objp = XVECTOR (obj); + ptrdiff_t nbytes = vector_nbytes (objp); + struct Lisp_Vector *vec = pure_alloc (nbytes, Lisp_Vectorlike); register ptrdiff_t i; - ptrdiff_t size; - - size = ASIZE (obj); + ptrdiff_t size = ASIZE (obj); if (size & PSEUDOVECTOR_FLAG) size &= PSEUDOVECTOR_SIZE_MASK; - vec = XVECTOR (make_pure_vector (size)); + memcpy (vec, objp, nbytes); for (i = 0; i < size; i++) - vec->contents[i] = purecopy (AREF (obj, i)); - if (COMPILEDP (obj)) - { - XSETPVECTYPE (vec, PVEC_COMPILED); - XSETCOMPILED (obj, vec); - } - else - XSETVECTOR (obj, vec); + vec->contents[i] = purecopy (vec->contents[i]); + XSETVECTOR (obj, vec); } else if (SYMBOLP (obj)) { @@ -5422,6 +5419,7 @@ purecopy (Lisp_Object obj) XSYMBOL (obj)->pinned = true; symbol_block_pinned = symbol_block; } + /* Don't hash-cons it. */ return obj; } else @@ -6229,13 +6227,14 @@ mark_discard_killed_buffers (Lisp_Object list) void mark_object (Lisp_Object arg) { - register Lisp_Object obj = arg; + register Lisp_Object obj; void *po; #ifdef GC_CHECK_MARKED_OBJECTS struct mem_node *m; #endif ptrdiff_t cdr_count = 0; + obj = arg; loop: po = XPNTR (obj); @@ -6870,7 +6869,7 @@ sweep_symbols (void) total_free_symbols = num_free; } -NO_INLINE /* For better stack traces */ +NO_INLINE /* For better stack traces. */ static void sweep_misc (void) {