Commit 872481d9 authored by Stefan Monnier's avatar Stefan Monnier

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.
parent fd93edbb
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.
......
......@@ -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".
......
This diff is collapsed.
This diff is collapsed.
......@@ -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)
......
......@@ -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
......
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
......
......@@ -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;
......
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>
......
......@@ -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)
{
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment