From b406e44c679587294c439c8a77c0f5166f0ba591 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Fri, 28 Feb 2025 10:46:47 +0100 Subject: [PATCH] New macro 'case' --- lisp/emacs-lisp/cl-macs.el | 62 ++------------------------------------ lisp/emacs-lisp/scope.el | 36 +++++++++++----------- lisp/subr.el | 58 +++++++++++++++++++++++++++++++++++ 3 files changed, 77 insertions(+), 79 deletions(-) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index a1c34fa01e7..631853ba92c 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -789,65 +789,7 @@ The result of the body appears to the compiler as a quoted constant." ;;; Conditional control structures. ;;;###autoload -(defmacro cl-case (expr &rest clauses) - "Eval EXPR and choose among clauses on that value. -Each clause looks like (KEYLIST BODY...). EXPR is evaluated and -compared against each key in each KEYLIST; the corresponding BODY -is evaluated. If no clause succeeds, this macro returns nil. A -single non-nil atom may be used in place of a KEYLIST of one -atom. A KEYLIST of t or `otherwise' is allowed only in the final -clause, and matches if no other keys match. Key values are -compared by `eql'. - -\(fn EXPR (KEYLIST BODY...)...)" - (declare (indent 1) (debug (form &rest (sexp body)))) - (macroexp-let2 macroexp-copyable-p temp expr - (let* ((head-list nil) - (has-otherwise nil)) - `(cond - ,@(mapcar - (lambda (c) - (cons (cond (has-otherwise - (macroexp-warn-and-return - "Preceding catch-all clause shadows this clause" - nil 'suspicious nil (car c))) - ((memq (car c) '(t otherwise)) (setq has-otherwise t)) - ((eq (car c) 'cl--ecase-error-flag) - `(error "cl-ecase failed: %s, %s" - ,temp ',(reverse head-list))) - ((null (car c)) - (macroexp-warn-and-return - "Case nil will never match" - nil 'suspicious)) - ((and (consp (car c)) (cdar c) (not (cddar c)) - (memq (caar c) '(quote function))) - (macroexp-warn-and-return - (format-message - (concat "This clause matches `%s' and `%s'. " - "If that's intended, write %s instead. " - "Otherwise, don't quote `%s'.") - (caar c) (cadar c) (list (cadar c) (caar c)) - (cadar c)) - `(cl-member ,temp ',(car c)) 'suspicious - nil (car c))) - ((listp (car c)) - (if (cl-subsetp (car c) head-list) - (macroexp-warn-and-return - (concat "All keys covered by preceding cases, " - "this clause can never match") - nil 'suspicious nil (car c)) - (setq head-list (append (car c) head-list)) - `(cl-member ,temp ',(car c)))) - (t - (if (memq (car c) head-list) - (macroexp-warn-and-return - (format-message - "Duplicate key in case: %s" (car c)) - nil 'suspicious nil (car c)) - (push (car c) head-list) - `(eql ,temp ,(if (keywordp (car c)) (car c) `',(car c)))))) - (or (cdr c) '(nil)))) - clauses))))) +(defalias 'cl-case #'case) ;;;###autoload (defmacro cl-ecase (expr &rest clauses) @@ -855,7 +797,7 @@ compared by `eql'. `otherwise'-clauses are not allowed. \n(fn EXPR (KEYLIST BODY...)...)" (declare (indent 1) (debug cl-case)) - `(cl-case ,expr ,@clauses (cl--ecase-error-flag))) + `(case ,expr ,@clauses (t (error "`cl-ecase' failed, no matching clause")))) ;;;###autoload (defmacro cl-typecase (expr &rest clauses) diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 7bbde581bbc..27bcba46a7c 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -26,8 +26,6 @@ ;;; Code: -(eval-when-compile (require 'cl-lib)) - (defvar scope-counter nil) (defvar scope-local-functions nil) @@ -44,7 +42,7 @@ "Return new local context with SYM bound at POS. Optional argument LOCAL is a local context to extend." - (cons (cons sym (or pos (cons 'gen (cl-incf scope-counter)))) local)) + (cons (cons sym (or pos (cons 'gen (incf scope-counter)))) local)) (defsubst scope-sym-pos (sym) (when (symbol-with-pos-p sym) (symbol-with-pos-pos sym))) @@ -151,7 +149,7 @@ Optional argument LOCAL is a local context to extend." (scope-report 'declaration (symbol-with-pos-pos head) (length (symbol-name bare)))) - (cl-case bare + (case bare (completion (scope-sharpquote local (cadr spec))) (interactive-only (when-let ((bare (scope-sym-bare (cadr spec))) @@ -745,7 +743,7 @@ Optional argument LOCAL is a local context to extend." (scope-widget-type-arguments-1 head args)))) (defun scope-widget-type-arguments-1 (head args) - (cl-case head + (case head ((list cons group vector choice radio set repeat checklist) (mapc #'scope-widget-type-1 args)) ((function-item) @@ -873,7 +871,7 @@ Optional argument LOCAL is a local context to extend." (progn (when-let ((beg (scope-sym-pos head))) (scope-report 'ampersand beg (length (symbol-name bare)))) - (cl-case bare + (case bare (&optional (scope-cl-lambda-optional local (cadr arglist) (cddr arglist) more body)) ((&rest &body) (scope-cl-lambda-rest local (cadr arglist) (cddr arglist) more body)) (&key (scope-cl-lambda-key local (cadr arglist) (cddr arglist) more body)) @@ -915,7 +913,7 @@ Optional argument LOCAL is a local context to extend." (progn (when-let ((beg (scope-sym-pos head))) (scope-report 'ampersand beg (length (symbol-name bare)))) - (cl-case bare + (case bare ((&rest &body) (scope-cl-lambda-rest l (cadr arglist) (cddr arglist) more body)) (&key (scope-cl-lambda-key l (cadr arglist) (cddr arglist) more body)) (&aux (scope-cl-lambda-aux l (cadr arglist) (cddr arglist) more body)))) @@ -939,7 +937,7 @@ Optional argument LOCAL is a local context to extend." (progn (when-let ((beg (scope-sym-pos head))) (scope-report 'ampersand beg (length (symbol-name bare)))) - (cl-case bare + (case bare (&key (scope-cl-lambda-key l (cadr arglist) (cddr arglist) more body)) (&aux (scope-cl-lambda-aux l (cadr arglist) (cddr arglist) more body)))) (scope-cl-lambda-1 l (car more) (cdr more) body)))) @@ -985,7 +983,7 @@ Optional argument LOCAL is a local context to extend." (progn (when-let ((beg (scope-sym-pos head))) (scope-report 'ampersand beg (length (symbol-name bare)))) - (cl-case bare + (case bare (&aux (scope-cl-lambda-aux l (cadr arglist) (cddr arglist) more body)) (&allow-other-keys (scope-cl-lambda-1 l (car more) (cdr more) body)))) (scope-cl-lambda-key l head (cdr arglist) more body)))) @@ -1031,7 +1029,7 @@ Optional argument LOCAL is a local context to extend." ((keywordp bkw))) (when-let ((beg (scope-sym-pos kw))) (scope-report 'constant beg (length (symbol-name bkw)))) - (cl-case bkw + (case bkw ((:init-value :keymap :after-hook :initialize) (scope-1 local (cadr body))) (:lighter (scope-mode-line-construct local (cadr body))) @@ -1089,7 +1087,7 @@ Optional argument LOCAL is a local context to extend." (mapc #'scope-mode-line-construct-1 format)) ((or (symbolp head) (symbol-with-pos-p head)) (scope-s nil head) - (cl-case (bare-symbol head) + (case (bare-symbol head) (:eval (scope-1 nil (cadr format))) (:propertize @@ -1197,7 +1195,7 @@ a (possibly empty) list of safe macros.") (while-let ((kw (car-safe args)) (bkw (scope-sym-bare kw)) ((keywordp bkw))) - (cl-case bkw + (case bkw (:type (when-let ((quoted (scope--unqoute (cadr args)))) (scope-widget-type-1 quoted))) (:group @@ -1209,7 +1207,7 @@ a (possibly empty) list of safe macros.") (while-let ((kw (car-safe args)) (bkw (scope-sym-bare kw)) ((keywordp bkw))) - (cl-case bkw + (case bkw (:group (when-let ((quoted (scope--unqoute (cadr args)))) (scope-report-s quoted 'group)))) (setq args (cddr args)))) @@ -1221,7 +1219,7 @@ a (possibly empty) list of safe macros.") (while-let ((kw (car-safe args)) (bkw (scope-sym-bare kw)) ((keywordp bkw))) - (cl-case bkw + (case bkw (:group (when-let ((q (scope--unqoute (cadr args)))) (scope-report-s q 'group)))) (setq args (cddr args)))) @@ -1286,12 +1284,12 @@ a (possibly empty) list of safe macros.") (scope-define-function-analyzer propertize (_string &rest props) (while props - (cl-case (scope-sym-bare (scope--unqoute (car props))) + (case (scope-sym-bare (scope--unqoute (car props))) ((face mouse-face) (when-let ((q (scope--unqoute (cadr props)))) (scope-face q)))) (setq props (cddr props)))) -(scope-define-function-analyzer eieio-defclass-internal (name superclasses slots options) +(scope-define-function-analyzer eieio-defclass-internal (name superclasses _ _) (when-let ((q (scope--unqoute name))) (scope-report-s q 'type)) (when-let ((q (scope--unqoute superclasses))) (dolist (sup q) (scope-report-s sup 'type)))) @@ -1307,7 +1305,7 @@ a (possibly empty) list of safe macros.") (while-let ((kw (car-safe args)) (bkw (scope-sym-bare kw)) ((keywordp bkw))) - (cl-case bkw + (case bkw (:type (when-let ((q (scope--unqoute (cadr args)))) (scope-widget-type-1 q))) (:args @@ -1467,7 +1465,7 @@ a (possibly empty) list of safe macros.") (scope-define-macro-analyzer setf (l &rest args) (scope-n l args)) -(dolist (sym '( pop push with-memoization cl-pushnew +(dolist (sym '( pop push with-memoization cl-pushnew incf decf ;; The following macros evaluate unsafe code. ;; Never expand them! static-if eval-when-compile eval-and-compile)) @@ -1489,7 +1487,7 @@ a (possibly empty) list of safe macros.") (scope-report-s f 'macro) (scope-1 l alist) (let ((scope-current-let-alist-form - (cons (or (scope-sym-pos f) (cons 'gen (cl-incf scope-counter))) + (cons (or (scope-sym-pos f) (cons 'gen (incf scope-counter))) (scope-sym-pos f)))) (scope-n l body))) diff --git a/lisp/subr.el b/lisp/subr.el index 87b4cbf1e8c..93e7e20dc5e 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -7192,4 +7192,62 @@ and return the value found in PLACE instead." (if (seq-empty-p arch) base (append base (list (expand-file-name arch "/usr/include")))))))))) +(defun subsetp (sub set) + "Return non-nil if all elements of SUB are also in SET." + (declare (important-return-value t)) + (catch 'ball (dolist (elem sub) (unless (memql elem set) (throw 'ball nil))))) + +(defmacro case (expr &rest clauses) + "Choose and execute one of CLAUSES based on the value of EXPR. +Each clause is a cons cell (VAL . BODY), if the value of EXPR is `eql' +to VAL then BODY executed. VAL can also be a list of values. A VAL of +t or `otherwise' matches any value. If no clause succeeds, return nil." + (declare (indent 1) (debug (form &rest (sexp body)))) + (macroexp-let2 macroexp-copyable-p temp expr + (let* ((head-list nil) + (has-otherwise nil)) + `(cond + ,@(mapcar + (lambda (c) + (cons (cond + (has-otherwise + (macroexp-warn-and-return + "Preceding catch-all clause shadows this clause" + nil 'suspicious nil (car c))) + ((memq (car c) '(t otherwise)) (setq has-otherwise t)) + ((null (car c)) + (macroexp-warn-and-return + "Case nil will never match" + nil 'suspicious)) + ((and (consp (car c)) (cdar c) (not (cddar c)) + (memq (caar c) '(quote function))) + (macroexp-warn-and-return + (format-message + (concat "This clause matches `%s' and `%s'. " + "If that's intended, write %s instead. " + "Otherwise, don't quote `%s'.") + (caar c) (cadar c) (list (cadar c) (caar c)) + (cadar c)) + `(memql ,temp ',(car c)) 'suspicious + nil (car c))) + ((listp (car c)) + (if (subsetp (car c) head-list) + (macroexp-warn-and-return + (concat "All keys covered by preceding cases, " + "this clause can never match") + nil 'suspicious nil (car c)) + (setq head-list (append (car c) head-list)) + `(memql ,temp ',(car c)))) + (t + (if (memq (car c) head-list) + (macroexp-warn-and-return + (format-message + "Duplicate key in case: %s" (car c)) + nil 'suspicious nil (car c)) + (push (car c) head-list) + `(eql ,temp ,(if (keywordp (car c)) (car c) + `',(car c)))))) + (or (cdr c) '(nil)))) + clauses))))) + ;;; subr.el ends here -- 2.39.5