[PATCH] Annotate cons cells with buffer positions, lread.c

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