[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master 872481d: Add classes as run-time descriptors of cl-
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master 872481d: Add classes as run-time descriptors of cl-structs. |
|
Date: |
Wed, 18 Mar 2015 14:31:42 +0000 |
branch: master
commit 872481d9e26d7569145c897fd319b1104e028878
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
Add classes as run-time descriptors of cl-structs.
* 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.
---
lisp/ChangeLog | 62 +++++++----
lisp/emacs-lisp/cl-generic.el | 64 ++++++-----
lisp/emacs-lisp/cl-macs.el | 198 +++++++++++++++++++---------------
lisp/emacs-lisp/cl-preloaded.el | 231 ++++++++++++++++++++++++++++++++++-----
lisp/emacs-lisp/debug.el | 8 +-
lisp/emacs-lisp/macroexp.el | 8 +-
lwlib/ChangeLog | 4 +
lwlib/xlwmenu.c | 58 +++++-----
src/ChangeLog | 18 ++--
src/alloc.c | 43 ++++----
10 files changed, 468 insertions(+), 226 deletions(-)
diff --git a/lisp/ChangeLog b/lisp/ChangeLog
index d61a0a6..2db0f9a 100644
--- a/lisp/ChangeLog
+++ b/lisp/ChangeLog
@@ -1,3 +1,31 @@
+2015-03-18 Stefan Monnier <address@hidden>
+
+ 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 <address@hidden>
Have gud-display-line not display source buffer in gud window.
@@ -6,13 +34,13 @@
2015-03-17 Tassilo Horn <address@hidden>
- * 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 <address@hidden>
- * 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 <address@hidden>
@@ -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 41c760e..c9ca92d 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 56fbcf0..d386678 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 401d34b..a18e0e5 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 8c1440d..8321328 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 68bf4f6..f0410f8 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 c98d725..e5dfed2 100644
--- a/lwlib/ChangeLog
+++ b/lwlib/ChangeLog
@@ -1,3 +1,7 @@
+2015-03-18 Stefan Monnier <address@hidden>
+
+ * xlwmenu.c (pop_up_menu): Remove debugging code.
+
2015-02-28 Jan Djärv <address@hidden>
* xlwmenu.c (remap_menubar): Re-realize menu to force move under
diff --git a/lwlib/xlwmenu.c b/lwlib/xlwmenu.c
index f781b7e..9317dea 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 fbf8fb4..1b1a9c5 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,7 @@
+2015-03-18 Stefan Monnier <address@hidden>
+
+ * alloc.c (purecopy): Handle hash-tables.
+
2015-03-16 Stefan Monnier <address@hidden>
* minibuf.c (Fread_buffer): Add `predicate' argument.
@@ -6,13 +10,11 @@
2015-03-15 Eli Zaretskii <address@hidden>
* 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 <address@hidden>
@@ -183,8 +185,8 @@
2015-02-28 Martin Rudalics <address@hidden>
- * 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 <address@hidden>
@@ -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 <address@hidden>
diff --git a/src/alloc.c b/src/alloc.c
index 0227825..1f4b1a4 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)
{
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master 872481d: Add classes as run-time descriptors of cl-structs.,
Stefan Monnier <=