mirror/emacs
1
0
Fork 0
mirror of https://git.savannah.gnu.org/git/emacs.git synced 2024-12-23 10:34:07 +00:00
Code Issues Releases Activity

Add classes as run-time descriptors of cl-structs.

Browse Source 
* lisp/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.
* lisp/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.
* lisp/emacs-lisp/cl-generic.el (cl--generic-struct-specializers)
(cl-generic-generalizers): Rewrite.
* src/alloc.c (purecopy): Handle hash-tables.

* lisp/emacs-lisp/debug.el (debug--implement-debug-on-entry):
Bind inhibit-debug-on-entry here...
(debug): Instead of here.

* lisp/emacs-lisp/macroexp.el (macroexp--debug-eager): New var.
(internal-macroexpand-for-load): Use it.

* lwlib/xlwmenu.c (pop_up_menu): Remove debugging code.
This commit is contained in:
Stefan Monnier 2015-03-18 10:31:07 -04:00
parent fd93edbb1c
commit 872481d9e2
10 changed files with 468 additions and 226 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
lisp/ChangeLog
View File

@ -1,3 +1,31 @@
2015-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
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 <dima@secretsauce.net>
Have gud-display-line not display source buffer in gud window.
@ -6,13 +34,13 @@
2015-03-17 Tassilo Horn <tsdh@gnu.org>
* 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 <simenheg@gmail.com>
* 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 <dancol@dancol.org>
@ -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.

64
lisp/emacs-lisp/cl-generic.el
View File

@ -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".

198
lisp/emacs-lisp/cl-macs.el
View File

@ -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)

231
lisp/emacs-lisp/cl-preloaded.el
View File

@ -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.

8
lisp/emacs-lisp/debug.el
View File

@ -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)

8
lisp/emacs-lisp/macroexp.el
View File

@ -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

4
lwlib/ChangeLog
View File

@ -1,3 +1,7 @@
2015-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
* xlwmenu.c (pop_up_menu): Remove debugging code.
2015-02-28 Jan Djärv <jan.h.d@swipnet.se>
* xlwmenu.c (remap_menubar): Re-realize menu to force move under

58
lwlib/xlwmenu.c
View File

@ -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;

18
src/ChangeLog
View File

@ -1,3 +1,7 @@
2015-03-18 Stefan Monnier <monnier@iro.umontreal.ca>
* alloc.c (purecopy): Handle hash-tables.
2015-03-16 Stefan Monnier <monnier@iro.umontreal.ca>
* minibuf.c (Fread_buffer): Add `predicate' argument.
@ -6,13 +10,11 @@
2015-03-15 Eli Zaretskii <eliz@gnu.org>
* 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 <dancol@dancol.org>
@ -183,8 +185,8 @@
2015-02-28 Martin Rudalics <rudalics@gmx.at>
* 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 <eliz@gnu.org>
@ -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 <dima@secretsauce.net>

43
src/alloc.c
View File

@ -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)
{