From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Alan Mackenzie Newsgroups: gmane.emacs.bugs Subject: bug#66912: With `require', the byte compiler reports the wrong file for errors. Date: Sun, 3 Nov 2024 22:34:58 +0000 Message-ID: References: Mime-Version: 1.0 Content-Type: text/plain; charset=us-ascii Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="14601"; mail-complaints-to="usenet@ciao.gmane.io" Cc: acm@muc.de, 66912@debbugs.gnu.org To: Stefan Monnier Original-X-From: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Sun Nov 03 23:36:19 2024 Return-path: Envelope-to: geb-bug-gnu-emacs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1t7jCk-0003aR-OQ for geb-bug-gnu-emacs@m.gmane-mx.org; Sun, 03 Nov 2024 23:36:18 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1t7jCX-0001Ig-8C; Sun, 03 Nov 2024 17:36:05 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1t7jCU-0001IK-R6 for bug-gnu-emacs@gnu.org; Sun, 03 Nov 2024 17:36:02 -0500 Original-Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1t7jCU-0000cr-IC for bug-gnu-emacs@gnu.org; Sun, 03 Nov 2024 17:36:02 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=From:In-Reply-To:MIME-Version:References:Date:To:Subject; bh=tuzkvH+vSKfrgPNC9uexr1n0qUqIz9WVTUGv04mdRMY=; b=pdSJ4aZL276pzi6g+mUOs9Vgb9xKZ8+m+dJI3jsRCoM4KBCznyDXvriKsH5P0RyZ2jjJ6MgxAnflLUcOGtenJNb4MaI6Q+tsBbtRjPkfcO5iNFemmH4szSMe4oWyhzepX5hMgrJ53TMbjX1Il6RC6wjf/1tQQVfq6i4LAw5YW/pchhd297Blu7Efnlhyut81CsHdgqVoa+qLnYuFRglLBW7lC/zlCAeIGQuSugl4uO2GXJ5m0DpEHoDUKtyS3l3yUAxHXchvx5pRSsBdjX6+WxbKXjgYNWUroON5cSDutOJPko4Q/7+wiGW0GWaqb67HMtNXkVISTvyLB4TTroYkOA==; Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1t7jCU-0008IP-C1 for bug-gnu-emacs@gnu.org; Sun, 03 Nov 2024 17:36:02 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Alan Mackenzie Original-Sender: "Debbugs-submit" Resent-CC: bug-gnu-emacs@gnu.org Resent-Date: Sun, 03 Nov 2024 22:36:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 66912 X-GNU-PR-Package: emacs Original-Received: via spool by 66912-submit@debbugs.gnu.org id=B66912.173067331231853 (code B ref 66912); Sun, 03 Nov 2024 22:36:02 +0000 Original-Received: (at 66912) by debbugs.gnu.org; 3 Nov 2024 22:35:12 +0000 Original-Received: from localhost ([127.0.0.1]:35322 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t7jBe-0008Hf-Pg for submit@debbugs.gnu.org; Sun, 03 Nov 2024 17:35:12 -0500 Original-Received: from mail.muc.de ([193.149.48.3]:56666) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1t7jBb-0008BU-PJ for 66912@debbugs.gnu.org; Sun, 03 Nov 2024 17:35:09 -0500 Original-Received: (qmail 49803 invoked by uid 3782); 3 Nov 2024 23:35:00 +0100 Original-Received: from muc.de (pd953a0dd.dip0.t-ipconnect.de [217.83.160.221]) (using STARTTLS) by colin.muc.de (tmda-ofmipd) with ESMTP; Sun, 03 Nov 2024 23:34:59 +0100 Original-Received: (qmail 24972 invoked by uid 1000); 3 Nov 2024 22:34:58 -0000 Content-Disposition: inline In-Reply-To: X-Submission-Agent: TMDA/1.3.x (Ph3nix) X-Primary-Address: acm@muc.de X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-gnu-emacs@gnu.org List-Id: "Bug reports for GNU Emacs, the Swiss army knife of text editors" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Original-Sender: bug-gnu-emacs-bounces+geb-bug-gnu-emacs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.bugs:294823 Archived-At: Hello, Stefan. I have a first version of a patch for this. Please see below. On Sat, Nov 02, 2024 at 10:51:46 -0400, Stefan Monnier wrote: > > I don't think we need either. In lread.c, there is already a static > > variable Vloads_in_progress (which despite the name, is not visible in > > Lisp). This variable is a stack of the file names currently being > > loaded. We could surely just use this, and avoid code duplication. > In that case we don't need `handler-bind` at all, and we just tack the > info when we build the error object in `Fsignal`. I've actually made a copy of Vloads_in_progress to Vloads_still_in_progress, a variable which isn't bound, hence whose binding won't get lost in an error situation. I'm not convinced we need both of these, though. > But I don't think it would be correct in all cases: if file A loads file > B which compiles file C which loads file D which signals an error we > want the compiler error message to say "error in D loaded from C" and > not "error in D loaded from C loaded from B loaded from A". Currently, my messages are "While loading foo.el... While loading bar.el... While loading baz.el...\n. [ .... ] > > I've been working out details in the last two or three days. I actually > > think the handler should exit with a (throw 'exit t). That's because ... > What/where would be the matching `catch`? I actually put in a (throw 'top-level t) on exit from the debugger. > I don't think the `handler-bind` we'd add to `load` should make > assumptions about how/where the errors will be handled. The handler-bind handler I've added calls the debugger if debug-on-error is non-nil. Otherwise it just exits, letting something else handle the error. [ .... ] > > We should respect any user setting of debug-on-error to anything > > non-nil. If non-nil, we should enter the debugger within the > > handler-bind's handler, so as to have access to Emacs's state when > > the error occurred. > I think we should do nothing special about `debug-on-error` and let it > be handled by the existing code: it should "just work". Well, I've done something special with it, as I proposed. [ .... ] > > Also, this will prevent the byte compiler having (eq > > byte-compile-debug nil) subverting the call of the debugger. > > After all, when loading a file, we're not actually in the byte > > compiler, so byte-compile-debug shouldn't have an effect. > That would be nice. Not sure how easy to do it, OTOH. It's done. :-) Please see my patch. [ .... ] > >> In any case, it should be easy to try out and change from one to the > >> other with very local changes (I'd expect that the code of the handlers > >> will be written in ELisp rather than C, right?). So either way is fine. > > No, I think the handler code should be in C. The function handler-bind-1 > > seems very clumsy for use from C code. It requires a function with no > > parameters, so this would likely involve creating a closure in the C > > code. This isn't good. > I was talking about the code of the handlers. I.e. the one we push > along with the HANDLER_BIND entry. I'd build the handler by calling to > ELisp code (indeed, building closures from C is not good). I've extended the handler-bind mechanism to enable handlers to be written in C. They have the advantage that there is no minimum amount of Lisp which needs to be loaded before the error handler can report a problem with nested requires. Anyhow, here's the patch (first version). Please let me know what you think. Thanks! diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index f058fc48cc7..776083468c6 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -1436,8 +1436,9 @@ byte-compile-report-error when printing the error message." (setq byte-compiler-error-flag t) (byte-compile-log-warning - (if (stringp error-info) error-info - (error-message-string error-info)) + (prefix-load-file-names + (if (stringp error-info) error-info + (error-message-string error-info))) fill :error)) ;;; sanity-checking arglists diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index ec947c1215d..d49ebb20fd8 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -426,8 +426,10 @@ debugger--insert-header ;; User calls debug directly. (_ (insert ": ") - (insert (backtrace-print-to-string (if (eq (car args) 'nil) - (cdr args) args))) + (insert + (prefix-load-file-names + (backtrace-print-to-string (if (eq (car args) 'nil) + (cdr args) args)))) (insert ?\n)))) diff --git a/src/eval.c b/src/eval.c index d0a2abf0089..8f95bd4d263 100644 --- a/src/eval.c +++ b/src/eval.c @@ -1581,20 +1581,77 @@ internal_lisp_condition_case (Lisp_Object var, Lisp_Object bodyform, } /* Call the function BFUN with no arguments, catching errors within it - according to HANDLERS. If there is an error, call HFUN with - one argument which is the data that describes the error: + according to HANDLERTYPE and HANDLERS. If there is an error, call + HFUN with one argument which is the data that describes the error: (SIGNALNAME . DATA) + HANDLERTYPE must be either CONDITION_CASE or HANDLER_BIND. + HANDLERS can be a list of conditions to catch. If HANDLERS is Qt, catch all errors. If HANDLERS is Qerror, catch all errors but allow the debugger to run if that is enabled. */ +static Lisp_Object +internal_cc_hb (enum handlertype handlertype, + Lisp_Object (*bfun) (void), Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, handlertype); + + if (handlertype == HANDLER_BIND) + { + c->val = Qnil; + c->bin_handler = hfun; + c->bytecode_dest = 0; + } + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + Lisp_Object internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { - struct handler *c = push_handler (handlers, CONDITION_CASE); + return internal_cc_hb (CONDITION_CASE, bfun, handlers, hfun); +} + +Lisp_Object +internal_handler_bind (Lisp_Object (*bfun) (void), Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + if (NILP (Flistp (handlers))) + handlers = Fcons (handlers, Qnil); + return internal_cc_hb (HANDLER_BIND, bfun, handlers, hfun); +} + +/* Like internal_cc_hb but call BFUN with ARG as its argument. */ + +static Lisp_Object +internal_cc_hb_1 (enum handlertype handlertype, + Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, handlertype); + if (handlertype == HANDLER_BIND) + { + c->val = Qnil; + c->bin_handler = hfun; + c->bytecode_dest = 0; + } if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; @@ -1604,21 +1661,49 @@ internal_condition_case (Lisp_Object (*bfun) (void), Lisp_Object handlers, } else { - Lisp_Object val = bfun (); + Lisp_Object val = bfun (arg); eassert (handlerlist == c); handlerlist = c->next; return val; } } -/* Like internal_condition_case but call BFUN with ARG as its argument. */ - Lisp_Object internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { - struct handler *c = push_handler (handlers, CONDITION_CASE); + return internal_cc_hb_1 (CONDITION_CASE, bfun, arg, handlers, hfun); +} + +Lisp_Object +internal_handler_bind_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + if (NILP (Flistp (handlers))) + handlers = Fcons (handlers, Qnil); + return internal_cc_hb_1 (HANDLER_BIND, bfun, arg, handlers, hfun); +} + +/* Like internal_cc_hb_1 but call BFUN with ARG1 and ARG2 as + its arguments. */ + +static Lisp_Object +internal_cc_hb_2 (enum handlertype handlertype, + Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), + Lisp_Object arg1, + Lisp_Object arg2, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, handlertype); + if (handlertype == HANDLER_BIND) + { + c->val = Qnil; + c->bin_handler = hfun; + c->bytecode_dest = 0; + } if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; @@ -1628,16 +1713,13 @@ internal_condition_case_1 (Lisp_Object (*bfun) (Lisp_Object), Lisp_Object arg, } else { - Lisp_Object val = bfun (arg); + Lisp_Object val = bfun (arg1, arg2); eassert (handlerlist == c); handlerlist = c->next; return val; } } -/* Like internal_condition_case_1 but call BFUN with ARG1 and ARG2 as - its arguments. */ - Lisp_Object internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), Lisp_Object arg1, @@ -1645,7 +1727,38 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), Lisp_Object handlers, Lisp_Object (*hfun) (Lisp_Object)) { - struct handler *c = push_handler (handlers, CONDITION_CASE); + return internal_cc_hb_2 (CONDITION_CASE, bfun, arg1, arg2, handlers, hfun); +} + +Lisp_Object +internal_handler_bind_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), + Lisp_Object arg1, + Lisp_Object arg2, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + if (NILP (Flistp (handlers))) + handlers = Fcons (handlers, Qnil); + return internal_cc_hb_2 (HANDLER_BIND, bfun, arg1, arg2, handlers, hfun); +} + +/* Like internal_cc_hb_2 but the second argument is an arbitrary pointer. */ + +static Lisp_Object +internal_cc_hb_1_voidstar (enum handlertype handlertype, + Lisp_Object (*bfun) (Lisp_Object, void *), + Lisp_Object arg1, + void *arg2, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + struct handler *c = push_handler (handlers, handlertype); + if (handlertype == HANDLER_BIND) + { + c->val = Qnil; + c->bin_handler = hfun; + c->bytecode_dest = 0; + } if (sys_setjmp (c->jmp)) { Lisp_Object val = handlerlist->val; @@ -1662,6 +1775,30 @@ internal_condition_case_2 (Lisp_Object (*bfun) (Lisp_Object, Lisp_Object), } } +Lisp_Object +internal_condition_case_1_voidstar (Lisp_Object (*bfun) (Lisp_Object, void *), + Lisp_Object arg1, + void *arg2, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + return internal_cc_hb_1_voidstar (CONDITION_CASE, bfun, arg1, arg2, + handlers, hfun); +} + +Lisp_Object +internal_handler_bind_1_voidstar (Lisp_Object (*bfun) (Lisp_Object, void *), + Lisp_Object arg1, + void *arg2, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object)) +{ + if (NILP (Flistp (handlers))) + handlers = Fcons (handlers, Qnil); + return internal_cc_hb_1_voidstar (HANDLER_BIND, bfun, arg1, arg2, + handlers, hfun); +} + /* Like internal_condition_case but call BFUN with NARGS as first, and ARGS as second argument. */ @@ -1691,6 +1828,35 @@ internal_condition_case_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), } } +Lisp_Object +internal_handler_bind_n (Lisp_Object (*bfun) (ptrdiff_t, Lisp_Object *), + ptrdiff_t nargs, + Lisp_Object *args, + Lisp_Object handlers, + Lisp_Object (*hfun) (Lisp_Object err)) +{ + struct handler *c = push_handler (handlers, HANDLER_BIND); + { + c->val = Qnil; + c->bin_handler = hfun; + c->bytecode_dest = 0; + } + if (sys_setjmp (c->jmp)) + { + Lisp_Object val = handlerlist->val; + clobbered_eassert (handlerlist == c); + handlerlist = handlerlist->next; + return hfun (val); + } + else + { + Lisp_Object val = bfun (nargs, args); + eassert (handlerlist == c); + handlerlist = c->next; + return val; + } +} + static Lisp_Object Qcatch_all_memory_full; /* Like a combination of internal_condition_case_1 and internal_catch. @@ -1900,9 +2066,12 @@ signal_or_quit (Lisp_Object error_symbol, Lisp_Object data, bool continuable) max_ensure_room (20); push_handler (make_fixnum (skip + h->bytecode_dest), SKIP_CONDITIONS); - call1 (h->val, error); - unbind_to (count, Qnil); - pop_handler (); + if (NILP (h->val)) + (h->bin_handler) (error); + else + call1 (h->val, error); + unbind_to (count, Qnil); /* Removes SKIP_CONDITIONS handler. */ + pop_handler (); /* Discards HANDLER_BIND handler. */ } continue; } diff --git a/src/keyboard.c b/src/keyboard.c index 6d28dca9aeb..6758c328038 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -1096,7 +1096,7 @@ DEFUN ("command-error-default-function", Fcommand_error_default_function, Fdiscard_input (); bitch_at_user (); } - + context = Fprefix_load_file_names (context); print_error_message (data, Qt, SSDATA (context), signal); } return Qnil; diff --git a/src/lisp.h b/src/lisp.h index 5ef97047f76..205a5aa747b 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3870,7 +3870,9 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) 'val' holds the retval during longjmp. */ HANDLER_BIND, /* Entry for 'handler-bind'. 'tag_or_ch' holds the list of conditions. - 'val' holds the handler function. + `val', if non-nil, holds the Lisp handler + function. If nil, the handler function + is a C function held in `bin_handler'. The rest of the handler is unused, except for 'bytecode_dest' that holds the number of preceding HANDLER_BIND @@ -3920,6 +3922,7 @@ record_in_backtrace (Lisp_Object function, Lisp_Object *args, ptrdiff_t nargs) struct bc_frame *act_rec; int poll_suppress_count; int interrupt_input_blocked; + Lisp_Object (*bin_handler) (Lisp_Object); /* Used only for HANDLER_BIND. */ #ifdef HAVE_X_WINDOWS int x_error_handler_depth; @@ -4873,11 +4876,19 @@ xsignal (Lisp_Object error_symbol, Lisp_Object data) extern Lisp_Object internal_catch (Lisp_Object, Lisp_Object (*) (Lisp_Object), Lisp_Object); extern Lisp_Object internal_lisp_condition_case (Lisp_Object, Lisp_Object, Lisp_Object); extern Lisp_Object internal_condition_case (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_handler_bind (Lisp_Object (*) (void), Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_handler_bind_1 (Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_handler_bind_2 (Lisp_Object (*) (Lisp_Object, Lisp_Object), Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_condition_case_1_voidstar (Lisp_Object (*) (Lisp_Object, void*), Lisp_Object, void *, Lisp_Object, Lisp_Object (*) (Lisp_Object)); +extern Lisp_Object internal_handler_bind_1_voidstar (Lisp_Object (*) (Lisp_Object, void *), Lisp_Object, void *, Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_condition_case_n (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, Lisp_Object, Lisp_Object (*) (Lisp_Object, ptrdiff_t, Lisp_Object *)); +extern Lisp_Object internal_handler_bind_n + (Lisp_Object (*) (ptrdiff_t, Lisp_Object *), ptrdiff_t, Lisp_Object *, + Lisp_Object, Lisp_Object (*) (Lisp_Object)); extern Lisp_Object internal_catch_all (Lisp_Object (*) (void *), void *, Lisp_Object (*) (enum nonlocal_exit, Lisp_Object)); extern struct handler *push_handler (Lisp_Object, enum handlertype) ATTRIBUTE_RETURNS_NONNULL; diff --git a/src/lread.c b/src/lread.c index ea0398196e3..2fb407d9948 100644 --- a/src/lread.c +++ b/src/lread.c @@ -234,8 +234,10 @@ #define USE_ANDROID_ASSETS /* A list of file names for files being loaded in Fload. Used to check for recursive loads. */ - static Lisp_Object Vloads_in_progress; +/* The same as the above, except it survives the unbinding done in the + event of an error, and can thus be used in error handling. */ +Lisp_Object Vloads_still_in_progress; static int read_emacs_mule_char (int, int (*) (int, Lisp_Object), Lisp_Object); @@ -1271,6 +1273,51 @@ close_file_unwind_android_fd (void *ptr) #endif +/* Call readevalloop inside a `handler-bind' form. */ +static Lisp_Object +load_readevalloop (Lisp_Object hist_file_name, struct infile *input) +{ + readevalloop (Qget_file_char, input, hist_file_name, + 0, Qnil, Qnil, Qnil, Qnil); + return Qnil; +} + +DEFUN ("prefix-load-file-names", Fprefix_load_file_names, + Sprefix_load_file_names, 1, 1, 0, + doc: /* Prefix the string BASE_STRING with a message about each +file currently being loaded. Return the resulting string and reset this +information to null. */) + (Lisp_Object base_string) +{ + Lisp_Object result = build_string (""); + Lisp_Object while_loading = build_string ("While loading "); + Lisp_Object ellipsis = build_string ("... "); + + while (!NILP (Vloads_still_in_progress)) + { + result = concat2 (concat3 (while_loading, + Fcar (Vloads_still_in_progress), + ellipsis), + result); + Vloads_still_in_progress = Fcdr (Vloads_still_in_progress); + } + result = concat3 (result, build_string ("\n"), base_string); + return result; +} + +/* Handle errors signalled by the above function. */ +static Lisp_Object +rel_error_handler (Lisp_Object err) +{ + if (!NILP (Vdebug_on_error)) + { + call_debugger (err); + Fthrow (Qtop_level, Qt); + } + else + return err; +} + DEFUN ("load", Fload, Sload, 1, 5, 0, doc: /* Execute a file of Lisp code named FILE. First try FILE with `.elc' appended, then try with `.el', then try @@ -1516,6 +1563,7 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, signal_error ("Recursive load", Fcons (found, Vloads_in_progress)); record_unwind_protect (record_load_unwind, Vloads_in_progress); Vloads_in_progress = Fcons (found, Vloads_in_progress); + Vloads_still_in_progress = Vloads_in_progress; } /* All loads are by default dynamic, unless the file itself specifies @@ -1606,16 +1654,25 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, if (!NILP (Vload_source_file_function)) { Lisp_Object val; + Lisp_Object args[5]; if (lread_fd_p) { lread_close (fd); clear_unwind_protect (fd_index); } - val = call4 (Vload_source_file_function, found, hist_file_name, - NILP (noerror) ? Qnil : Qt, - (NILP (nomessage) || force_load_messages) ? Qnil : Qt); - return unbind_to (count, val); + args[0] = Vload_source_file_function; + args[1] = found; + args[2] = hist_file_name; + args[3] = NILP (noerror) ? Qnil : Qt; + args[4] = (NILP (nomessage) || force_load_messages) ? Qnil : Qt; + val = internal_handler_bind_n (Ffuncall, + 5, args, + Qerror, + rel_error_handler); + unbind_to (count, Qnil); + Vloads_still_in_progress = Vloads_in_progress; + return val; } } @@ -1724,8 +1781,11 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, Fset (Qlexical_binding, Qt); if (! version || version >= 22) - readevalloop (Qget_file_char, &input, hist_file_name, - 0, Qnil, Qnil, Qnil, Qnil); + internal_handler_bind_1_voidstar + ((Lisp_Object (*) (Lisp_Object, void *)) load_readevalloop, + hist_file_name, + &input, + Qerror, rel_error_handler); else { /* We can't handle a file which was compiled with @@ -1741,6 +1801,8 @@ DEFUN ("load", Fload, Sload, 1, 5, 0, if (!NILP (Ffboundp (Qdo_after_load_evaluation))) call1 (Qdo_after_load_evaluation, hist_file_name) ; + Vloads_still_in_progress = Vloads_in_progress; + for (int i = 0; i < ARRAYELTS (saved_strings); i++) { xfree (saved_strings[i].string); @@ -5772,6 +5834,7 @@ init_lread (void) Vload_true_file_name = Qnil; Vstandard_input = Qt; Vloads_in_progress = Qnil; + Vloads_still_in_progress = Qnil; } /* Print a warning that directory intended for use USE and with name @@ -5819,6 +5882,7 @@ syms_of_lread (void) defsubr (&Sintern_soft); defsubr (&Sunintern); defsubr (&Sget_load_suffixes); + defsubr (&Sprefix_load_file_names); defsubr (&Sload); defsubr (&Seval_buffer); defsubr (&Seval_region); @@ -6138,6 +6202,8 @@ syms_of_lread (void) Vloads_in_progress = Qnil; staticpro (&Vloads_in_progress); + Vloads_still_in_progress = Qnil; + staticpro (&Vloads_still_in_progress); DEFSYM (Qhash_table, "hash-table"); DEFSYM (Qdata, "data"); > Stefan -- Alan Mackenzie (Nuremberg, Germany).