;;; 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)
`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)
;;; Code:
-(eval-when-compile (require 'cl-lib))
-
(defvar scope-counter nil)
(defvar scope-local-functions nil)
"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)))
(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)))
(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)
(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))
(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))))
(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))))
(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))))
((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)))
(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
(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
(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))))
(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))))
(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))))
(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
(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))
(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)))
(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
projects / emacs.git / commitdiff