[PATCH] Annotate cons cells with buffer positions, lread.c
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
PATCH 21.5
This is part of what’s necessary for merging GNU’s bytecomp changes. They use
a read-symbol-position, which works most of the time, but has obvious issues
in that symbols are far from unique, so getting a symbol’s position doesn’t
necessarily tell you anything useful about the associated byte compile error.
As Ben suggested in his comment, conses are unique, and I can get ~okay
results with the below, but it’s not finished, and for good results, I need to
be quite invasive in the byte compile and optimization code, since all the
code that conses to make its changes needs to be examined and the position
transferred over. I did the below diff with -b, ignoring whitespace changes,
the actual diff is much more invasive.
Opinions, anyone?
diff -r 83e5c3cd6be6 lisp/byte-optimize.el
--- a/lisp/byte-optimize.el Sat Jan 10 19:43:28 2015 +0900
+++ b/lisp/byte-optimize.el Sat Mar 14 01:58:15 2015 +0000
＠＠ -398,6 +398,7 ＠＠
;;
(let ((fn (car-safe form))
tmp)
+ (byte-compile-keep-cons-position form
(cond ((not (consp form))
(if (not (and for-effect
(or byte-compile-delete-errors
＠＠ -410,17 +411,18 ＠＠
(prin1-to-string form)))
;; map (quote nil) to nil to simplify optimizer logic.
;; map quoted constants to nil if for-effect (just because).
- (and (nth 1 form)
- (not for-effect)
- form))
+ (and (nth 1 form) (not for-effect) form))
((eq fn 'function)
(when (cddr form)
(byte-compile-warn "malformed function form: %S" form))
(cond
(for-effect nil)
((and (eq (car-safe (cadr form)) 'lambda)
- (not (eq (cadr form) (setq tmp (byte-optimize-lambda
- (cadr form))))))
+ (not (eq (cadr form)
+ (setq tmp
+ (byte-compile-keep-cons-position
+ (cadr form)
+ (byte-optimize-lambda (cadr form)))))))
(list fn tmp))
(t form)))
((and (eq 'lambda (car-safe fn))
＠＠ -476,9 +478,9 ＠＠
((memq fn '(save-excursion save-restriction save-current-buffer))
;; those subrs which have an implicit progn; it's not quite good
- ;; enough to treat these like normal function calls.
- ;; This can turn (save-excursion ...) into (save-excursion) which
- ;; will be optimized away in the lap-optimize pass.
+ ;; enough to treat these like normal function calls. This can
+ ;; turn (save-excursion ...) into (save-excursion) which will be
+ ;; optimized away in the lap-optimize pass.
(cons fn (byte-optimize-body (cdr form) for-effect)))
((eq fn 'with-output-to-temp-buffer)
＠＠ -578,12 +580,12 ＠＠
(setq tmp (byte-optimize-side-effect-free-p form))
(or byte-compile-delete-errors
(eq tmp 'error-free)
- ;; XEmacs; GNU handles the expansion of (pop foo) specially
- ;; here. We changed the macro to expand to (prog1 (car-safe
- ;; PLACE) (setq PLACE (cdr PLACE))) , which has the same
- ;; effect. (This only matters when
- ;; byte-compile-delete-errors is nil, which is usually true
- ;; for GNU and usually false for XEmacs.)
+ ;; XEmacs; GNU handles the expansion of (pop foo)
+ ;; specially here. We changed the macro to expand to
+ ;; (prog1 (car-safe PLACE) (setq PLACE (cdr PLACE))) ,
+ ;; which has the same effect. (This only matters when
+ ;; byte-compile-delete-errors is nil, which is usually
+ ;; true for GNU and usually false for XEmacs.)
(progn
(byte-compile-warn "%s called for effect"
(prin1-to-string form))
＠＠ -597,14 +599,15 ＠＠
;; Otherwise, no args can be considered to be for-effect,
;; even if the called function is for-effect, because we
;; don't know anything about that function.
- (cons fn (mapcar 'byte-optimize-form (cdr form)))))))
+ (cons fn (mapcar 'byte-optimize-form (cdr form))))))))
(defun byte-optimize-form (form &optional for-effect)
"The source-level pass of the optimizer."
;;
;; First, optimize all sub-forms of this one.
- (setq form (byte-optimize-form-code-walker form for-effect))
+ (setq form (byte-compile-keep-cons-position form
+ (byte-optimize-form-code-walker form for-effect)))
;;
;; After optimizing all subforms, optimize this form until it doesn't
;; optimize any further. This means that some forms will be passed through
＠＠ -618,11 +621,13 ＠＠
;; we don't have any of these yet, but we might.
(setq opt (get (car form) 'byte-for-effect-optimizer)))
(setq opt (get (car form) 'byte-optimizer)))
- (not (eq form (setq new (funcall opt form)))))
+ (not (eq form (setq new (byte-compile-keep-cons-position form
+ (funcall opt form))))))
(progn
;; (if (equal form new) (error "bogus optimizer -- %s" opt))
(byte-compile-log " %s\t==>\t%s" form new)
- (setq new (byte-optimize-form new for-effect))
+ (setq new (byte-compile-keep-cons-position new
+ (byte-optimize-form new for-effect)))
new)
form)))
diff -r 83e5c3cd6be6 lisp/bytecomp.el
--- a/lisp/bytecomp.el Sat Jan 10 19:43:28 2015 +0900
+++ b/lisp/bytecomp.el Sat Mar 14 01:58:15 2015 +0000
＠＠ -559,8 +559,8 ＠＠
(placeholders (cadr (pop form)))
(cannot-inline-alist (cannot-inline-alist
placeholders lambdas))
- (lambdas (sublis cannot-inline-alist
- lambdas :test #'eq)))
+ (lambdas (byte-compile-sublis-with-text-position cannot-inline-alist
+ lambdas)))
;; Used specially, note the bindings in our callers.
(setq byte-compile-function-environment
(pairlis
＠＠ -602,7 +602,7 ＠＠
compiled :test #'eq
:descend-structures t))
placeholders compiled)
- (sublis (pairlis
+ (byte-compile-sublis-with-text-position (pairlis
placeholders compiled
(pairlis
(mapcar*
＠＠ -613,7 +613,7 ＠＠
'byte-compile-data-placeholder)))
(nconc list list))))
compiled))
- form :test #'eq))))
+ form ))))
(put wrapper 'byte-compile
#'(lambda (form)
(let ((byte-compile-function-environment
＠＠ -1204,6 +1204,48 ＠＠
(defvar byte-compile-current-form nil)
(defvar byte-compile-current-file nil)
(defvar byte-compile-dest-file nil)
+(defvar byte-compile-text-positions nil)
+
+(put 'byte-compile-keep-text-position 'lisp-indent-function 1)
+(defmacro byte-compile-keep-text-position (old &rest body)
+ "Ensure the result of BODY has the same position annotation as OLD."
+ (let ((gensym (gensym "position"))
+ (whither (gensym "whither")))
+ `(let ((,gensym (if byte-compile-text-positions
+ (gethash ,old byte-compile-text-positions nil)
+ (prog1 nil ,old)))
+ (,whither (progn ,＠body)))
+ (prog1
+ ,whither
+ (and ,gensym
+ (puthash ,whither ,gensym byte-compile-text-positions))))))
+
+
+(defun byte-compile-sublis-with-text-position (alist tree)
+ (let ((assq (assq tree alist))
+ (if assq
+ (cdr assq)
+ (if (atom tree)
+ tree
+ (let ((car (byte-compile-sublis-with-text-position alist (car tree)))
+ (cdr (byte-compile-sublis-with-text-position alist (cdr tree))))
+ (if (and (eq car (car tree)) (eq cdr (cdr tree)))
+ tree
+ (byte-compile-keep-text-position tree
+ (cons (byte-compile-keep-text-position (car tree) car)
+ (byte-compile-keep-text-position (car tree) cdr))))))))))
+
+(defun byte-compile-mapcar-with-positions (function list)
+ (mapcon #'(lambda (tail)
+ (byte-compile-keep-text-position tail
+ (list (funcall function (car tail))))) list))
+
+(defmacro byte-compile-keep-text-position1 (old &rest body)
+ (list* 'progn old body))
+
+(defun byte-compile-object-position (object)
+ (and byte-compile-text-positions
+ (gethash object byte-compile-text-positions)))
(defmacro byte-compile-log (format-string &rest args)
`(when (and byte-optimize (memq byte-optimize-log '(t source)))
＠＠ -1267,67 +1309,43 ＠＠
(defvar byte-compile-inbuffer)
(defvar byte-compile-outbuffer)
-
-(defun byte-compile-warn (format &rest args)
+(defvar byte-compile-form-stack nil)
+
+(defun byte-compile-warn (&rest args)
+ (let* ((format (car args))
+ (memq (memq :form args))
+ (byte-compile-form-stack (if memq
+ (prog1
+ (cons (cadr memq)
+ byte-compile-form-stack)
+ (loop for tail on args
+ when (eq (cdr tail) memq)
+ do (setf (cdr tail)
+ (cdddr tail))))
+ byte-compile-form-stack))
+ (args (cdr args)))
(setq format (apply 'format format args))
(if byte-compile-error-on-warn
(error "%s" format) ; byte-compile-file catches and logs it
- (byte-compile-log-1 (concat "** " format) t)
-
- ;; This was a first attempt to add line numbers to the
- ;; byte-compilation output. Unfortunately, it doesn't work
- ;; perfectly: it reports the line number at the end of the form
- ;; (which may be an entire function), rather than the line number
- ;; of the actual problem. Doing this right is hard because we
- ;; currently use the built-in Lisp parser to parse the entire form
- ;; at once. What we basically need is a whole separate parser
- ;; that annotates its output with line numbers. For example, we
- ;; might modify the parser in lread.c so that, with the right
- ;; option set, it replaces every Lisp object contained in the
- ;; structure it returns with a cons of that object and the line
- ;; number it was found on (determined by counting newlines,
- ;; starting from some arbitrary point). You then have two
- ;; options: (a) Modify the byte compiler so that everything that
- ;; compiles a form deals with the new annotated form rather than
- ;; the old one, or (b) The byte compiler saves this structure
- ;; while converting it into a normal structure that's given to the
- ;; various form handlers, which need no (or less) modification.
- ;; In the former case, finding the line number is trivial because
- ;; it's in the form. In the latter case, finding the line number
- ;; depends on having a unique Lisp object that can be looked up in
- ;; the annotated structure -- i.e. a list, vector, or string.
- ;; You'd have to look at the various places where errors are spit
- ;; out (not very many, really), and make sure that such a unique
- ;; object is available. Then you do a depth-first search through
- ;; the annotated structure to find the object.
- ;;
- ;; An alternative way of doing (b) that's probably much more
- ;; efficient (and easier to implement) is simply to have the
- ;; parser in lread.c annotate every unique object using a separate
- ;; hash table. This also eliminates the need for a search to find
- ;; the line number. In order to be fine-grained enough to get at
- ;; every symbol in a form -- e.g. if we want to pinpoint a
- ;; particular undefined variable in a function call -- we need to
- ;; annotate every cons, not just each list. We still have
- ;; (probably unimportant) problems with vectors, since all we have
- ;; is the start of the vector. If we cared about this, we could
- ;; store in the hash table a list of the line numbers for each
- ;; item in the vector, not just its start.
- ;;
- ;; --ben
-
-; (byte-compile-log-1 (concat "** line: "
-; (save-excursion
-; (set-buffer byte-compile-inbuffer)
-; (int-to-string (line-number)))
-; " "
-; format) t)
-;;; RMS says:
-;;; It is useless to flash warnings too fast to be read.
-;;; Besides, they will all be shown at the end.
-;;; and comments out the next two lines.
+ (let ((byte-compile-object-position
+ (some #'byte-compile-object-position byte-compile-form-stack)))
+ (byte-compile-log-1 (concat (if byte-compile-object-position
+ (or (buffer-file-name
+ (marker-buffer
+ byte-compile-object-position))
+ byte-compile-current-file)
+ "** ")
+ (if byte-compile-object-position
+ (format ":%d "
+ (marker-position
+ byte-compile-object-position)))
+ format)))
+ ;;; RMS says:
+ ;;; It is useless to flash warnings too fast to be read.
+ ;;; Besides, they will all be shown at the end.
+ ;;; and comments out the next two lines.
(or noninteractive ; already written on stdout.
- (message "Warning: %s" format))))
+ (message "Warning: %s" format)))))
;;; This function should be used to report errors that have halted
;;; compilation of the current file.
＠＠ -1986,8 +2004,13 ＠＠
(let* ((byte-compile-current-file (buffer-file-name))
(load-file-name (buffer-file-name))
(byte-compile-last-warned-form 'nothing)
+; (byte-compile-text-positions nil)
(value (eval (displaying-byte-compile-warnings
- (byte-compile-sexp (read (current-buffer))
+ (byte-compile-sexp
+ (multiple-value-bind (object table)
+ (read (current-buffer) :with-cons-positions t)
+ (setq byte-compile-text-positions table)
+ object)
"toplevel forms")))))
(cond (arg
(message "Compiling from buffer... done.")
＠＠ -2015,7 +2038,8 ＠＠
;; byte-compile-warning-types
;; byte-compile-warnings))
(byte-compile-force-escape-quoted byte-compile-force-escape-quoted)
- (byte-compile-using-dynamic nil))
+ (byte-compile-using-dynamic nil)
+ (byte-compile-text-positions nil))
(byte-compile-close-variables
(save-excursion
(setq byte-compile-outbuffer
＠＠ -2053,7 +2077,11 ＠＠
(looking-at ";"))
(forward-line 1))
(not (eobp)))
- (byte-compile-file-form (read byte-compile-inbuffer))
+ (byte-compile-file-form
+ (multiple-value-bind (object table)
+ (read byte-compile-inbuffer :with-cons-positions t)
+ (setq byte-compile-text-positions table)
+ object))
(or (eq byte-compile-inbuffer (current-buffer))
(error 'invalid-state
"byte compiling didn't save-excursion appropriately"
＠＠ -2362,10 +2390,14 ＠＠
(byte-compile-keep-pending form))
((and (symbolp (car form))
(setq handler (get (car form) 'byte-hunk-handler)))
- (cond ((setq form (funcall handler form))
+ (cond ((setq form
+ (byte-compile-keep-text-position form
+ (funcall handler form)))
(byte-compile-flush-pending)
(byte-compile-output-file-form form))))
- ((eq form (setq form (macroexpand form byte-compile-macro-environment)))
+ ((eq form (setq form
+ (byte-compile-keep-text-position form
+ (macroexpand form byte-compile-macro-environment))))
(byte-compile-keep-pending form))
(t
(byte-compile-file-form form)))))
＠＠ -3062,7 +3094,12 ＠＠
;; (Use byte-compile-form-do-effect to reset the for-effect flag too.)
;;
(defun byte-compile-form (form &optional for-effect)
- (setq form (macroexpand form byte-compile-macro-environment))
+ (let ((byte-compile-form-stack (if (consp form)
+ (cons form byte-compile-form-stack)
+ byte-compile-form-stack)))
+ (setq form
+ (byte-compile-keep-text-position form
+ (macroexpand form byte-compile-macro-environment)))
(cond ((not (consp form))
(cond ((or (not (symbolp form))
(byte-compile-constant-symbol-p form))
＠＠ -3083,12 +3120,14 ＠＠
((and (eq (car-safe (car form)) 'lambda)
;; if the form comes out the same way it went in, that's
;; because it was malformed, and we couldn't unfold it.
- (not (eq form (setq form (byte-compile-unfold-lambda form)))))
+ (not (eq form (setq form
+ (byte-compile-keep-text-position form
+ (byte-compile-unfold-lambda form))))))
(byte-compile-form form for-effect)
(setq for-effect nil))
((byte-compile-normal-call form)))
(when for-effect
- (byte-compile-discard)))
+ (byte-compile-discard))))
;; Generate the list of functions with keyword arguments like so:
;;
diff -r 83e5c3cd6be6 src/doc.c
--- a/src/doc.c Sat Jan 10 19:43:28 2015 +0900
+++ b/src/doc.c Sat Mar 14 01:58:15 2015 +0000
＠＠ -403,7 +403,7 ＠＠
if (!STRINGP (string))
invalid_state ("loading bytecode failed to return string", string);
- return Fread (string);
+ return Fread (1, &string);
}
static Lisp_Object
diff -r 83e5c3cd6be6 src/lisp.h
--- a/src/lisp.h Sat Jan 10 19:43:28 2015 +0900
+++ b/src/lisp.h Sat Mar 14 01:58:15 2015 +0000
＠＠ -5498,7 +5498,7 ＠＠
void where_is_to_char (Lisp_Object, Eistring *);
/* Defined in lread.c */
-EXFUN (Fread, 1);
+EXFUN (Fread, MANY);
void ebolify_bytecode_constants (Lisp_Object);
void close_load_descs (void);
diff -r 83e5c3cd6be6 src/lread.c
--- a/src/lread.c Sat Jan 10 19:43:28 2015 +0900
+++ b/src/lread.c Sat Mar 14 01:58:15 2015 +0000
＠＠ -60,6 +60,7 ＠＠
Lisp_Object Vvalues, Vstandard_input, Vafter_load_alist;
Lisp_Object Vload_suppress_alist;
Lisp_Object Qload, Qload_internal, Qfset;
+Lisp_Object Q_with_cons_positions;
/* Hash-table that maps directory names to hashes of their contents. */
static Lisp_Object Vlocate_file_hash_table;
＠＠ -126,6 +127,10 ＠＠
It must be set to nil before all top-level calls to read0. */
Lisp_Object Vread_objects;
+/* Weak eq-keyed hash table mapping each cons that has been read to its
+ buffer position. Or nil, to say no such mapping should be done. */
+Lisp_Object Vread_cons_positions;
+
/* Nonzero means load should forcibly load all dynamic doc strings. */
/* Note that this always happens (with some special behavior) when
purify_flag is set. */
＠＠ -467,7 +472,7 ＠＠
Lisp_Object ivan;
NGCPRO1 (juan);
- ivan = Fread (juan);
+ ivan = Fread (1, &juan);
if (!CONSP (ivan))
invalid_byte_code ("invalid lazy-loaded byte code", ivan);
XCOMPILED_FUNCTION (john)->instructions = XCAR (ivan);
＠＠ -1589,7 +1594,7 ＠＠
return unbind_to (speccount);
}
-DEFUN ("read", Fread, 0, 1, 0, /*
+DEFUN ("read", Fread, 0, MANY, 0, /*
Read one Lisp expression as text from STREAM, return as Lisp object.
If STREAM is nil, use the value of `standard-input' (which see).
STREAM or the value of `standard-input' may be:
＠＠ -1599,9 +1604,21 ＠＠
call it with a char as argument to push a char back)
a string (takes text from string, starting at the beginning)
t (read text line using minibuffer and use it).
+
+Optional keyword argument WITH-CONS-POSITIONS, if non-nil, says to
+return a second value, a hash table mapping conses within the object
+read to their beginning positions, as buffer markers. This is only
+available if STREAM is a buffer.
+
+arguments: (&optional STREAM &key WITH-CONS-POSITIONS)
*/
- (stream))
+ (int nargs, Lisp_Object *args))
{
+ Lisp_Object stream = nargs > 0 ? args[0] : Qnil;
+
+ PARSE_KEYWORDS_8 (intern ("read"), nargs, args, 1, (with_cons_positions),
+ NULL, 1, 0);
+
if (NILP (stream))
stream = Vstandard_input;
if (EQ (stream, Qt))
＠＠ -1619,6 +1636,31 ＠＠
if (STRINGP (stream))
return Fcar (Fread_from_string (stream, Qnil, Qnil));
+ if (!NILP (with_cons_positions))
+ {
+ int speccount = specpdl_depth ();
+ Lisp_Object positions = Qnil, result = Qnil;
+
+ if (!BUFFERP (stream))
+ {
+ signal_error (Qunimplemented,
+ "annotation only available with buffer STREAMs",
+ Qunbound);
+ }
+
+ internal_bind_lisp_object (&Vread_cons_positions,
+ make_lisp_hash_table (200,
+ HASH_TABLE_KEY_WEAK,
+ Qeq));
+
+ result = read0 (stream);
+ positions = Vread_cons_positions;
+ unbind_to (speccount);
+
+ return values2 (result, positions);
+ }
+
+
return read0 (stream);
}
＠＠ -1656,7 +1698,6 ＠＠
UNGCPRO;
return tem;
}
-
/* Use this for recursive reads, in contexts where internal tokens
＠＠ -2978,8 +3019,8 ＠＠
{
Lisp_Object head;
Lisp_Object tail;
- int length;
- int allow_dotted_lists;
+ Elemcount length;
+ Boolint allow_dotted_lists, save_positions;
Ichar terminator;
};
＠＠ -2988,6 +3029,16 ＠＠
{
struct read_list_state *s = (struct read_list_state *) state;
Lisp_Object elt;
+ Lisp_Object cons_position = Qnil;
+ struct gcpro gcpro1;
+
+ if (!NILP (Vread_cons_positions))
+ {
+ cons_position = Fcopy_marker (XBUFFER (readcharfun)->point_marker,
+ Qnil);
+ }
+
+ GCPRO1 (cons_position);
elt = read1 (readcharfun);
＠＠ -3004,6 +3055,10 ＠＠
if (ch == s->terminator) /* deal with #+, #- reader macros */
{
unreadchar (readcharfun, s->terminator);
+ if (!NILP (cons_position))
+ {
+ Fset_marker (cons_position, Qnil, Qnil);
+ }
goto done;
}
else if (ch == ']')
＠＠ -3030,6 +3085,10 ＠＠
if (ch == s->terminator)
{
unreadchar (readcharfun, s->terminator);
+ if (!NILP (cons_position))
+ {
+ Fset_marker (cons_position, Qnil, Qnil);
+ }
goto done;
}
}
＠＠ -3043,8 +3102,15 ＠＠
else
s->head = elt;
s->tail = elt;
+
+ if (!NILP (cons_position))
+ {
+ Fputhash (elt, cons_position, Vread_cons_positions);
+ }
+
done:
s->length++;
+ UNGCPRO;
return s;
}
＠＠ -3313,6 +3379,8 ＠＠
DEFSYMBOL (Qreadable);
DEFSYMBOL (Qwritable);
DEFSYMBOL (Qexecutable);
+
+ DEFKEYWORD (Q_with_cons_positions);
}
void
＠＠ -3508,6 +3576,9 ＠＠
Vread_objects = Qnil;
staticpro (&Vread_objects);
+ Vread_cons_positions = Qnil;
+ staticpro (&Vread_cons_positions);
+
Vlocate_file_hash_table = make_lisp_hash_table (200,
HASH_TABLE_NON_WEAK,
#ifdef DEFAULT_FILE_SYSTEM_IGNORE_CASE
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[PATCH] Improve #'read-quoted-char, #'quoted-insert
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
PATCH 21.5
This change is what prompted the few smaller commits I just did. I had thought
adding function-key-map support to C-q would be a small thing, but I didn’t
realise at that point the issues with it and with the help code, so it took
that bit longer.
2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
* simple.el (quoted-insert):
Update the docstring here, syncing GNU's, especially mentioning
read-quoted-char-radix.
* cmdloop.el:
* cmdloop.el (read-quoted-char-radix): Move this up here, outside
the functions.
* cmdloop.el (read-function-key-map): New label, reading and
replacing characters from function-key-map if appropriate.
* cmdloop.el (read-quoted-char): Multiple changes:
-- Take advantage of help-event-list, but be careful not to have
any keystrokes with character equivalents in it, so the user can
type C-q C-h and have the expected result.
-- Use function-key-map, as does #'read-char and
#'read-exclusive-char, helpful for character composition under
X11.
-- Pop up the help window ourselves if, e.g. F1 arrives on a TTY
via function-key-map, event-stream won't have done it.
-- Error if no keystroke that can be converted into a character is
specified, don't just insert ?\x00 as we used to and as does GNU
-- Use #'digit-char-p instead of reimplementing it.
-- Fix a bug of mine where I wasn't consistent about treating
character codes as Unicode.
diff -r 6ec4964c1687 lisp/simple.el
--- a/lisp/simple.el Thu Mar 12 23:31:42 2015 +0000
+++ b/lisp/simple.el Sat Mar 14 00:00:39 2015 +0000
＠＠ -275,14 +275,21 ＠＠
(defun quoted-insert (arg)
"Read next input character and insert it.
This is useful for inserting control characters.
-You may also type up to 3 octal digits, to insert a character with that code.
+With argument, insert ARG copies of the character.
+
+If the first character you type after this command is an octal digit,
+you should type a sequence of octal digits which specify a Unicode character.
+Any nondigit terminates the sequence. If the terminator is a RET,
+it is discarded; any other terminator is used itself as input.
+The variable `read-quoted-char-radix' specifies the radix for this feature;
+set it to 10 or 16 to use decimal or hex instead of octal.
In overwrite mode, this function inserts the character anyway, and
does not handle octal digits specially. This means that if you use
overwrite as your normal editing mode, you can use this function to
insert characters when necessary.
-In binary overwrite mode, this function does overwrite, and octal
+In binary overwrite mode, this function does overwrite, and octal
digits are interpreted as a character code. This is supposed to make
this function useful in editing binary files."
(interactive "*p")
diff -r 6ec4964c1687 lisp/cmdloop.el
--- a/lisp/cmdloop.el Thu Mar 12 23:31:42 2015 +0000
+++ b/lisp/cmdloop.el Sat Mar 14 00:00:39 2015 +0000
＠＠ -520,8 +524,31 ＠＠
(y-or-n-p-minibuf prompt)))
+(defcustom read-quoted-char-radix 8
+ "Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
+See `digit-char-p' and its RADIX argument for possible values."
+:type '(choice (const 8) (const 10) (const 16))
+:group 'editing-basics)
+
(labels
- ((read-char-1 (errorp prompt inherit-input-method seconds)
+ ((read-function-key-map (events prompt)
+ "Read keystrokes scanning `function-key-map'. Return an event vector."
+ (let (binding)
+ (while (keymapp
+ (setq binding
+ (lookup-key function-key-map
+ (setq events
+ (vconcat events
+ (list (next-key-event
+ nil prompt))))))))
+ (when binding
+ ;; Found something in function-key-map. If it's a function
+ ;; (e.g. synthesize-keysym), call it.
+ (if (functionp binding)
+ (setq binding (funcall binding nil)))
+ (setq events (map 'vector #'character-to-event binding)))
+ events))
+ (read-char-1 (errorp prompt inherit-input-method seconds)
"Return a character from command input or the current macro.
Look up said input in `function-key-map' as appropriate.
＠＠ -540,29 +567,15 ＠＠
(add-timeout seconds #'(lambda (ignore)
(return-from read-char-1 nil))
nil)))
- (events []) binding character)
+ (events []) character)
(unwind-protect
(while t
- ;; Read keystrokes scanning `function-key-map'.
- (while (keymapp
- (setq binding
- (lookup-key
- function-key-map
- (setq events
- (vconcat events (list
- (next-key-event
- nil prompt))))))))
- (when binding
- ;; Found something in function-key-map. If it's a function
- ;; (e.g. synthesize-keysym), call it.
- (if (functionp binding)
- (setq binding (funcall binding nil)))
- (setq events (map 'vector #'character-to-event binding)))
- ;; Put the remaining keystrokes back on the input queue.
- (setq unread-command-events
- (nconc (reduce #'cons events :start 1 :from-end t
-:initial-value nil)
- unread-command-events))
+ (setq events (read-function-key-map events prompt)
+ ;; Put the remaining keystrokes back on the input queue.
+ unread-command-events (reduce #'cons events
+:start 1 :from-end t
+:initial-value
+ unread-command-events))
(unless inhibit-quit
(and (event-matches-key-specifier-p (aref events 0)
(quit-char))
＠＠ -633,93 +645,95 ＠＠
If SECONDS is non-nil, only wait that number of seconds for input. If no
input is received in that time, return nil."
- (read-char-1 nil prompt inherit-input-method seconds)))
+ (read-char-1 nil prompt inherit-input-method seconds))
-;;;; Input and display facilities.
+ (defun read-quoted-char (&optional prompt)
+ "Like `read-char', but do not allow quitting.
-;; BEGIN SYNCHED WITH FSF 21.2.
-
-(defcustom read-quoted-char-radix 8
- "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
-Legitimate radix values are 8, 10 and 16."
-:type '(choice (const 8) (const 10) (const 16))
-:group 'editing-basics)
-
-(defun read-quoted-char (&optional prompt)
- ;; XEmacs change; description of the character code input
- "Like `read-char', but do not allow quitting.
-
-Also, if the first character read is a digit of base (the value of)
-`read-quoted-char-radix', we read as many of such digits as are
-typed and return a character with the corresponding Unicode code
-point. Any input that is not a digit (in the base used) terminates
-the sequence. If the terminator is RET, it is discarded; any other
-terminator is used itself as input.
+Also, if the first character read is a digit of base `read-quoted-char-radix',
+we read as many of such digits as are typed and return a character with the
+corresponding Unicode code point. Any input that is not a digit (in the base
+used) terminates the sequence. If the terminator is RET, it is discarded; any
+other terminator is used itself as input.
The optional argument PROMPT specifies a string to use to prompt the user.
The variable `read-quoted-char-radix' controls which radix to use
-for numeric input."
- (let (;(message-log-max nil)
- done (first t) (code 0) char event
- (prompt (and prompt (gettext prompt)))
- )
- (while (not done)
- (let ((inhibit-quit first)
- ;; Don't let C-h get the help message--only help
- ;; function keys.
- ;; XEmacs: we don't support the help function keys as of
- ;; 2006-04-16. GNU have a Vhelp_event_list in addition
- ;; to help-char in src/keyboard.c, and it's only useful
- ;; to set help-form while help-char is nil when that
- ;; functionality is available.
- (help-char nil)
- (help-form (format
- "Type the special character you want to use,
-or the character code, base %d (the value of `read-quoted-char-radix')
-RET terminates the character code and is discarded;
-any other non-digit terminates the character code and is then used as input."
- read-quoted-char-radix)))
- (and prompt (display-message 'prompt (format "%s-" prompt)))
- (setq event (next-command-event)
- ;; If event-to-character fails, this is fine, we handle that
- ;; with the (null char) cond branch below.
- char (event-to-character event))
- (if inhibit-quit (setq quit-flag nil)))
- ;; Translate TAB key into control-I ASCII character, and so on.
- (and char
- (let ((translated (lookup-key function-key-map (vector char))))
- (if (arrayp translated)
- (setq char (aref translated 0)))))
- (cond ((null char))
- ((not (characterp char))
- ;; XEmacs change; event instead of char.
- (setq unread-command-events (list event)
- done t))
-; ((/= (logand char ?\M-\^＠) 0)
-; ;; Turn a meta-character into a character with the 0200 bit set.
-; (setq code (logior (logand char (lognot ?\M-\^＠)) 128)
-; done t))
- ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))
- (setq code (+ (* code read-quoted-char-radix) (- char ?0)))
- (and prompt (setq prompt (display-message 'prompt
- (format "%s %c" prompt char)))))
- ((and (<= ?a (downcase char))
- (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))
- (setq code (+ (* code read-quoted-char-radix)
- (+ 10 (- (downcase char) ?a))))
- (and prompt (setq prompt (display-message 'prompt
- (format "%s %c" prompt char)))))
- ((and (not first) (eq char ?\C-m))
- (setq done t))
- ((not first)
- ;; XEmacs change; event instead of char.
- (setq unread-command-events (list event)
- done t))
- (t (setq code (char-to-int char)
- done t)))
- (setq first nil))
- ;; XEmacs change; unicode-to-char instead of int-to-char
- (unicode-to-char code)))
+for numeric input.
+
+There is no INHERIT-INPUT-METHOD option, the intent is that `read-quoted-char'
+is a mechanism to escape briefly from an input method and from other key
+bindings."
+ (let (done (first t) (code 0) char (events []) event fixnum
+ (prompt (and prompt (gettext prompt)))
+ (help-event-list
+ ;; Don't let C-h get the help message--only help function
+ ;; keys.
+ (remove-if #'event-to-character
+ ;; Fold help-char into help-event-list to make
+ ;; our code below easier.
+ (cons help-char help-event-list)
+ :key #'character-to-event))
+ (help-char nil)
+ (help-form
+ (format
+ "Type the special character you want to use, or the \
+character code, \nbase %d (the value of `read-quoted-char-radix').
+
+RET terminates the character code and is discarded; any other non-digit
+terminates the character code and is then used as input."
+ read-quoted-char-radix))
+ window-configuration)
+ (while (not done)
+ (let ((inhibit-quit first))
+ (setq events (read-function-key-map events
+ (and prompt (concat prompt
+ " - ")))
+ event (aref events 0)
+ unread-command-events (reduce #'cons events :from-end t
+ :start 1 :initial-value
+ unread-command-events)
+ events []
+ ;; Possibly the only place within XEmacs we still want meta
+ ;; equivalence, always!
+ char (event-to-character event nil 'meta))
+ (if inhibit-quit (setq quit-flag nil))
+ (cond ((null char)
+ (if (find event help-event-list
+ :test #'event-matches-key-specifier-p)
+ ;; If we're on a TTY and f1 comes from function-key-map,
+ ;; event-stream.c may not handle it as it should. Show
+ ;; help ourselves.
+ (when (not window-configuration)
+ (with-output-to-temp-buffer (help-buffer-name nil)
+ (setq window-configuration
+ (current-window-configuration))
+ (write-sequence help-form)))
+ ;; Require at least one keystroke that can be converted
+ ;; into a character, no point inserting ^＠ into the buffer
+ ;; when the user types F8. This differs from GNU Emacs.
+ (if first
+ (error 'no-character-typed event)
+ ;; Not first; a non-character keystroke terminates.
+ (setq unread-command-events
+ (cons event unread-command-events)
+ done t))))
+ ((setq fixnum (digit-char-p char read-quoted-char-radix))
+ (setq code (+ (* code read-quoted-char-radix) fixnum))
+ (and prompt (setq prompt
+ (concat prompt " " (list char)))))
+ ((and (not first) (eql char ?\C-m))
+ (setq done t))
+ ((not first)
+ (setq unread-command-events (cons event
+ unread-command-events)
+ done t))
+ (t
+ (setq code (char-to-unicode char)
+ done t)))
+ (setq first (and first (null char)))))
+ (and window-configuration
+ (set-window-configuration window-configuration))
+ (unicode-to-char code))))
;; in passwd.el.
; (defun read-passwd (prompt &optional confirm default)
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Create a new error for when a char is needed but event-to-character gives nil
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1426297249 0
# Sat Mar 14 01:40:49 2015 +0000
# Node ID c87b776ab0e17984bc705dccebbf6207b13e5620
# Parent 916b48abd1c6959f81904ad159a2f49dbef3e038
Create a new error for when a char is needed but event-to-character gives nil
lisp/ChangeLog addition:
2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
* cmdloop.el (no-character-typed):
New error, for those cases when a keystroke is to be treated as a
character but has no character equivalent.
* cmdloop.el (read-char-1): Use it.
* keymap.el (synthesize-keysym): Use it.
src/ChangeLog addition:
2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
* general-slots.h (Qno_character_typed): New error symbol.
* event-stream.c (syms_of_event_stream): Define it.
New error, for those cases when a keystroke is to be treated as a
character in some context but has no character equivalent.
* cmds.c (Fself_insert_command):
Use it.
diff -r 916b48abd1c6 -r c87b776ab0e1 lisp/ChangeLog
--- a/lisp/ChangeLog Sat Mar 14 01:16:45 2015 +0000
+++ b/lisp/ChangeLog Sat Mar 14 01:40:49 2015 +0000
＠＠ -1,3 +1,11 ＠＠
+2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * cmdloop.el (no-character-typed):
+ New error, for those cases when a keystroke is to be treated as a
+ character but has no character equivalent.
+ * cmdloop.el (read-char-1): Use it.
+ * keymap.el (synthesize-keysym): Use it.
+
2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
* cus-start.el (all): Describe help-event-list for Custom.
diff -r 916b48abd1c6 -r c87b776ab0e1 lisp/cmdloop.el
--- a/lisp/cmdloop.el Sat Mar 14 01:16:45 2015 +0000
+++ b/lisp/cmdloop.el Sat Mar 14 01:40:49 2015 +0000
＠＠ -280,6 +280,10 ＠＠
(princ (gettext " not defined.") stream) ; doo dah, doo dah.
))
+(put 'no-character-typed 'display-error
+ #'(lambda (error-object stream)
+ (write-sequence "Not a character keystroke, " stream)
+ (write-sequence (key-description (cadr error-object)) stream)))
(defcustom teach-extended-commands-p t
"*If true, then `\\[execute-extended-command]' will teach you keybindings.
＠＠ -593,8 +597,7 ＠＠
(aref (cdr binding) (caar binding)))))))
(return-from read-char-1 character)))
(if errorp
- (error 'invalid-key-binding "Not a character keystroke"
- (aref events 0)))
+ (error 'no-character-typed (aref events 0)))
;; If we're not erroring, loop until we get a character
(setq events []))
(if timeout (disable-timeout timeout))))))
diff -r 916b48abd1c6 -r c87b776ab0e1 lisp/keymap.el
--- a/lisp/keymap.el Sat Mar 14 01:16:45 2015 +0000
+++ b/lisp/keymap.el Sat Mar 14 01:40:49 2015 +0000
＠＠ -512,7 +512,7 ＠＠
(error "Illegal character in keysym: %c" char))
(t
;; Illegal event.
- (error "Event has no character equivalent: %s" event))))
+ (error 'no-character-typed event))))
(vector (intern (concat "" (nreverse list))))))
(defun synthesize-unicode-codepoint (ignore-prompt)
diff -r 916b48abd1c6 -r c87b776ab0e1 src/ChangeLog
--- a/src/ChangeLog Sat Mar 14 01:16:45 2015 +0000
+++ b/src/ChangeLog Sat Mar 14 01:40:49 2015 +0000
＠＠ -1,3 +1,12 ＠＠
+2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * general-slots.h (Qno_character_typed): New error symbol.
+ * event-stream.c (syms_of_event_stream): Define it.
+ New error, for those cases when a keystroke is to be treated as a
+ character in some context but has no character equivalent.
+ * cmds.c (Fself_insert_command):
+ Use it.
+
2015-03-14 Aidan Kehoe <kehoea(a)parhasard.net>
Add support for GNU's help-event-list here, useful for accepting
diff -r 916b48abd1c6 -r c87b776ab0e1 src/cmds.c
--- a/src/cmds.c Sat Mar 14 01:16:45 2015 +0000
+++ b/src/cmds.c Sat Mar 14 01:40:49 2015 +0000
＠＠ -346,9 +346,9 ＠＠
c = Fevent_to_character (Vlast_command_event, Qnil, Qnil, Qnil);
if (NILP (c))
- invalid_operation (
- "Last typed key has no character equivalent (that we know of)",
- Fcopy_event (Vlast_command_event, Qnil));
+ {
+ Fsignal (Qno_character_typed, Fcopy_event (Vlast_command_event, Qnil));
+ }
CHECK_CHAR_COERCE_INT (c);
diff -r 916b48abd1c6 -r c87b776ab0e1 src/event-stream.c
--- a/src/event-stream.c Sat Mar 14 01:16:45 2015 +0000
+++ b/src/event-stream.c Sat Mar 14 01:40:49 2015 +0000
＠＠ -4920,6 +4920,7 ＠＠
DEFSYMBOL (Qcommand_event_p);
DEFERROR_STANDARD (Qundefined_keystroke_sequence, Qsyntax_error);
+ DEFERROR_STANDARD (Qno_character_typed, Qundefined_keystroke_sequence);
DEFERROR_STANDARD (Qinvalid_key_binding, Qinvalid_state);
DEFSUBR (Frecent_keys);
diff -r 916b48abd1c6 -r c87b776ab0e1 src/general-slots.h
--- a/src/general-slots.h Sat Mar 14 01:16:45 2015 +0000
+++ b/src/general-slots.h Sat Mar 14 01:40:49 2015 +0000
＠＠ -213,6 +213,7 ＠＠
SYMBOL_MODULE_API (Qnative);
SYMBOL (Qnatnum);
SYMBOL (Qno);
+SYMBOL (Qno_character_typed);
SYMBOL (Qnone);
SYMBOL (Qnot);
SYMBOL (Qnothing);
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Be more careful about echo_buf arithmetic, event-stream.c.
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1426203102 0
# Thu Mar 12 23:31:42 2015 +0000
# Node ID 6ec4964c168757948e11cb77e28966c253f00559
# Parent 27876789edc5d9485f2c9895ec4790edeaaf71f1
Be more careful about echo_buf arithmetic, event-stream.c.
src/ChangeLog addition:
2015-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
* event-stream.c (lookup_command_event):
Check whether echo_buf_fill_pointer is negative before using it in
arithmetic, avoiding a crash in GC.
Oddly the old code didn't do this check and didn't crash, but its
echo_buf was from malloced memory, not from our string data, so
there may have been more room to manoeuvre.
diff -r 27876789edc5 -r 6ec4964c1687 src/ChangeLog
--- a/src/ChangeLog Thu Mar 12 00:59:27 2015 +0000
+++ b/src/ChangeLog Thu Mar 12 23:31:42 2015 +0000
＠＠ -1,3 +1,12 ＠＠
+2015-03-12 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * event-stream.c (lookup_command_event):
+ Check whether echo_buf_fill_pointer is negative before using it in
+ arithmetic, avoiding a crash in GC.
+ Oddly the old code didn't do this check and didn't crash, but its
+ echo_buf was from malloced memory, not from our string data, so
+ there may have been more room to manoeuvre.
+
2015-03-04 Aidan Kehoe <kehoea(a)parhasard.net>
* sequence.c (count_with_tail):
diff -r 27876789edc5 -r 6ec4964c1687 src/event-stream.c
--- a/src/event-stream.c Thu Mar 12 00:59:27 2015 +0000
+++ b/src/event-stream.c Thu Mar 12 23:31:42 2015 +0000
＠＠ -4067,10 +4067,11 ＠＠
#endif
{
Lisp_Object prompt = Fkeymap_prompt (leaf, Qt);
- if (STRINGP (prompt))
+ if (STRINGP (prompt) && STRINGP (command_builder->echo_buf))
{
/* Append keymap prompt to key echo buffer */
- int buf_fill_pointer = command_builder->echo_buf_fill_pointer;
+ Bytecount buf_fill_pointer
+ = max (command_builder->echo_buf_fill_pointer, 0);
Bytecount len = XSTRING_LENGTH (prompt);
if (len + buf_fill_pointer + 1
＠＠ -4090,7 +4091,8 ＠＠
/* Show the keymap prompt, but don't adjust the fill
pointer to reflect it. */
command_builder->echo_buf_end
- = command_builder->echo_buf_fill_pointer + len;
+ = buf_fill_pointer + len;
+ command_builder->echo_buf_fill_pointer = buf_fill_pointer;
}
maybe_echo_keys (command_builder, 1);
}
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Look for cased character classes when deciding on case-fold-search, #'isearch
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1426097175 0
# Wed Mar 11 18:06:15 2015 +0000
# Node ID 0bddb59072b667153117b8c6407cdedaee4dad3b
# Parent ccb0cff115d2dc5a0752e3f688a562c48ab90ffc
Look for cased character classes when deciding on case-fold-search, #'isearch
lisp/ChangeLog addition:
2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
* isearch-mode.el:
* isearch-mode.el (isearch-fix-case):
Use the new #'no-case-regexp-p function if treating ISEARCH-STRING
as a regular expression; otherwise, use the [[:upper:]] character
class.
* isearch-mode.el (isearch-no-upper-case-p): Removed.
* isearch-mode.el (with-caps-disable-folding): Removed.
These two haven't been used since 1998.
* occur.el (occur-1):
Use #'no-case-regexp-p here.
* replace.el (perform-replace):
Don't use #'no-upper-case-p, use #'no-case-regexp-p or
(string-match "[[:upper:]]" ...) as appropriate.
* simple.el:
* simple.el (no-upper-case-p): Removed. This did two different
things, and its secondary function (examining regular expressions)
just became much more complicated; move the regular expression
functionality to its own function, use character classes when
examining non-regular-expressions instead.
The code to look for character classes, and the design decision
that this should be done, are from GNU, thank you Stefan Monnier.
* simple.el (no-case-regexp-p): New.
Given a REGEXP, return non-nil if it has nothing to suggest an
interactive user wants a case-sensitive search.
* simple.el (with-search-caps-disable-folding):
* simple.el (with-interactive-search-caps-disable-folding):
Update both these macros to use #'no-case-regexp-p.
diff -r ccb0cff115d2 -r 0bddb59072b6 lisp/ChangeLog
--- a/lisp/ChangeLog Wed Mar 11 15:06:05 2015 +0000
+++ b/lisp/ChangeLog Wed Mar 11 18:06:15 2015 +0000
＠＠ -1,3 +1,33 ＠＠
+2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * isearch-mode.el:
+ * isearch-mode.el (isearch-fix-case):
+ Use the new #'no-case-regexp-p function if treating ISEARCH-STRING
+ as a regular expression; otherwise, use the [[:upper:]] character
+ class.
+ * isearch-mode.el (isearch-no-upper-case-p): Removed.
+ * isearch-mode.el (with-caps-disable-folding): Removed.
+ These two haven't been used since 1998.
+ * occur.el (occur-1):
+ Use #'no-case-regexp-p here.
+ * replace.el (perform-replace):
+ Don't use #'no-upper-case-p, use #'no-case-regexp-p or
+ (string-match "[[:upper:]]" ...) as appropriate.
+ * simple.el:
+ * simple.el (no-upper-case-p): Removed. This did two different
+ things, and its secondary function (examining regular expressions)
+ just became much more complicated; move the regular expression
+ functionality to its own function, use character classes when
+ examining non-regular-expressions instead.
+ The code to look for character classes, and the design decision
+ that this should be done, are from GNU, thank you Stefan Monnier.
+ * simple.el (no-case-regexp-p): New.
+ Given a REGEXP, return non-nil if it has nothing to suggest an
+ interactive user wants a case-sensitive search.
+ * simple.el (with-search-caps-disable-folding):
+ * simple.el (with-interactive-search-caps-disable-folding):
+ Update both these macros to use #'no-case-regexp-p.
+
2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
Correct #'clear-message and friends so the START and END supplied
diff -r ccb0cff115d2 -r 0bddb59072b6 lisp/isearch-mode.el
--- a/lisp/isearch-mode.el Wed Mar 11 15:06:05 2015 +0000
+++ b/lisp/isearch-mode.el Wed Mar 11 18:06:15 2015 +0000
＠＠ -1068,7 +1068,11 ＠＠
(not isearch-fixed-case)
search-caps-disable-folding)
(setq isearch-case-fold-search
- (no-upper-case-p isearch-string isearch-regexp)))
+ (if isearch-regexp
+ (no-case-regexp-p isearch-string)
+ (save-match-data
+ (let (case-fold-search)
+ (not (string-match "[[:upper:]]" isearch-string)))))))
(setq isearch-mode (if case-fold-search
(if isearch-case-fold-search
" Isearch" ;As God Intended Mode
＠＠ -1856,15 +1860,6 ＠＠
t))
isearch-unhidden-extents)))))
-(defun isearch-no-upper-case-p (string)
- "Return t if there are no upper case chars in string.
-But upper case chars preceded by \\ do not count since they
-have special meaning in a regexp."
- ;; this incorrectly returns t for "\\\\A"
- (let ((case-fold-search nil))
- (not (string-match "\\(^\\|[^\\]\\)[A-Z]" string))))
-(make-obsolete 'isearch-no-upper-case-p 'no-upper-case-p)
-
;; Portability functions to support various Emacs versions.
(defun isearch-char-to-string (c)
＠＠ -1876,20 +1871,6 ＠＠
; (isearch-char-to-string c))
(define-function 'isearch-text-char-description 'text-char-description)
-
-;; Used by etags.el and info.el
-(defmacro with-caps-disable-folding (string &rest body) "\
-Eval BODY with `case-fold-search' let to nil if STRING contains
-uppercase letters and `search-caps-disable-folding' is t."
- `(let ((case-fold-search
- (if (and case-fold-search search-caps-disable-folding)
- (isearch-no-upper-case-p ,string)
- case-fold-search)))
- ,＠body))
-(make-obsolete 'with-caps-disable-folding 'with-search-caps-disable-folding)
-(put 'with-caps-disable-folding 'lisp-indent-function 1)
-(put 'with-caps-disable-folding 'edebug-form-spec '(form body))
-
;;;========================================================
;;; Advanced highlighting
diff -r ccb0cff115d2 -r 0bddb59072b6 lisp/occur.el
--- a/lisp/occur.el Wed Mar 11 15:06:05 2015 +0000
+++ b/lisp/occur.el Wed Mar 11 18:06:15 2015 +0000
＠＠ -394,8 +394,7 ＠＠
(let ((count (occur-engine
regexp active-bufs occur-buf
(or nlines list-matching-lines-default-context-lines)
- (and case-fold-search
- (no-upper-case-p regexp t))
+ (and case-fold-search (no-case-regexp-p regexp))
list-matching-lines-buffer-name-face
nil list-matching-lines-face t)))
(let* ((bufcount (length active-bufs))
diff -r ccb0cff115d2 -r 0bddb59072b6 lisp/replace.el
--- a/lisp/replace.el Wed Mar 11 15:06:05 2015 +0000
+++ b/lisp/replace.el Wed Mar 11 18:06:15 2015 +0000
＠＠ -563,7 +563,11 ＠＠
;; XEmacs addition
(qr-case-fold-search
(if (and case-fold-search search-caps-disable-folding)
- (no-upper-case-p search-string regexp-flag)
+ (if regexp-flag
+ (no-case-regexp-p search-string)
+ (save-match-data
+ (let (case-fold-search)
+ (not (string-match "[[:upper:]]" search-string)))))
case-fold-search))
(message
(if query-flag
diff -r ccb0cff115d2 -r 0bddb59072b6 lisp/simple.el
--- a/lisp/simple.el Wed Mar 11 15:06:05 2015 +0000
+++ b/lisp/simple.el Wed Mar 11 18:06:15 2015 +0000
＠＠ -94,47 +94,70 ＠＠
"Warnings customizations."
:group 'minibuffer)
-
(defcustom search-caps-disable-folding t
"*If non-nil, upper case chars disable case fold searching.
This does not apply to \"yanked\" strings."
:type 'boolean
:group 'editing-basics)
-;; This is stolen (and slightly modified) from FSF emacs's
-;; `isearch-no-upper-case-p'.
-(defun no-upper-case-p (string &optional regexp-flag)
- "Return t if there are no upper case chars in STRING.
-If REGEXP-FLAG is non-nil, disregard letters preceded by `\\' (but not `\\\\')
-since they have special meaning in a regexp."
+(defun no-case-regexp-p (regexp)
+ "Return t if there are no case-specific constructs in REGEXP.
+
+Lower case characters are regarded as not case-specific. Upper case
+characters are usually regarded as case-specific, but upper case characters
+used in special regexp constructs, where they do not match upper case
+characters specifically, are regarded as not case-specific. In contrast, the
+character classes [:lower:] and [:upper:] are viewed as case-specific.
+
+This is intended to be used by interactive searching code to decide, in a
+do-what-I-mean fashion, whether a given search should be case-sensitive."
(let ((case-fold-search nil))
- (not (string-match (if regexp-flag
- "\\(^\\|\\\\\\\\\\|[^\\]\\)[A-Z]"
- "[A-Z]")
- string))
- ))
-
-(defmacro with-search-caps-disable-folding (string regexp-flag &rest body) "\
-Eval BODY with `case-fold-search' let to nil if `search-caps-disable-folding'
-is non-nil, and if STRING (either a string or a regular expression according
-to REGEXP-FLAG) contains uppercase letters."
+ (save-match-data
+ (not (or (string-match "\\(^\\|\\\\\\\\\\|[^\\]\\)[[:upper:]]" regexp)
+ (and (string-match "\\[:\\(upp\\|low\\)er:]" regexp)
+ (condition-case err
+ (progn
+ (string-match (substring regexp 0
+ (match-beginning 0)) "")
+ nil)
+ (invalid-regexp
+ (equal "Unmatched [ or [^" (cadr err))))))))))
+
+(defmacro* with-search-caps-disable-folding (string regexp-p &body body)
+ "Execute the forms in BODY, respecting `search-caps-disable-folding'.
+
+Within BODY, bind `case-fold-search' to nil if `search-caps-disable-folding'
+is non-nil, REGEXP-P is nil, and if STRING contains any uppercase characters.
+
+If REGEXP-P is non-nil, treat STRING as a regular expression, and bind
+`case-fold-search' to nil if it contains uppercase characters that are
+not special regular expression constructs, or if it contains
+case-specific character classes such as `[[:upper:]]' or
+`[[:lower:]]'. See `no-case-regexp-p'."
`(let ((case-fold-search
(if (and case-fold-search search-caps-disable-folding)
- (no-upper-case-p ,string ,regexp-flag)
+ (if ,regexp-p
+ (no-case-regexp-p ,string)
+ (save-match-data
+ (let (case-fold-search)
+ (not (string-match "[[:upper:]]" ,string)))))
case-fold-search)))
,＠body))
(put 'with-search-caps-disable-folding 'lisp-indent-function 2)
(put 'with-search-caps-disable-folding 'edebug-form-spec
'(sexp sexp &rest form))
-(defmacro with-interactive-search-caps-disable-folding (string regexp-flag
- &rest body)
- "Same as `with-search-caps-disable-folding', but only in the case of a
-function called interactively."
+(defmacro* with-interactive-search-caps-disable-folding (string regexp-p
+ &body body)
+ "Like `with-search-caps-disable-folding', but only when interactive."
`(let ((case-fold-search
- (if (and (interactive-p)
- case-fold-search search-caps-disable-folding)
- (no-upper-case-p ,string ,regexp-flag)
+ (if (and (interactive-p) case-fold-search
+ search-caps-disable-folding)
+ (if ,regexp-p
+ (no-case-regexp-p ,string)
+ (save-match-data
+ (let (case-fold-search)
+ (not (string-match "[[:upper:]]" ,string)))))
case-fold-search)))
,＠body))
(put 'with-interactive-search-caps-disable-folding 'lisp-indent-function 2)
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Update message-stack to reflect START and END supplied to #'append-message
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1426086365 0
# Wed Mar 11 15:06:05 2015 +0000
# Node ID ccb0cff115d2dc5a0752e3f688a562c48ab90ffc
# Parent 1044acf60048098a0b60326561d732c7691a357a
Update message-stack to reflect START and END supplied to #'append-message
lisp/ChangeLog addition:
2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
Correct #'clear-message and friends so the START and END supplied
to #'append-message are reflected when restoring messages from the
message stack.
* simple.el (remove-message-hook):
Update this to reflect the START and END keyword arguments.
* simple.el (log-message):
Update this to take START and END keyword arguments.
* simple.el (clear-message):
Update this to reflect a changed `message-stack' alist structure.
* simple.el (remove-message):
Update this to reflect a changed `message-stack' alist structure;
don't do `with-trapping-errors' and resignal use
#'call-with-condition-handler directly instead, for better
backtraces and easier debugging.
* simple.el (append-message):
Update this to reflect a changed message-stack structure.
diff -r 1044acf60048 -r ccb0cff115d2 lisp/ChangeLog
--- a/lisp/ChangeLog Sun Mar 08 20:59:25 2015 +0000
+++ b/lisp/ChangeLog Wed Mar 11 15:06:05 2015 +0000
＠＠ -1,3 +1,22 ＠＠
+2015-03-11 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ Correct #'clear-message and friends so the START and END supplied
+ to #'append-message are reflected when restoring messages from the
+ message stack.
+ * simple.el (remove-message-hook):
+ Update this to reflect the START and END keyword arguments.
+ * simple.el (log-message):
+ Update this to take START and END keyword arguments.
+ * simple.el (clear-message):
+ Update this to reflect a changed `message-stack' alist structure.
+ * simple.el (remove-message):
+ Update this to reflect a changed `message-stack' alist structure;
+ don't do `with-trapping-errors' and resignal use
+ #'call-with-condition-handler directly instead, for better
+ backtraces and easier debugging.
+ * simple.el (append-message):
+ Update this to reflect a changed message-stack structure.
+
2014-12-31 Michael Sperber <mike(a)xemacs.org>
* simple.el (line-move): Add `noerror' optional argument, as in
diff -r 1044acf60048 -r ccb0cff115d2 lisp/simple.el
--- a/lisp/simple.el Sun Mar 08 20:59:25 2015 +0000
+++ b/lisp/simple.el Wed Mar 11 15:06:05 2015 +0000
＠＠ -4166,8 +4166,9 ＠＠
(defvar remove-message-hook 'log-message
"A function or list of functions to be called when a message is removed
from the echo area at the bottom of the frame. The label of the removed
-message is passed as the first argument, and the text of the message
-as the second argument.")
+message is passed as the first argument, the text of the message as the second
+argument, and the start and end of the substring of the message can be
+supplied as keyword arguments.")
(defcustom log-message-max-size 50000
"Maximum size of the \" *Message-Log*\" buffer. See `log-message'."
＠＠ -4300,7 +4301,7 ＠＠
"For use as the `log-message-filter-function'. Only logs error messages."
(eq label 'error))
-(defun log-message (label message)
+(defun* log-message (label message &key (start 0) end)
"Stuff a copy of the message into the \" *Message-Log*\" buffer,
if it satisfies the `log-message-filter-function'.
＠＠ -4316,12 +4317,10 ＠＠
(let (extent)
;; Mark multiline message with an extent, which `view-lossage'
;; will recognize.
- (save-match-data
- (when (string-match "\n" message)
- (setq extent (make-extent (point) (point)))
- (set-extent-properties extent '(end-open nil message-multiline t)))
- )
- (insert message "\n")
+ (when (find ?\n message :start start :end end)
+ (setq extent (make-extent (point) (point)))
+ (set-extent-properties extent '(end-open nil message-multiline t)))
+ (write-line message (current-buffer) :start start :end end)
(when extent
(set-extent-property extent 'end-open t)))
(when (> (point-max) (max log-message-max-size (point-min)))
＠＠ -4377,42 +4376,48 ＠＠
(if no-restore
nil ; just preparing to put another msg up
(if message-stack
- (let ((oldmsg (cdr (car message-stack))))
- (raw-append-message oldmsg frame stdout-p)
- oldmsg)
+ (let ((oldmsg (second (car message-stack))))
+ (prog1
+ ;; #### Doesn't pass back information about the substring of
+ ;; OLDMSG displayed. None of our callers use this, as of
+ ;; 20150311, though.
+ oldmsg
+ (raw-append-message oldmsg frame stdout-p
+:start (third (car message-stack))
+:end (fourth (car message-stack)))))
;; #### Should we (redisplay-echo-area) here? Messes some
;; things up.
nil))))
(defun remove-message (&optional label frame)
- ;; If label is nil, we want to remove all matching messages.
- ;; Must reverse the stack first to log them in the right order.
- (let ((log nil))
- (while (and message-stack
- (or (null label) ; null label means clear whole stack
- (eq label (car (car message-stack)))))
- (push (car message-stack) log)
- (setq message-stack (cdr message-stack)))
- (let ((s message-stack))
- (while (cdr s)
- (let ((msg (car (cdr s))))
- (if (eq label (car msg))
- (progn
- (push msg log)
- (setcdr s (cdr (cdr s))))
- (setq s (cdr s))))))
+ "Remove any message with a specified LABEL from `message-stack'.
+
+With nil LABEL, remove all messages from `message-stack'. Calls those
+functions specified by `remove-message-hook' with the details of each removed
+message."
+ (let (log)
+ (if label
+ (setq log (reverse (remove* label message-stack :test-not #'eq
+:key #'car))
+ message-stack (delete* label message-stack :key #'car))
+ ;; If label is nil, we want to remove all messages. Must reverse the
+ ;; stack first to log them in the right order.
+ (setq log (nreverse message-stack)
+ message-stack nil))
;; (possibly) log each removed message
(while log
- (with-trapping-errors
- :operation 'remove-message-hook
- :class 'message-log
- :error-form (progn
- (setq remove-message-hook nil)
- (let ((inhibit-read-only t))
- (erase-buffer " *Echo Area*")))
- :resignal t
- (run-hook-with-args 'remove-message-hook
- (car (car log)) (cdr (car log))))
+ (call-with-condition-handler
+ ((macro . (lambda (function) (subst '#:xEbgpd2 'error function)))
+ #'(lambda (error)
+ (setq remove-message-hook nil)
+ (let ((inhibit-read-only t))
+ (erase-buffer " *Echo Area*"))
+ (lwarn 'message-log 'warning
+ "Error in `remove-message-hook': %s\n\nBacktrace follows:\n%s"
+ (error-message-string error)
+ (backtrace-in-condition-handler-eliminating-handler 'error))))
+ #'run-hook-with-args 'remove-message-hook (caar log)
+ (cadar log) :start (third (car log)) :end (fourth (car log)))
(setq log (cdr log)))))
(defun* append-message (label message &optional frame stdout-p
＠＠ -4436,10 +4441,16 ＠＠
;; able to append to an existing message.
(if (eq 'stream (frame-type frame))
(set-device-clear-left-side (frame-device frame) nil))
- (let ((top (car message-stack)))
- (if (eq label (car top))
- (setcdr top (concat (cdr top) message))
- (push (cons label message) message-stack)))
+ (if (eq label (caar message-stack))
+ (setf (cadar message-stack)
+ (concat (subseq (cadar message-stack) (third (car message-stack))
+ (fourth (car message-stack)))
+ (if (or end (not (eql start 0)))
+ (subseq message start end)
+ message))
+ (caddar message-stack) nil
+ (car (cdddar message-stack)) nil)
+ (push (list label message start end) message-stack))
(raw-append-message message frame stdout-p :start start :end end)
(if (eq 'stream (frame-type frame))
(set-device-clear-left-side (frame-device frame) t)))
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Revert part of Jerry's December gnuserv change
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1425848365 0
# Sun Mar 08 20:59:25 2015 +0000
# Node ID 1044acf60048098a0b60326561d732c7691a357a
# Parent e9bb3688e654d8f944fbf2943f9f9d030e272501
Revert part of Jerry's December 2014 that broke gnuclient on some OS X.
lib-src/ChangeLog addition:
2015-03-08 Aidan Kehoe <kehoea(a)parhasard.net>
* gnuserv.c (echo_request):
No longer close the file handle unconditionally, leave this to the
individual socket types.
* gnuserv.c (handle_internet_request):
Close the file handle here.
* gnuserv.c (handle_unix_request):
Don't close the file handle here, document why (it broke gnuclient
under OS X). It should actually be OK, but my suspicion is that
the issues is that the Unix (local) domain sockets are still
underdocumented compared to the internet sockets.
diff -r e9bb3688e654 -r 1044acf60048 lib-src/ChangeLog
--- a/lib-src/ChangeLog Wed Mar 04 15:54:00 2015 +0000
+++ b/lib-src/ChangeLog Sun Mar 08 20:59:25 2015 +0000
＠＠ -1,3 +1,16 ＠＠
+2015-03-08 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * gnuserv.c (echo_request):
+ No longer close the file handle unconditionally, leave this to the
+ individual socket types.
+ * gnuserv.c (handle_internet_request):
+ Close the file handle here.
+ * gnuserv.c (handle_unix_request):
+ Don't close the file handle here, document why (it broke gnuclient
+ under OS X). It should actually be OK, but my suspicion is that
+ the issues is that the Unix (local) domain sockets are still
+ underdocumented compared to the internet sockets.
+
2014-12-05 Jerry James <james(a)xemacs.org>
* gnuserv.c (echo_request): close the socket when done
diff -r e9bb3688e654 -r 1044acf60048 lib-src/gnuserv.c
--- a/lib-src/gnuserv.c Wed Mar 04 15:54:00 2015 +0000
+++ b/lib-src/gnuserv.c Sun Mar 08 20:59:25 2015 +0000
＠＠ -321,7 +321,6 ＠＠
exit(1);
} /* if */
- close(s);
} /* echo_request */
＠＠ -754,6 +753,7 ＠＠
echo_request(s);
+ close(s);
} /* handle_internet_request */
#endif /* INTERNET_DOMAIN_SOCKETS */
＠＠ -864,6 +864,14 ＠＠
echo_request(s);
+ /* Closing s here (or rather, within echo_request() with both
+ internet and local connections) meant gnuserv never returned
+ usefully under OS X, as of 20150308, reflecting changeset
+ https://bitbucket.org/xemacs/xemacs/commits/c03dd89 . Keeping it
+ open is not a significant security risk (it's a local connection,
+ with file system access restrictions) and given the practical
+ limitation on the number of handles gnuserv will keep around,
+ it's also not a significant resource issue. Leave it open. */
} /* handle_unix_request */
#endif /* UNIX_DOMAIN_SOCKETS */
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
Re: [COMMIT] Fix some bugs in #'substitute, #'nsubstitute.
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
Ar an cúigiú lá de mí Márta, scríobh Stephen J. Turnbull:
> Aidan Kehoe writes:
>
> > +;; Test #'substitute. Paul Dietz has much more comprehensive
> > tests.
>
> What was the issue with adding the Dietz suite to XEmacs? License?
Something of the sort; it was the days of the GPLv3 changeover and he
(Dietz) didn’t answer my email regarding their licence status. They really
are excellent, it would be nice to include them.
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments
[COMMIT] Fix some bugs in #'substitute, #'nsubstitute.
9 years, 1 month
Aidan Kehoe
Aidan Kehoe
APPROVE COMMIT
NOTE: This patch has been committed.
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1425484440 0
# Wed Mar 04 15:54:00 2015 +0000
# Node ID e9bb3688e654d8f944fbf2943f9f9d030e272501
# Parent eabf763bc6f95812d41b72436de9cd1ab73f7737
Fix some bugs in #'substitute, #'nsubstitute.
src/ChangeLog addition:
2015-03-04 Aidan Kehoe <kehoea(a)parhasard.net>
* sequence.c (count_with_tail):
Accept COUNT from #'substitute, #'nsubstitute too.
* sequence.c (FdeleteX):
Only remove COUNT from the arguments if FROM-END is non-nil.
* sequence.c (Fnsubstitute):
Remove COUNT from the arguments if specified and FROM-END is
non-nil.
* sequence.c (Fsubstitute):
Remove COUNT from the arguments if specified and FROM-END is
non-nil. Do this before calling count_with_tail(). When we
encounter the cons return by count_with_tail(), use the
replacement object.
tests/ChangeLog addition:
2015-03-04 Aidan Kehoe <kehoea(a)parhasard.net>
* automated/lisp-tests.el:
Add some tests for #'substitute.
diff -r eabf763bc6f9 -r e9bb3688e654 src/ChangeLog
--- a/src/ChangeLog Sat Feb 28 17:06:40 2015 -0800
+++ b/src/ChangeLog Wed Mar 04 15:54:00 2015 +0000
＠＠ -1,3 +1,18 ＠＠
+2015-03-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * sequence.c (count_with_tail):
+ Accept COUNT from #'substitute, #'nsubstitute too.
+ * sequence.c (FdeleteX):
+ Only remove COUNT from the arguments if FROM-END is non-nil.
+ * sequence.c (Fnsubstitute):
+ Remove COUNT from the arguments if specified and FROM-END is
+ non-nil.
+ * sequence.c (Fsubstitute):
+ Remove COUNT from the arguments if specified and FROM-END is
+ non-nil. Do this before calling count_with_tail(). When we
+ encounter the cons return by count_with_tail(), use the
+ replacement object.
+
2015-01-08 Stephen J. Turnbull <stephen(a)xemacs.org>
Fix progress bar crashes.
diff -r eabf763bc6f9 -r e9bb3688e654 src/sequence.c
--- a/src/sequence.c Sat Feb 28 17:06:40 2015 -0800
+++ b/src/sequence.c Wed Mar 04 15:54:00 2015 +0000
＠＠ -710,9 +710,6 ＠＠
/* Our callers should have filtered out non-positive COUNT. */
assert (counting >= 0);
- /* And we're not prepared to handle COUNT from any other caller at the
- moment. */
- assert (EQ (caller, QremoveX)|| EQ (caller, QdeleteX));
}
check_test = get_check_test_function (item, &test, test_not, if_, if_not,
＠＠ -1878,7 +1875,7 ＠＠
PARSE_KEYWORDS (FdeleteX, nargs, args, 9,
(test, if_not, if_, test_not, key, start, end, from_end,
- count), (start = Qzero, count = Qunbound));
+ count), (start = Qzero));
CHECK_SEQUENCE (sequence);
CHECK_NATNUM (start);
＠＠ -1890,45 +1887,41 ＠＠
ending = BIGNUMP (end) ? 1 + MOST_POSITIVE_FIXNUM : XFIXNUM (end);
}
- if (!UNBOUNDP (count))
- {
- if (!NILP (count))
- {
- CHECK_INTEGER (count);
- if (FIXNUMP (count))
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (FIXNUMP (count))
+ {
+ counting = XFIXNUM (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1;
+ }
+#endif
+ if (counting < 1)
+ {
+ return sequence;
+ }
+
+ if (!NILP (from_end))
+ {
+ /* Sigh, this is inelegant. Force count_with_tail () to ignore
+ the count keyword, so we get the actual number of matching
+ elements, and can start removing from the beginning for the
+ from-end case. */
+ for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args;
+ ii < nargs; ii += 2)
{
- counting = XFIXNUM (count);
+ if (EQ (args[ii], Q_count))
+ {
+ args[ii + 1] = Qnil;
+ break;
+ }
}
-#ifdef HAVE_BIGNUM
- else
- {
- counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
- 1 + MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM - 1;
- }
-#endif
-
- if (counting < 1)
- {
- return sequence;
- }
-
- if (!NILP (from_end))
- {
- /* Sigh, this is inelegant. Force count_with_tail () to ignore
- the count keyword, so we get the actual number of matching
- elements, and can start removing from the beginning for the
- from-end case. */
- for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (FdeleteX))->min_args;
- ii < nargs; ii += 2)
- {
- if (EQ (args[ii], Q_count))
- {
- args[ii + 1] = Qnil;
- break;
- }
- }
- ii = 0;
- }
+ ii = 0;
}
}
＠＠ -5797,6 +5790,20 ＠＠
{
return sequence;
}
+
+ if (!NILP (from_end))
+ {
+ for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (Fnsubstitute))->min_args;
+ ii < nargs; ii += 2)
+ {
+ if (EQ (args[ii], Q_count))
+ {
+ args[ii + 1] = Qnil;
+ break;
+ }
+ }
+ ii = 0;
+ }
}
check_test = get_check_test_function (item, &test, test_not, if_, if_not,
＠＠ -6015,16 +6022,16 ＠＠
{
Lisp_Object new_ = args[0], item = args[1], sequence = args[2], tail = Qnil;
Lisp_Object result = Qnil, result_tail = Qnil;
- Lisp_Object object, position0, matched_count;
+ Lisp_Object object, position0, matched;
Elemcount starting = 0, ending = MOST_POSITIVE_FIXNUM, encountered = 0;
- Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, presenting = 0;
+ Elemcount ii = 0, counting = MOST_POSITIVE_FIXNUM, skipping = 0;
Boolint test_not_unboundp = 1;
check_test_func_t check_test = NULL;
struct gcpro gcpro1;
PARSE_KEYWORDS (Fsubstitute, nargs, args, 9,
(test, if_, if_not, test_not, key, start, end, count,
- from_end), (start = Qzero, count = Qunbound));
+ from_end), (start = Qzero));
CHECK_SEQUENCE (sequence);
＠＠ -6040,30 +6047,6 ＠＠
check_test = get_check_test_function (item, &test, test_not, if_, if_not,
key, &test_not_unboundp);
- if (!UNBOUNDP (count))
- {
- if (!NILP (count))
- {
- CHECK_INTEGER (count);
- if (FIXNUMP (count))
- {
- counting = XFIXNUM (count);
- }
-#ifdef HAVE_BIGNUM
- else
- {
- counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
- 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM;
- }
-#endif
-
- if (counting <= 0)
- {
- return sequence;
- }
- }
- }
-
if (!CONSP (sequence))
{
position0 = position (&object, item, sequence, check_test,
＠＠ -6081,17 +6064,62 ＠＠
}
}
- matched_count = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute);
-
- if (ZEROP (matched_count))
+ if (!NILP (count))
+ {
+ CHECK_INTEGER (count);
+ if (FIXNUMP (count))
+ {
+ counting = XFIXNUM (count);
+ }
+#ifdef HAVE_BIGNUM
+ else
+ {
+ counting = bignum_sign (XBIGNUM_DATA (count)) > 0 ?
+ 1 + MOST_POSITIVE_FIXNUM : -1 + MOST_NEGATIVE_FIXNUM;
+ }
+#endif
+
+ if (counting <= 0)
+ {
+ return sequence;
+ }
+
+ /* Sigh, this is inelegant. Force count_with_tail () to ignore the count
+ keyword, so we get the actual number of matching elements, and can
+ start removing from the beginning for the from-end case. */
+ if (!NILP (from_end))
+ {
+ for (ii = XSUBR (GET_DEFUN_LISP_OBJECT (Fsubstitute))->min_args;
+ ii < nargs; ii += 2)
+ {
+ if (EQ (args[ii], Q_count))
+ {
+ args[ii + 1] = Qnil;
+ break;
+ }
+ }
+ ii = 0;
+ }
+ }
+
+ matched = count_with_tail (&tail, nargs - 1, args + 1, Qsubstitute);
+
+ if (ZEROP (matched))
{
return sequence;
}
if (!NILP (count) && !NILP (from_end))
{
- presenting = XFIXNUM (matched_count);
- presenting = presenting <= counting ? 0 : presenting - counting;
+ Elemcount matching = XFIXNUM (matched);
+ if (matching > counting)
+ {
+ /* skipping is the number of elements to be skipped before we start
+ substituting. It is for those cases where both :count and
+:from-end are specified, and the number of elements present is
+ greater than that limit specified with :count. */
+ skipping = matching - counting;
+ }
}
GCPRO1 (result);
＠＠ -6100,20 +6128,32 ＠＠
{
if (EQ (tail, tailing))
{
+ /* No need to do check_test, we're sure that this element matches
+ because its cons is what count_with_tail returned as the
+ tail. */
+ if (skipping ? encountered >= skipping : encountered < counting)
+ {
+ if (NILP (result))
+ {
+ result = Fcons (new_, XCDR (tail));
+ }
+ else
+ {
+ XSETCDR (result_tail, Fcons (new_, XCDR (tail)));
+ }
+ }
+ else
+ {
+ XSETCDR (result_tail, tail);
+ }
+
XUNGCPRO (elt);
UNGCPRO;
-
- if (NILP (result))
- {
- return XCDR (tail);
- }
-
- XSETCDR (result_tail, XCDR (tail));
- return result;
+ return result;
}
else if (starting <= ii && ii < ending &&
(check_test (test, key, item, elt) == test_not_unboundp)
- && (presenting ? encountered++ >= presenting
+ && (skipping ? encountered++ >= skipping
: encountered++ < counting))
{
if (NILP (result))
diff -r eabf763bc6f9 -r e9bb3688e654 tests/ChangeLog
--- a/tests/ChangeLog Sat Feb 28 17:06:40 2015 -0800
+++ b/tests/ChangeLog Wed Mar 04 15:54:00 2015 +0000
＠＠ -1,3 +1,8 ＠＠
+2015-03-04 Aidan Kehoe <kehoea(a)parhasard.net>
+
+ * automated/lisp-tests.el:
+ Add some tests for #'substitute.
+
2014-10-11 Stephen J. Turnbull <stephen(a)xemacs.org>
* automated/keymap-tests.el:
diff -r eabf763bc6f9 -r e9bb3688e654 tests/automated/lisp-tests.el
--- a/tests/automated/lisp-tests.el Sat Feb 28 17:06:40 2015 -0800
+++ b/tests/automated/lisp-tests.el Wed Mar 04 15:54:00 2015 +0000
＠＠ -2988,6 +2988,97 ＠＠
(Check-Error wrong-number-of-arguments
(funcall list-and-four 7 8 9 10)))
+;; Test #'substitute. Paul Dietz has much more comprehensive tests.
+
+(Assert (equal (substitute 'a 'b '(a b c d e f g)) '(a a c d e f g)))
+(Assert (equal (substitute 'a 'b '(a b c d e b f g) :from-end t :count 1)
+ '(a b c d e a f g)))
+
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x)))
+ (and (equal nomodif x) y))
+ '(z b c z b d z c b z e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :count nil)))
+ (and (equal nomodif x) y))
+ '(z b c z b d z c b z e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :key nil)))
+ (and (equal nomodif x) y))
+ '(z b c z b d z c b z e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :count 100)))
+ (and (equal nomodif x) y))
+ '(z b c z b d z c b z e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :count 0)))
+ (and (equal nomodif x) y))
+ '(a b c a b d a c b a e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :count 1)))
+ (and (equal nomodif x) y))
+ '(z b c a b d a c b a e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'c x :count 1)))
+ (and (equal nomodif x) y))
+ '(a b z a b d a c b a e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :from-end t)))
+ (and (equal nomodif x) y))
+ '(z b c z b d z c b z e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :from-end t :count 1)))
+ (and (equal nomodif x) y))
+ '(a b c a b d a c b z e)))
+(Assert (equal (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif))
+ (y (substitute 'z 'a x :from-end t :count 4)))
+ (and (equal nomodif x) y))
+ '(z b c z b d z c b z e)))
+(Assert (equal (multiple-value-list
+ (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif)))
+ (values
+ (loop for i from 0 to 10
+ collect (substitute 'z 'a x :start i))
+ (equal nomodif x))))
+ '(((z b c z b d z c b z e) (a b c z b d z c b z e)
+ (a b c z b d z c b z e) (a b c z b d z c b z e)
+ (a b c a b d z c b z e) (a b c a b d z c b z e)
+ (a b c a b d z c b z e) (a b c a b d a c b z e)
+ (a b c a b d a c b z e) (a b c a b d a c b z e)
+ (a b c a b d a c b a e))
+ t)))
+(Assert (equal (multiple-value-list
+ (let* ((nomodif '(a b c a b d a c b a e))
+ (x (copy-list nomodif)))
+ (values
+ (loop for i from 0 to 10
+ collect (substitute 'z 'a x :start i :end nil))
+ (equal nomodif x))))
+ '(((z b c z b d z c b z e) (a b c z b d z c b z e)
+ (a b c z b d z c b z e) (a b c z b d z c b z e)
+ (a b c a b d z c b z e) (a b c a b d z c b z e)
+ (a b c a b d z c b z e) (a b c a b d a c b z e)
+ (a b c a b d a c b z e) (a b c a b d a c b z e)
+ (a b c a b d a c b a e))
+ t)))
+(Assert (equal
+ (let* ((nomodif '(1 2 3 2 6 1 2 4 1 3 2 7))
+ (x (copy-list nomodif))
+ (y (substitute 300 1 x :key #'1-)))
+ (and (equal nomodif x) y))
+ '(1 300 3 300 6 1 300 4 1 3 300 7)))
+
;; Test labels and inlining.
(labels
((+ (&rest arguments)
--
‘Tramadol is further fed to cattle […] when working them […] (as draft
animals) so that the animals do not get tired quickly. …’
— Angewandte Chemie, Sept 2014, describing the social context of
(synthetic) tramadol having been found in Cameroon tree roots.
_______________________________________________
XEmacs-Patches mailing list
XEmacs-Patches(a)xemacs.org
http://lists.xemacs.org/mailman/listinfo/xemacs-patches
- 1 participants
- 0 comments