commit 986621ae1ff4d3cfad31adb20216f1f71ce0747c (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Tue Nov 12 23:12:07 2024 -0500 (with-peg-rules): Build proper `peg-function`s * lisp/progmodes/peg.el (with-peg-rules): Use the new (FUNC EXP) feature in `cl-labels`. diff --git a/lisp/progmodes/peg.el b/lisp/progmodes/peg.el index 0b069e95563..115f692a030 100644 --- a/lisp/progmodes/peg.el +++ b/lisp/progmodes/peg.el @@ -438,10 +438,9 @@ rulesets defined previously with `define-peg-ruleset'." (macroexpand-all `(cl-labels ,(mapcar (lambda (rule) - ;; FIXME: Use `peg--lambda' as well. `(,(peg--rule-id (car rule)) - () - ,(peg--translate-rule-body (car rule) (cdr rule)))) + (peg--lambda ',(cdr rule) () + ,(peg--translate-rule-body (car rule) (cdr rule))))) rules) ,@body) `((:peg-rules ,@(append rules (cdr ctx))) commit 79400f4f18b80cdde72eda86023e41a81d09a164 Author: Stefan Monnier Date: Tue Nov 12 22:58:53 2024 -0500 (cl-labels): Add support for (FUNC EXP) bindings (bug#59786) Allow `cl-labels` to use the same (FUNC EXP) bindings as were already added to `cl-flet` in Emacs-25. The Info doc (mistakenly) already documented this new feature. * lisp/emacs-lisp/cl-macs.el (cl--self-tco-on-form): New function. (cl-labels): Use it to add support for (FUNC EXP) bindings. * test/lisp/emacs-lisp/cl-macs-tests.el (cl-macs--labels): Add test for tail-recursive (FUNC EXP) bindings. diff --git a/etc/NEWS b/etc/NEWS index e63132efeda..c2dccec9548 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -236,6 +236,11 @@ modal editing packages. * Changes in Specialized Modes and Packages in Emacs 31.1 +** CL-Lib ++++ +*** 'cl-labels' now also accepts (FUNC EXP) bindings, like 'cl-flet'. +Such bindings make it possible to compute which function to bind to FUNC. + ** Whitespace --- diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index b37f744b175..65bc2cb9173 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2247,15 +2247,35 @@ Like `cl-flet' but the definitions can refer to previous ones. . ,optimized-body)) ,retvar))))))) +(defun cl--self-tco-on-form (var form) + ;; Apply self-tco to the function returned by FORM, assuming that + ;; it will be bound to VAR. + (pcase form + (`(function (lambda ,fargs . ,ebody)) form + (pcase-let* ((`(,decls . ,body) (macroexp-parse-body ebody)) + (`(,ofargs . ,obody) (cl--self-tco var fargs body))) + `(function (lambda ,ofargs ,@decls . ,obody)))) + (`(let ,bindings ,form) + `(let ,bindings ,(cl--self-tco-on-form var form))) + (`(if ,cond ,exp1 ,exp2) + `(if ,cond ,(cl--self-tco-on-form var exp1) + ,(cl--self-tco-on-form var exp2))) + (`(oclosure--fix-type ,exp1 ,exp2) + `(oclosure--fix-type ,exp1 ,(cl--self-tco-on-form var exp2))) + (_ form))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make local (recursive) function definitions. -BINDINGS is a list of definitions of the form (FUNC ARGLIST BODY...) where +BINDINGS is a list of definitions of the form either (FUNC EXP) +where EXP is a form that should return the function to bind to the +function name FUNC, or (FUNC ARGLIST BODY...) where FUNC is the function name, ARGLIST its arguments, and BODY the -forms of the function body. FUNC is defined in any BODY, as well +forms of the function body. FUNC is in scope in any BODY or EXP, as well as FORM, so you can write recursive and mutually recursive -function definitions. See info node `(cl) Function Bindings' for -details. +function definitions, with the caveat that EXPs are evaluated in sequence +and you cannot call a FUNC before its EXP has been evaluated. +See info node `(cl) Function Bindings' for details. \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -2273,18 +2293,16 @@ details. (unless (assq 'function newenv) (push (cons 'function #'cl--labels-convert) newenv)) ;; Perform self-tail call elimination. - (setq binds (mapcar - (lambda (bind) - (pcase-let* - ((`(,var ,sargs . ,sbody) bind) - (`(function (lambda ,fargs . ,ebody)) - (macroexpand-all `(cl-function (lambda ,sargs . ,sbody)) - newenv)) - (`(,ofargs . ,obody) - (cl--self-tco var fargs ebody))) - `(,var (function (lambda ,ofargs . ,obody))))) - (nreverse binds))) - `(letrec ,binds + `(letrec ,(mapcar + (lambda (bind) + (pcase-let* ((`(,var ,sargs . ,sbody) bind)) + `(,var ,(cl--self-tco-on-form + var (macroexpand-all + (if (null sbody) + sargs ;A (FUNC EXP) definition. + `(cl-function (lambda ,sargs . ,sbody))) + newenv))))) + (nreverse binds)) . ,(macroexp-unprogn (macroexpand-all (macroexp-progn body) diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index 3fabcbc50c9..4baf5428101 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -666,7 +666,15 @@ collection clause." (len4 (xs n) (cond (xs (cond (nil 'nevertrue) ((len4 (cdr xs) (1+ n))))) - (t n)))) + (t n))) + + ;; Tail calls through obstacles. + (len5 + (if (not (fboundp 'oclosure-lambda)) + #'ignore + (oclosure-lambda (accessor (type 'cl-macs-test) (slot 'length)) + (xs n) + (if xs (len5 (cdr xs) (1+ n)) n))))) (should (equal (len nil 0) 0)) (should (equal (len2 nil 0) 0)) (should (equal (len3 nil 0) 0)) @@ -675,11 +683,13 @@ collection clause." (should (equal (len2 list-42 0) 42)) (should (equal (len3 list-42 0) 42)) (should (equal (len4 list-42 0) 42)) + (should (equal (len5 list-42 0) 42)) ;; Should not bump into stack depth limits. (should (equal (len list-42k 0) 42000)) (should (equal (len2 list-42k 0) 42000)) (should (equal (len3 list-42k 0) 42000)) - (should (equal (len4 list-42k 0) 42000)))) + (should (equal (len4 list-42k 0) 42000)) + (should (equal (len5 list-42k 0) 42000)))) ;; Check that non-recursive functions are handled more efficiently. (should (pcase (macroexpand '(cl-labels ((f (x) (+ x 1))) (f 5))) commit a7400cb8810373b6d39347a5e0e1ac7152d3abd1 Author: Eli Zaretskii Date: Tue Nov 12 18:37:30 2024 +0200 ; * src/w32menu.c (w32_popup_dialog): Fix last change. diff --git a/src/w32menu.c b/src/w32menu.c index 4f57760dad2..92b4b9c6d3c 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -187,7 +187,7 @@ Lisp_Object w32_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) { #ifdef NTGUI_UNICODE - typedef int (WINAPI *WideCharToMultiByte_Proc)(UINT,DWORD,LPCSTR,int, + typedef int (WINAPI *MultiByteToWideChar_Proc)(UINT,DWORD,LPCSTR,int, LPWSTR, int); static MultiByteToWideChar_Proc pMultiByteToWideChar = MultiByteToWideChar; #endif /* NTGUI_UNICODE */ commit 77739d42ab2f728c61faa2fa8f6a521f9240881e Author: Eli Zaretskii Date: Tue Nov 12 18:35:50 2024 +0200 ; * src/w32menu.c (w32_popup_dialog): Fix last change (bug#74312). diff --git a/src/w32menu.c b/src/w32menu.c index b5f87ebb42c..4f57760dad2 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -187,8 +187,8 @@ Lisp_Object w32_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) { #ifdef NTGUI_UNICODE - typedef int (WINAPI *WideCharToMultiByte_Proc)(UINT,DWORD,LPCWSTR,int,LPSTR, - int,LPCSTR,LPBOOL); + typedef int (WINAPI *WideCharToMultiByte_Proc)(UINT,DWORD,LPCSTR,int, + LPWSTR, int); static MultiByteToWideChar_Proc pMultiByteToWideChar = MultiByteToWideChar; #endif /* NTGUI_UNICODE */ check_window_system (f); commit b54fa15ffbb959e97ea0b77bfeb9ae412a63b4e8 Author: Eli Zaretskii Date: Tue Nov 12 14:41:01 2024 +0200 Fix Cygw32 build * src/pdumper.c (dump_mm_heap_cb_release): Avoid NULL pointer dereference. * src/w32dwrite.c (INITGUID) [CYGWIN]: Don't define for Cygwin. * src/w32menu.c (w32_popup_dialog): Fix Cygw32 build. (Bug#74312) diff --git a/src/pdumper.c b/src/pdumper.c index c888b659dde..c0b36b1ca44 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -4853,11 +4853,14 @@ struct dump_memory_map_heap_control_block static void dump_mm_heap_cb_release (struct dump_memory_map_heap_control_block *cb) { - eassert (cb->refcount > 0); - if (--cb->refcount == 0) + if (cb) { - free (cb->mem); - free (cb); + eassert (cb->refcount > 0); + if (--cb->refcount == 0) + { + free (cb->mem); + free (cb); + } } } diff --git a/src/w32dwrite.c b/src/w32dwrite.c index 32e2644af2c..29f9d5f1fed 100644 --- a/src/w32dwrite.c +++ b/src/w32dwrite.c @@ -37,7 +37,7 @@ along with GNU Emacs. If not, see . */ #include #include -#ifndef MINGW_W64 +#if !defined MINGW_W64 && !defined CYGWIN # define INITGUID #endif #include @@ -659,7 +659,7 @@ w32_dwrite_encode_char (struct font *font, int c) if (dwrite_font_face == NULL) return FONT_INVALID_CODE; hr = dwrite_font_face->lpVtbl->GetGlyphIndices (dwrite_font_face, - &c, 1, &index); + (UINT32 *) &c, 1, &index); if (verify_hr (hr, "Failed to GetGlyphIndices")) { if (index == 0) diff --git a/src/w32menu.c b/src/w32menu.c index c3d147841b6..b5f87ebb42c 100644 --- a/src/w32menu.c +++ b/src/w32menu.c @@ -186,6 +186,11 @@ task_dialog_callback (HWND hwnd, UINT msg, WPARAM wParam, Lisp_Object w32_popup_dialog (struct frame *f, Lisp_Object header, Lisp_Object contents) { +#ifdef NTGUI_UNICODE + typedef int (WINAPI *WideCharToMultiByte_Proc)(UINT,DWORD,LPCWSTR,int,LPSTR, + int,LPCSTR,LPBOOL); + static MultiByteToWideChar_Proc pMultiByteToWideChar = MultiByteToWideChar; +#endif /* NTGUI_UNICODE */ check_window_system (f); if (task_dialog_indirect)