From 2f045c0043de702cda8bb686635b393a2ff9f2d8 Mon Sep 17 00:00:00 2001 From: akater Date: Tue, 21 Sep 2021 23:14:12 +0000 Subject: [PATCH] * lisp/emacs-lisp/cl-macs.el (cl-flet): Improved definition Fixes the following issues with cl-flet: - No error on illegal function names - No error on malformed specs - Incorrectly treated (setf ..) local functions - No warning on duplicated definitions - No warning on unused definitions - No way to capture definitions present in the body * lisp/emacs-lisp/cl-generic.el (cl--generic-with-memoization): Move definition to cl-macs * lisp/emacs-lisp/cl-macs.el (cl--expand-flet): New function for more robust cl-flet definition and more featureful expansion (cl--with-memoization): Move definition from cl-generic (cl--flet-convert-with-setf, cl--valid-function-name-symbol-p, cl--check-function-name, cl--valid-let-symbol-p, cl--call-flet-expander, cl--expand-local-setf): New function to accomodate cl--expand-flet (with--cl-flet-macroexp): New macro to accomodate cl--expand-flet (cl--flet-convert-with-setf-cache, cl--local-setf-expanders): New variable to accomodate cl--expand-flet --- lisp/emacs-lisp/cl-generic.el | 12 +- lisp/emacs-lisp/cl-macs.el | 335 +++++++++++++++++++++++++++++++--- 2 files changed, 317 insertions(+), 30 deletions(-) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 1640975b84..39e38e29fa 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -98,7 +98,7 @@ ;; usually be simplified, or even completely skipped. (eval-when-compile (require 'cl-lib)) -(eval-when-compile (require 'cl-macs)) ;For cl--find-class. +(eval-when-compile (require 'cl-macs)) ;For cl--find-class, with-memoization. (eval-when-compile (require 'pcase)) (cl-defstruct (cl--generic-generalizer @@ -589,7 +589,7 @@ defalias sym 'dummy)) ;Record definition into load-history. ;; e.g. for tracing/debug-on-entry. (defalias sym gfun))))) -(defmacro cl--generic-with-memoization (place &rest code) +(defmacro cl--with-memoization (place &rest code) (declare (indent 1) (debug t)) (gv-letplace (getter setter) place `(or ,getter @@ -601,7 +601,7 @@ defmacro cl--generic-with-memoization (place &rest code) (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) (defun cl--generic-get-dispatcher (dispatch) - (cl--generic-with-memoization + (cl--with-memoization (gethash dispatch cl--generic-dispatchers) ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) @@ -647,7 +647,7 @@ defun cl--generic-get-dispatcher (dispatch) (let ((method-cache (make-hash-table :test #'eql))) (lambda (,@fixedargs &rest args) (let ,bindings - (apply (cl--generic-with-memoization + (apply (cl--with-memoization (gethash ,tag-exp method-cache) (cl--generic-cache-miss generic ',dispatch-arg dispatches-left methods @@ -691,7 +691,7 @@ defun cl--generic-build-combined-method (generic methods) ;; Special case needed to fix a circularity during bootstrap. (cl--generic-standard-method-combination generic methods) (let ((f - (cl--generic-with-memoization + (cl--with-memoization ;; FIXME: Since the fields of `generic' are modified, this ;; hash-table won't work right, because the hashes will change! ;; It's not terribly serious, but reduces the effectiveness of @@ -1140,7 +1140,7 @@ defvar cl--generic-head-used (make-hash-table :test #'eql)) ;; since we can't use the `head' specializer to implement itself. (if (not (eq (car-safe specializer) 'head)) (cl-call-next-method) - (cl--generic-with-memoization + (cl--with-memoization (gethash (cadr specializer) cl--generic-head-used) specializer) (list cl--generic-head-generalizer))) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 6d6482c349..ecbe8e86fc 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2004,6 +2004,282 @@ defun cl--labels-convert (f) (setq cl--labels-convert-cache (cons f res)) res)))))) +(defvar cl--flet-convert-with-setf-cache nil + "Like `cl--labels-convert-cache' but for local setf functions.") + +(defun cl--flet-convert-with-setf (f) + "Special macro-expander to rename (function F) references in `cl-flet', including (function (setf F)). + +See also `cl--labels-convert'." + ;; Note: If this function, or `cl--labels-convert', for that matter, + ;; is redefined at runtime, + ;; the whole replacement mechanism breaks! + (if (and (consp f) (eq 'setf (car f))) + (cond + ;; We repeat lots of code from `cl--labels-convert' + ((eq (cadr f) (car cl--flet-convert-with-setf-cache)) + (cdr cl--flet-convert-with-setf-cache)) + (t + (let* ((found (assoc f macroexpand-all-environment #'equal)) + (replacement (and found + (ignore-errors + (funcall (cdr found) cl--labels-magic))))) + (if (and replacement (eq cl--labels-magic (car replacement))) + (nth 1 replacement) + (let ((res `(function ,f))) + (setq cl--flet-convert-with-setf-cache (cons (cadr f) res)) + res))))) + (cl--labels-convert f))) + +(defmacro cl--with-memoization (place &rest code) + (declare (indent 1) (debug t)) + (gv-letplace (getter setter) place + `(or ,getter + ,(macroexp-let2 nil val (macroexp-progn code) + `(progn + ,(funcall setter val) + ,val))))) + +(defun cl--valid-function-name-symbol-p (expr) + "If expr is a symbol permitted to be a function name, return non-nil. + +Otherwise, return nil." + (and (symbolp expr) (not (eq t expr)) expr)) + +(defun cl--check-function-name (expr) + "Signal error if EXPR is invalid function name. Otherwise, return nil." + (unless (or (cl--valid-function-name-symbol-p expr) + (and (consp expr) (eq 'setf (car expr)) + (consp (cdr expr)) + (symbolp (cadr expr)) + (null (cddr expr)))) + (error "Illegal function name: %s" expr))) + +(defun cl--valid-let-symbol-p (x) + "If X is a symbol permitted to be a variable in a let binding, return non-nil. + +Otherwise, return nil." + ;; Not nil, t, :keywords --- + ;; according to error message `Attempt to set a constant symbol' from `let' + ;; and description of SYMBOL_CONSTANT_P in data.c. + ;; + ;; Unfortunately we can't use symbol-constant-p directly. + (and (symbolp x) (not (or (null x) (eq t x) (keywordp x))))) + +(defun cl--call-flet-expander (expander function-name) + "Call flet expander EXPANDER for local function FUNCTION-NAME, +checking return value type." + (let ((binding-or-pseudo-binding (funcall expander))) + (unless (and (consp binding-or-pseudo-binding) + (or (cl--valid-let-symbol-p (car binding-or-pseudo-binding)) + (null (car binding-or-pseudo-binding))) + (consp (cdr binding-or-pseudo-binding)) + (null (cddr binding-or-pseudo-binding))) + (error "cl--expand-flet expander %s for local function %s returns illegal value: %s" + expander function-name binding-or-pseudo-binding)) + binding-or-pseudo-binding)) + +(defmacro with--cl-flet-macroexp ( arglist var + function-name expander memoized-alist + &rest body) + "Return lambda (with ARGLIST being its arglist) that can +serve as a macroexpanding function in +`macroexpand-all-environment' to expand local function calls of +the form (FUNCTION-NAME ..). + +The body of lambda will be BODY, with variable named VAR +implicitly bound to the return value of flet-expander EXPANDER, +retreived from the place MEMOIZED-ALIST if possible, and saved in +the place MEMOIZED-ALIST otherwise. + +MEMOIZED-ALIST is presumed to refer to an alist." + (declare (indent 5)) + (unless (proper-list-p arglist) + (error "Arglist is not a proper list: %s" arglist)) + (unless (cl--valid-let-symbol-p var) + (error "Can't be a `let' variable: %s" var)) + `(lambda ,arglist + (let ((,var + (let ((return-value + (cl--with-memoization (alist-get ,function-name + ,memoized-alist + nil nil #'equal) + (cl--call-flet-expander ,expander ,function-name)))) + (if (null (car return-value)) (cadr return-value) + (car return-value))))) + ,@body))) + +(defvar cl--local-setf-expanders nil + "Holds expanders for local non-generic setf functions. + +Holds the same data as flet-expanders-plist argument to +`cl--expand-flet', only this one is alist and its keys are F +rather than (setf F).") + +(defun cl--expand-local-setf (&rest places-and-values) + "Expand `(setf . ,PLACES-AND-VALUES) +according to `cl--local-setf-expanders'. + +Presumes the caller has `macroexpand-all-environment' bound." + (macroexp-progn + (cl-loop + for cons on places-and-values by #'cddr + for (place new) on places-and-values by #'cddr + as expander = nil + if (null (cdr cons)) + do (error "Odd number of arguments to setf: %s" + (cons 'setf places-and-values)) + else collect + (cond ((or (not (consp place)) + ;; Do not override local macros. + (assq (car place) macroexpand-all-environment)) + (macroexpand-all + (macroexpand-1 `(setf ,place ,new) + (remove '(setf . cl--expand-local-setf) + macroexpand-all-environment)) + macroexpand-all-environment)) + ((progn + (unless (proper-list-p (cdr place)) + (error "Malformed place: %s" place)) + (setq expander + (alist-get (car place) cl--local-setf-expanders + nil nil #'eq))) + (funcall expander place new)) + (t + (macroexpand-all + (macroexpand-1 `(setf ,place ,new) + (remove '(setf . cl--expand-local-setf) + macroexpand-all-environment)) + macroexpand-all-environment)))))) + +(defun cl--expand-flet (env body &rest flet-expanders-plist) + "Return a form equivalent to `(cl-flet ,bindings BODY) +where bindings correspond to FLET-EXPANDERS-PLIST as described below. + +ENV should be macroexpansion environment +to be augmented with some definitions from FLET-EXPANDERS-PLIST +to then expand forms in BODY with. + +FLET-EXPANDERS-PLIST should be a plist +where keys are function names +and values are 0-argument lambdas +to be called if the corresponding function name is encountered +in BODY and then only (that is, at most once). + +The return value of said lambdas should be either + +- a valid let-binding (SYMBOL function) to be used in let* + bindings over BODY so that SYMBOL could be used in place of the + corresponding function name in BODY + +or + +- a list (NIL EXPR) for EXPR to be used in BODY in place of the + corresponding function name as is. + +In case several identical function names are specified in +FLET-EXPANDERS-PLIST, the first one is used +(and a warning is issued). + +Note: ENV is not used as is, but is copied." + (declare (indent 2)) + (let ((cl--local-setf-expanders cl--local-setf-expanders) memoized-setf + memoized all-names) + (cl-loop + for cons on flet-expanders-plist by #'cddr + for (function-name expander) on flet-expanders-plist by #'cddr + if (null (cdr cons)) + do (error "Odd number of arguments to cl--expand-flet: %s" + (apply #'list 'cl--expand-flet env body flet-expanders-plist)) + else + do (cl--check-function-name function-name) + ;; TODO: Maybe allow t as a pseudo-function-name + ;; for unconditional code execution during macroexpansion. + (unless (cl-typep expander 'function) + (signal 'wrong-type-argument + (list 'function expander 'expander))) + (let ((seen (assoc function-name all-names + ;; Here and after, names may be symbols or conses. + #'equal))) + (if seen (cl-symbol-macrolet ((warned (cdr seen))) + (unless warned + (warn "Duplicate local function definition: %s" + function-name) + (setf warned t))) + (push (cons function-name nil) all-names) + ;; The last definition should be the effectual one. + ;; Our implementation presumes + ;; `cl--expand-flet' lists entries in reverse order + ;; compared to `cl-flet'. + ;; This makes implementations of `cl--expand-flet', `cl-flet' simpler + ;; while the difference in the interface + ;; only matters for incorrect or stylistically bad code + ;; so it shouldn't bother us. + (let ((f function-name) + ;; Don't capture loop's vars in lambdas below + ;; returned by `with--cl-flet-macroexp'. + (thunk expander)) + (if (not (and (consp function-name) + (eq 'setf (car function-name)))) + (push (cons function-name + (with--cl-flet-macroexp (&rest args) var + f thunk memoized + (if (eq (car args) cl--labels-magic) + (list cl--labels-magic var) + `(funcall ,var ,@args)))) + env) + (push (cons (cadr function-name) + (with--cl-flet-macroexp (place new) var + f thunk memoized-setf + ;; `gv' does the same but a gv-based implementation + ;; we could think of required advising function-get + ;; and advising is ugly. + ;; This is also more CL-self-contained. + (let ((new-gensym (let ((gensym-counter 0)) + (gensym "setf-arg-"))) + setf-args) + `(let (,@(let ((gensym-counter 1)) + (mapcar + (lambda (arg) + (let ((gensym + (gensym "setf-arg-"))) + (push gensym setf-args) + (list gensym arg))) + (cdr place))) + (,new-gensym ,new)) + (funcall ,var ,new-gensym + ,@(nreverse setf-args)))))) + cl--local-setf-expanders) + (push (cons function-name + (with--cl-flet-macroexp (&rest _args) var + f thunk + ;; TODO: memoized? + memoized-setf + (list cl--labels-magic var))) + ;; This is meant solely for `cl--flet-convert-with-setf'. + env)))))) + (let* ((macroexpanded-body + (let ((newenv (cons '(setf . cl--expand-local-setf) env))) + ;; TODO: Get rid of the newenv binding + ;; if the order of 'function and 'setf + ;; in the `macroxpand-all-environment' is not essential. + (macroexpand-all (macroexp-progn body) + (if (assq 'function newenv) newenv + (cons (cons 'function + #'cl--flet-convert-with-setf) + newenv))))) + (memoized (nconc memoized memoized-setf)) + (binds + ;; Preserve cdrs to use nset-difference below. + (mapcar #'cdr memoized))) + (dolist (missing (cl-nset-difference all-names memoized + :key #'car :test #'equal)) + (warn "Local function defined but is missing in body: %s" + (car missing))) + (macroexp-let* (cl-delete nil binds :key #'car :test #'eq) + macroexpanded-body)))) + + ;;;###autoload (defmacro cl-flet (bindings &rest body) "Make local function definitions. @@ -2027,30 +2303,41 @@ defmacro cl-flet (bindings &rest body) [&optional ("interactive" interactive)] def-body)]) cl-declarations body))) - (let ((binds ()) (newenv macroexpand-all-environment)) - (dolist (binding bindings) - (let ((var (make-symbol (format "--cl-%s--" (car binding)))) - (args-and-body (cdr binding))) - (if (and (= (length args-and-body) 1) (symbolp (car args-and-body))) - ;; Optimize (cl-flet ((fun var)) body). - (setq var (car args-and-body)) - (push (list var (if (= (length args-and-body) 1) - (car args-and-body) - `(cl-function (lambda . ,args-and-body)))) - binds)) - (push (cons (car binding) - (lambda (&rest args) - (if (eq (car args) cl--labels-magic) - (list cl--labels-magic var) - `(funcall ,var ,@args)))) - newenv))) - ;; FIXME: Eliminate those functions which aren't referenced. - (macroexp-let* (nreverse binds) - (macroexpand-all - `(progn ,@body) - ;; Don't override lexical-let's macro-expander. - (if (assq 'function newenv) newenv - (cons (cons 'function #'cl--labels-convert) newenv)))))) + (apply #'cl--expand-flet macroexpand-all-environment body + (let (flet-expanders-plist) + (dolist (binding bindings flet-expanders-plist) + (let (function-name args-and-body) + (unless (and (consp binding) + (proper-list-p + (setq args-and-body (cdr binding))) + args-and-body) + (error "The flet definition spec %s is malformed" binding)) + ;; Function name will be checked for correctness by expand-flet. + ;; TODO: Consider checking it right here to error earlier. + (setq function-name (car binding)) + ;; TODO: We push a quoted lambda form; + ;; maybe it's better to push a closure? + (push `(lambda () + ,(or (and (null (cdr args-and-body)) + (symbolp (car args-and-body)) + `(list nil ',(car args-and-body))) + (progn + (unless (listp (car args-and-body)) + (error "The lambda expression has a non-list lambda-list: %s" + (cons 'lambda args-and-body) + ;; TODO: When implicit cl-block is implemented, change this to + ;; `(lambda ,(car args-and-body) + ;; (cl-block ,function-name ,@(cdr args-and-body))) + ;; for consistency. + )) + `(list (make-symbol + (format "--cl-%s--" ',function-name)) + (list 'cl-function + (cons 'lambda + ;; TODO: Implement implicit cl-block + ',args-and-body)))))) + flet-expanders-plist) + (push function-name flet-expanders-plist)))))) ;;;###autoload (defmacro cl-flet* (bindings &rest body) -- 2.32.0