From 23c8fdd12686b6165c98af459507dda0ea28dc85 Mon Sep 17 00:00:00 2001 From: Eshel Yaron Date: Thu, 15 Aug 2024 20:38:49 +0200 Subject: [PATCH] scope.el: Expand unknown macros, regress a bit --- lisp/emacs-lisp/scope.el | 1719 +++++++++++++++++++------------------- 1 file changed, 856 insertions(+), 863 deletions(-) diff --git a/lisp/emacs-lisp/scope.el b/lisp/emacs-lisp/scope.el index 25ddef6123d..3b4530f46a6 100644 --- a/lisp/emacs-lisp/scope.el +++ b/lisp/emacs-lisp/scope.el @@ -22,10 +22,17 @@ ;; Scope analysis for Emacs Lisp. +;;; Todo: + +;; - Fix handling of generalized variables. +;; - Take callback argument instead of returning list. + ;;; Code: (eval-when-compile (require 'cl-lib)) +(defvar scope-counter nil) + (defsubst scope-local-get (sym local) "Get binding position of symbol SYM in local context LOCAL." (alist-get sym local)) @@ -34,60 +41,47 @@ "Return new local context with SYM bound at POS. Optional argument LOCAL is a local context to extend." - (cons (cons sym pos) local)) + (cons (cons sym (or pos (cons 'gen (cl-incf scope-counter)))) local)) + +(defsubst scope-sym-pos (sym) + (when (symbol-with-pos-p sym) (symbol-with-pos-pos sym))) (defun scope-s (local sym) - (let* ((beg (symbol-with-pos-pos sym)) + (let* ((beg (scope-sym-pos sym)) (bare (bare-symbol sym)) (len (length (symbol-name bare)))) - (unless (or (booleanp bare) (keywordp bare)) + (unless (or (booleanp bare) (keywordp bare) (null beg)) (list (list beg len (scope-local-get bare local)))))) +(defun scope-let-1 (local0 local bindings body) + (if bindings + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (bare-symbol sym)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos sym))) + (nconc + (when beg (list (list beg len beg))) + (scope-1 local0 (cadr binding)) + (scope-let-1 local0 (scope-local-new bare beg local) + (cdr bindings) body))) + (scope-n local body))) + (defun scope-let (local bindings body) - (nconc - (mapcan (lambda (binding) - (cond - ((consp binding) - (cons - (let* ((sym (car binding)) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym)) - (len (length (symbol-name bare)))) - (list beg len beg)) - (scope-1 local (cadr binding)))) - (binding - (let* ((sym binding) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym)) - (len (length (symbol-name bare)))) - (list (list beg len beg)))))) - bindings) - (let ((l local)) - (dolist (binding bindings) - (when-let ((sym (if (consp binding) (car binding) binding))) - (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l)))) - (scope-n l body)))) + (scope-let-1 local local bindings body)) (defun scope-let* (local bindings body) (if bindings - (let ((binding (car bindings))) + (let* ((binding (ensure-list (car bindings))) + (sym (car binding)) + (bare (bare-symbol sym)) + (len (length (symbol-name bare))) + (beg (scope-sym-pos sym))) (nconc - (if (consp binding) - (cons - (let* ((sym (car binding)) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym))) - (list beg (length (symbol-name bare)) beg)) - (scope-1 local (cadr binding))) - (let* ((sym binding) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym))) - (list (list beg (length (symbol-name bare)) beg)))) + (when beg (list (list beg len beg))) + (scope-1 local (cadr binding)) (scope-let* - (let ((sym (if (consp binding) (car binding) binding))) - (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) local)) - (cdr bindings) - body))) + (scope-local-new bare beg local) (cdr bindings) body))) (scope-n local body))) (defun scope-if-let* (local bindings body) @@ -97,46 +91,54 @@ Optional argument LOCAL is a local context to extend." (if (cdr binding) ;; BINDING is (SYMBOL VALUEFORM). (let* ((sym (car binding)) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym))) - (cons - (list beg (length (symbol-name bare)) beg) - (nconc (scope-1 local (cadr binding)) - (scope-if-let* (scope-local-new bare beg local) - (cdr bindings) body)))) + (bare (bare-symbol sym)) + (beg (scope-sym-pos sym))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (scope-1 local (cadr binding)) + (scope-if-let* (scope-local-new bare beg local) + (cdr bindings) body))) ;; BINDING is (VALUEFORM). (nconc (scope-1 local (car binding)) (scope-if-let* local (cdr bindings) body))) ;; BINDING is just SYMBOL. (let* ((sym binding) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym))) - (cons - (list beg (length (symbol-name bare)) beg) + (bare (bare-symbol sym)) + (beg (scope-sym-pos sym))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) (scope-if-let* (scope-local-new bare beg local) (cdr bindings) body))))) (scope-n local body))) (defun scope-if-let (local bindings body) (scope-if-let* local - (if (and (consp bindings) (symbol-with-pos-p (car bindings))) + (if (and (consp bindings) + (or (symbol-with-pos-p (car bindings)) + (symbolp (car bindings)))) (list bindings) bindings) body)) -(defun scope-defun (local _name args body) +(defun scope-lambda (local args body) (let ((int-spec nil) (doc-form nil)) (cond - ((and (consp (car body)) (symbol-with-pos-p (caar body)) + ((and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) (eq (bare-symbol (caar body)) :documentation)) (setq doc-form (cadar body)) (setq body (cdr body))) ((stringp (car body)) (setq body (cdr body)))) - (when (and (consp (car body)) (symbol-with-pos-p (caar body)) + (when (and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) (eq (bare-symbol (caar body)) 'declare)) (setq body (cdr body))) - (when (and (consp (car body)) (symbol-with-pos-p (caar body)) + (when (and (consp (car body)) + (or (symbol-with-pos-p (caar body)) + (symbolp (caar body))) (eq (bare-symbol (caar body)) 'interactive)) (setq int-spec (cadar body)) (setq body (cdr body))) @@ -153,270 +155,280 @@ Optional argument LOCAL is a local context to extend." (scope-1 local int-spec) (let ((l local)) (dolist (arg args) - (when (and (symbol-with-pos-p arg) (not (memq (bare-symbol arg) '(&optional &rest)))) - (setq l (scope-local-new (bare-symbol arg) (symbol-with-pos-pos arg) l)))) + (when-let ((bare (bare-symbol arg)) + (beg (scope-sym-pos arg))) + (unless (memq bare '(&optional &rest)) + (setq l (scope-local-new bare beg l))))) (scope-n l body))))) -(defun scope-defmethod-1 (local0 local name args body) - (if args - (let ((arg (car args))) - (cond - ((consp arg) - (let ((var (car arg)) - (spec (cadr arg))) - (cond - ((symbol-with-pos-p var) - (let* ((beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (nconc - (cond - ((consp spec) - (let ((head (car spec)) - (form (cadr spec))) - (and (symbol-with-pos-p head) - (eq 'eql (bare-symbol head)) - (not (or (symbolp form) (symbol-with-pos-p form))) - (scope-1 local0 form))))) - (scope-defmethod-1 local0 (scope-local-new bare beg local) name (cdr args) body))))) - ((consp var) - ;; VAR is (&key (VAR INIT SVAR)) or (&key VAR). - (let ((var (cadr var))) - (cond - ((symbol-with-pos-p var) - (let* ((beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (nconc - (cond - ((consp spec) - (let ((head (car spec)) - (form (cadr spec))) - (and (symbol-with-pos-p head) - (eq 'eql (bare-symbol head)) - (not (or (symbolp form) (symbol-with-pos-p form))) - (scope-1 local0 form))))) - (scope-defmethod-1 local0 (scope-local-new bare beg local) name (cdr args) body))))) - ((consp var) - (let* ((init (cadr var)) - (svar (caddr var)) - (var (car var)) - (beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (nconc - (scope-1 local0 init) - (when svar - (let ((sbeg (symbol-with-pos-pos svar))) - (list (list sbeg (length (symbol-name (bare-symbol svar))) - sbeg)))) - (scope-defmethod-1 - local0 - (scope-local-new bare beg - (if svar - (scope-local-new (bare-symbol svar) - (symbol-with-pos-pos svar) - local) - local)) - name (cdr args) body))))))))))) - ((symbol-with-pos-p arg) - (cond - ((memq (bare-symbol arg) '(&optional &rest &body _)) - (scope-defmethod-1 local0 local name (cdr args) body)) - ((eq (bare-symbol arg) '&context) - (let* ((expr-type (cadr args)) - (expr (car expr-type)) - (type (cadr expr-type)) - (more (cddr args))) - (nconc - (scope-1 local0 expr) - (cond - ((consp type) - (let ((head (car type)) - (form (cadr type))) - (and (symbol-with-pos-p head) - (eq 'eql (bare-symbol head)) - (not (or (symbolp form) (symbol-with-pos-p form))) - (scope-1 local0 form))))) - (scope-defmethod-1 local0 local name more body)))) - (t - (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (scope-defmethod-1 local0 (scope-local-new bare beg local) - name (cdr args) body)))))))) - (scope-n local body))) - -(defun scope-defmethod (local name rest) - (when (and (symbol-with-pos-p (car rest)) - (eq (bare-symbol (car rest)) :extra)) - (setq rest (cddr rest))) - (when (and (symbol-with-pos-p (car rest)) - (memq (bare-symbol (car rest)) '(:before :after :around))) - (setq rest (cdr rest))) - (scope-defmethod-1 local local name (car rest) - (if (stringp (cadr rest)) (cddr rest) (cdr rest)))) - -(defun scope-defgeneric-2 (local name args body) - (cond - ((and (consp (car body)) (symbol-with-pos-p (caar body)) - (memq (bare-symbol (caar body)) - '(declare :documentation :argument-precedence-order))) - (scope-defgeneric-1 local name args (cdr body))) - ((and (consp (car body)) (symbol-with-pos-p (caar body)) - (eq (bare-symbol (caar body)) :method)) - (nconc - (scope-defmethod local nil (cdar body)) - (scope-defgeneric-1 local name args (cdr body)))) - ;; FIXME: `args' may include `&key', so defun is not a perfect match. - (t (scope-defun local name args body)))) - -(defun scope-defgeneric-1 (local name args body) - (cond - ((and (consp (car body)) (symbol-with-pos-p (caar body)) - (memq (bare-symbol (caar body)) - '(declare :documentation :argument-precedence-order))) - (scope-defgeneric-1 local name args (cdr body))) - ((and (consp (car body)) (symbol-with-pos-p (caar body)) - (eq (bare-symbol (caar body)) :method)) - (nconc - (scope-defmethod local nil (cdar body)) - (scope-defgeneric-1 local name args (cdr body)))) - (t (scope-defgeneric-2 local name args body)))) - -(defun scope-defgeneric (local name args body) - (when (stringp (car body)) (setq body (cdr body))) - (scope-defgeneric-1 local name args body)) +(defun scope-defun (local _name args body) (scope-lambda local args body)) + +;; (defun scope-defmethod-1 (local0 local name args body) +;; (if args +;; (let ((arg (car args))) +;; (cond +;; ((consp arg) +;; (let ((var (car arg)) +;; (spec (cadr arg))) +;; (cond +;; ((symbol-with-pos-p var) +;; (let* ((beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (nconc +;; (cond +;; ((consp spec) +;; (let ((head (car spec)) +;; (form (cadr spec))) +;; (and (symbol-with-pos-p head) +;; (eq 'eql (bare-symbol head)) +;; (not (or (symbolp form) (symbol-with-pos-p form))) +;; (scope-1 local0 form))))) +;; (scope-defmethod-1 local0 (scope-local-new bare beg local) name (cdr args) body))))) +;; ((consp var) +;; ;; VAR is (&key (VAR INIT SVAR)) or (&key VAR). +;; (let ((var (cadr var))) +;; (cond +;; ((symbol-with-pos-p var) +;; (let* ((beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (nconc +;; (cond +;; ((consp spec) +;; (let ((head (car spec)) +;; (form (cadr spec))) +;; (and (symbol-with-pos-p head) +;; (eq 'eql (bare-symbol head)) +;; (not (or (symbolp form) (symbol-with-pos-p form))) +;; (scope-1 local0 form))))) +;; (scope-defmethod-1 local0 (scope-local-new bare beg local) name (cdr args) body))))) +;; ((consp var) +;; (let* ((init (cadr var)) +;; (svar (caddr var)) +;; (var (car var)) +;; (beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (nconc +;; (scope-1 local0 init) +;; (when svar +;; (let ((sbeg (symbol-with-pos-pos svar))) +;; (list (list sbeg (length (symbol-name (bare-symbol svar))) +;; sbeg)))) +;; (scope-defmethod-1 +;; local0 +;; (scope-local-new bare beg +;; (if svar +;; (scope-local-new (bare-symbol svar) +;; (symbol-with-pos-pos svar) +;; local) +;; local)) +;; name (cdr args) body))))))))))) +;; ((symbol-with-pos-p arg) +;; (cond +;; ((memq (bare-symbol arg) '(&optional &rest &body _)) +;; (scope-defmethod-1 local0 local name (cdr args) body)) +;; ((eq (bare-symbol arg) '&context) +;; (let* ((expr-type (cadr args)) +;; (expr (car expr-type)) +;; (type (cadr expr-type)) +;; (more (cddr args))) +;; (nconc +;; (scope-1 local0 expr) +;; (cond +;; ((consp type) +;; (let ((head (car type)) +;; (form (cadr type))) +;; (and (symbol-with-pos-p head) +;; (eq 'eql (bare-symbol head)) +;; (not (or (symbolp form) (symbol-with-pos-p form))) +;; (scope-1 local0 form))))) +;; (scope-defmethod-1 local0 local name more body)))) +;; (t +;; (let* ((beg (symbol-with-pos-pos arg)) +;; (bare (bare-symbol arg)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (scope-defmethod-1 local0 (scope-local-new bare beg local) +;; name (cdr args) body)))))))) +;; (scope-n local body))) + +;; (defun scope-defmethod (local name rest) +;; (when (and (symbol-with-pos-p (car rest)) +;; (eq (bare-symbol (car rest)) :extra)) +;; (setq rest (cddr rest))) +;; (when (and (symbol-with-pos-p (car rest)) +;; (memq (bare-symbol (car rest)) '(:before :after :around))) +;; (setq rest (cdr rest))) +;; (scope-defmethod-1 local local name (car rest) +;; (if (stringp (cadr rest)) (cddr rest) (cdr rest)))) + +;; (defun scope-defgeneric-2 (local name args body) +;; (cond +;; ((and (consp (car body)) (symbol-with-pos-p (caar body)) +;; (memq (bare-symbol (caar body)) +;; '(declare :documentation :argument-precedence-order))) +;; (scope-defgeneric-1 local name args (cdr body))) +;; ((and (consp (car body)) (symbol-with-pos-p (caar body)) +;; (eq (bare-symbol (caar body)) :method)) +;; (nconc +;; (scope-defmethod local nil (cdar body)) +;; (scope-defgeneric-1 local name args (cdr body)))) +;; ;; FIXME: `args' may include `&key', so defun is not a perfect match. +;; (t (scope-defun local name args body)))) + +;; (defun scope-defgeneric-1 (local name args body) +;; (cond +;; ((and (consp (car body)) (symbol-with-pos-p (caar body)) +;; (memq (bare-symbol (caar body)) +;; '(declare :documentation :argument-precedence-order))) +;; (scope-defgeneric-1 local name args (cdr body))) +;; ((and (consp (car body)) (symbol-with-pos-p (caar body)) +;; (eq (bare-symbol (caar body)) :method)) +;; (nconc +;; (scope-defmethod local nil (cdar body)) +;; (scope-defgeneric-1 local name args (cdr body)))) +;; (t (scope-defgeneric-2 local name args body)))) + +;; (defun scope-defgeneric (local name args body) +;; (when (stringp (car body)) (setq body (cdr body))) +;; (scope-defgeneric-1 local name args body)) (defun scope-cond (local clauses) - (mapcan (apply-partially #'scope-n local) clauses)) + (let ((res nil)) + (dolist (clause clauses) + (setq res (nconc (scope-n local clause) res))) + res)) (defun scope-setq (local args) (when args (let ((var (car args)) (val (cadr args))) - (nconc (scope-s local var) + (nconc (when (symbol-with-pos-p var) (scope-s local var)) (scope-1 local val) (scope-setq local (cddr args)))))) (defun scope-defvar (local _sym init) (scope-1 local init)) -(defun scope-condition-case (local var bodyform handlers) - (nconc - (when var - (let* ((beg (symbol-with-pos-pos var)) - (bare (bare-symbol var))) - (list (list beg (length (symbol-name bare)) beg)))) - (scope-1 local bodyform) - (mapcan - (let ((l (if var (scope-local-new (bare-symbol var) (symbol-with-pos-pos var) local) local))) - (lambda (handler) (scope-n l (cdr handler)))) - handlers))) - -(defun scope-dotimes (local var lst res body) - (cons - (let* ((beg (symbol-with-pos-pos var)) - (bare (bare-symbol var))) - (list beg (length (symbol-name bare)) beg)) - (nconc - (scope-1 local lst) - (scope-1 local res) - (let ((l (scope-local-new (bare-symbol var) (symbol-with-pos-pos var) local))) - (scope-n l body))))) - -(defun scope-pcase-qpat (local qpat) - (cond - ((consp qpat) - (if (eq (car qpat) '\,) (scope-pcase-pattern local (cadr qpat)) - (let* ((l-r0 (scope-pcase-qpat local (car qpat))) - (l (car l-r0)) - (r0 (cdr l-r0)) - (l-r (scope-pcase-qpat l (cdr qpat)))) - (cons (car l-r) (nconc r0 (cdr l-r)))))) - ;; FIXME: Support vector qpats. - (t (list local)))) - -(defun scope-pcase-and (local patterns) - (if patterns - (let* ((l-r0 (scope-pcase-pattern local (car patterns))) - (l (car l-r0)) - (r0 (cdr l-r0)) - (l-r (scope-pcase-and l (cdr patterns)))) - (cons (car l-r) (nconc r0 (cdr l-r)))) - (list local))) - -(defun scope-pcase-pattern (local pattern) - (cond - ((symbol-with-pos-p pattern) - (let ((bare (bare-symbol pattern))) - (if (or (eq bare '_) (keywordp bare)) (list local) - ;; FIXME: Keep track of symbols bound here and analyze - ;; subsequent symbol patterns with the same symbol as equality - ;; tests, not new bindings. - (let* ((beg (symbol-with-pos-pos pattern))) - (cons (scope-local-new bare beg local) - (list (list beg (length (symbol-name bare)) beg))))))) - ((consp pattern) - (let ((head (car pattern))) - (cond - ((eq head '\`) - (scope-pcase-qpat local (cadr pattern))) - ((eq head 'quote) (list local)) - ((symbol-with-pos-p head) - (let ((bh (bare-symbol head))) - (cond - ((eq bh 'pred) - ;; FIXME: Analyze FUN at (cadr pattern). - (list local)) - ((eq bh 'app) - ;; FIXME: Likewise here. - (scope-pcase-pattern local (caddr pattern))) - ((eq bh 'guard) (cons local (scope-1 local (cadr pattern)))) - ((eq bh 'cl-type) (list local)) - ((eq bh 'let) - (let ((r0 (scope-1 local (caddr pattern))) - (l-r (scope-pcase-pattern local (cadr pattern)))) - (cons (car l-r) (nconc r0 (cdr l-r))))) - ((eq bh 'and) (scope-pcase-and local (cdr pattern))) - ((eq bh 'or) - ;; FIXME: `or' patterns deserve special handling because - ;; they can create multiple binding positions for the same - ;; symbol in different subpatterns, and the effective - ;; binding position can only be determined at run time. - (scope-pcase-and local (cdr pattern))))))))) - ((or (integerp pattern) (stringp pattern)) (list local)))) - -(defun scope-pcase-1 (local pattern body) - (let* ((l-r (scope-pcase-pattern local pattern)) - (l (car l-r)) - (r (cdr l-r))) - (when l (nconc r (scope-n l body))))) - -(defun scope-pcase (local exp cases) - (nconc - (scope-1 local exp) - (mapcan - (lambda (case) - (scope-pcase-1 local (car case) (cdr case))) - cases))) - -(defun scope-push (local new place) - (nconc (scope-1 local new) (scope-1 local place))) +(defun scope-condition-case-handlers (local handlers) + (when handlers + (nconc + (scope-n local (cdar handlers)) + (scope-condition-case-handlers local (cdr handlers))))) -(defun scope-minibuffer-with-setup-hook (local fun body) - (nconc - (scope-1 local (if (and (symbol-with-pos-p (car-safe fun)) - (eq :append (bare-symbol (car-safe fun)))) - (cadr fun) - fun)) - (scope-n local body))) +(defun scope-condition-case (local var bodyform handlers) + (let* ((bare (bare-symbol var)) + (beg (when (symbol-with-pos-p var) (symbol-with-pos-pos var))) + (l (scope-local-new (bare-symbol var) beg local))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (scope-1 local bodyform) + (scope-condition-case-handlers l handlers)))) + +;; (defun scope-dotimes (local var lst res body) +;; (cons +;; (let* ((beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var))) +;; (list beg (length (symbol-name bare)) beg)) +;; (nconc +;; (scope-1 local lst) +;; (scope-1 local res) +;; (let ((l (scope-local-new (bare-symbol var) (symbol-with-pos-pos var) local))) +;; (scope-n l body))))) + +;; (defun scope-pcase-qpat (local qpat) +;; (cond +;; ((consp qpat) +;; (if (eq (car qpat) '\,) (scope-pcase-pattern local (cadr qpat)) +;; (let* ((l-r0 (scope-pcase-qpat local (car qpat))) +;; (l (car l-r0)) +;; (r0 (cdr l-r0)) +;; (l-r (scope-pcase-qpat l (cdr qpat)))) +;; (cons (car l-r) (nconc r0 (cdr l-r)))))) +;; ;; FIXME: Support vector qpats. +;; (t (list local)))) + +;; (defun scope-pcase-and (local patterns) +;; (if patterns +;; (let* ((l-r0 (scope-pcase-pattern local (car patterns))) +;; (l (car l-r0)) +;; (r0 (cdr l-r0)) +;; (l-r (scope-pcase-and l (cdr patterns)))) +;; (cons (car l-r) (nconc r0 (cdr l-r)))) +;; (list local))) + +;; (defun scope-pcase-pattern (local pattern) +;; (cond +;; ((symbol-with-pos-p pattern) +;; (let ((bare (bare-symbol pattern))) +;; (if (or (eq bare '_) (keywordp bare)) (list local) +;; ;; FIXME: Keep track of symbols bound here and analyze +;; ;; subsequent symbol patterns with the same symbol as equality +;; ;; tests, not new bindings. +;; (let* ((beg (symbol-with-pos-pos pattern))) +;; (cons (scope-local-new bare beg local) +;; (list (list beg (length (symbol-name bare)) beg))))))) +;; ((consp pattern) +;; (let ((head (car pattern))) +;; (cond +;; ((eq head '\`) +;; (scope-pcase-qpat local (cadr pattern))) +;; ((eq head 'quote) (list local)) +;; ((symbol-with-pos-p head) +;; (let ((bh (bare-symbol head))) +;; (cond +;; ((eq bh 'pred) +;; ;; FIXME: Analyze FUN at (cadr pattern). +;; (list local)) +;; ((eq bh 'app) +;; ;; FIXME: Likewise here. +;; (scope-pcase-pattern local (caddr pattern))) +;; ((eq bh 'guard) (cons local (scope-1 local (cadr pattern)))) +;; ((eq bh 'cl-type) (list local)) +;; ((eq bh 'let) +;; (let ((r0 (scope-1 local (caddr pattern))) +;; (l-r (scope-pcase-pattern local (cadr pattern)))) +;; (cons (car l-r) (nconc r0 (cdr l-r))))) +;; ((eq bh 'and) (scope-pcase-and local (cdr pattern))) +;; ((eq bh 'or) +;; ;; FIXME: `or' patterns deserve special handling because +;; ;; they can create multiple binding positions for the same +;; ;; symbol in different subpatterns, and the effective +;; ;; binding position can only be determined at run time. +;; (scope-pcase-and local (cdr pattern))))))))) +;; ((or (integerp pattern) (stringp pattern)) (list local)))) + +;; (defun scope-pcase-1 (local pattern body) +;; (let* ((l-r (scope-pcase-pattern local pattern)) +;; (l (car l-r)) +;; (r (cdr l-r))) +;; (when l (nconc r (scope-n l body))))) + +;; (defun scope-pcase (local exp cases) +;; (nconc +;; (scope-1 local exp) +;; (mapcan +;; (lambda (case) +;; (scope-pcase-1 local (car case) (cdr case))) +;; cases))) + +;; (defun scope-push (local new place) +;; (nconc (scope-1 local new) (scope-1 local place))) + +;; (defun scope-minibuffer-with-setup-hook (local fun body) +;; (nconc +;; (scope-1 local (if (and (symbol-with-pos-p (car-safe fun)) +;; (eq :append (bare-symbol (car-safe fun)))) +;; (cadr fun) +;; fun)) +;; (scope-n local body))) (defun scope--backquote (local elements depth) (cond @@ -441,20 +453,18 @@ Optional argument LOCAL is a local context to extend." (if defs (let* ((def (car defs)) (func (car def)) - (exps (cdr def))) - (cons - (list (symbol-with-pos-pos func) (length (symbol-name (bare-symbol func))) - (symbol-with-pos-pos func)) - (nconc - (if (cdr exps) - ;; def is (FUNC ARGLIST BODY...) - (scope-defun local nil (car exps) (cdr exps)) - ;; def is (FUNC EXP) - (scope-1 local (car exps))) - (let ((scope-flet-alist (cons (cons (bare-symbol func) - (symbol-with-pos-pos func)) - scope-flet-alist))) - (scope-flet local (cdr defs) body))))) + (exps (cdr def)) + (beg (scope-sym-pos func)) + (bare (bare-symbol func))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (if (cdr exps) + ;; def is (FUNC ARGLIST BODY...) + (scope-lambda local (car exps) (cdr exps)) + ;; def is (FUNC EXP) + (scope-1 local (car exps))) + (let ((scope-flet-alist (scope-local-new bare beg scope-flet-alist))) + (scope-flet local (cdr defs) body)))) (scope-n local body))) (defun scope-labels (local defs forms) @@ -462,27 +472,25 @@ Optional argument LOCAL is a local context to extend." (let* ((def (car defs)) (func (car def)) (args (cadr def)) - (body (cddr def))) - (cons - (list (symbol-with-pos-pos func) (length (symbol-name (bare-symbol func))) - (symbol-with-pos-pos func)) - (let ((scope-flet-alist (cons (cons (bare-symbol func) - (symbol-with-pos-pos func)) - scope-flet-alist))) - (nconc - (scope-defun local nil args body) - (scope-flet local (cdr defs) forms))))) + (body (cddr def)) + (beg (scope-sym-pos func)) + (bare (bare-symbol func))) + (let ((scope-flet-alist (scope-local-new bare beg scope-flet-alist))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (scope-lambda local args body) + (scope-flet local (cdr defs) forms)))) (scope-n local forms))) (defvar scope-block-alist nil) (defun scope-block (local name body) (if name - (let* ((beg (symbol-with-pos-pos name)) + (let* ((beg (scope-sym-pos name)) (bare (bare-symbol name))) - (cons - (list beg (length (symbol-name bare)) beg) - (let ((scope-block-alist (cons (cons bare beg) scope-block-alist))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (let ((scope-block-alist (scope-local-new bare beg scope-block-alist))) (scope-n local body)))) (scope-n local body))) @@ -495,228 +503,231 @@ Optional argument LOCAL is a local context to extend." (scope-1 local result))) (defun scope-sharpquote (local arg) - (when (symbol-with-pos-p arg) - (let ((bare (bare-symbol arg))) - (cond - ((functionp bare) (list (list (symbol-with-pos-pos arg) (length (symbol-name bare)) 'function))) - ((or (assq bare scope-flet-alist) (consp arg)) - (scope-1 local arg)))))) - -(defun scope-cl-defun-aux (local name args body) - (if args - (let ((arg (car args))) - (cond - ((symbol-with-pos-p arg) - (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (scope-cl-defun-aux (scope-local-new bare beg local) - name (cdr args) body)))) - ((consp arg) - (let* ((var (car arg)) - (init (cadr arg)) - (beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (nconc - (scope-1 local init) - (scope-cl-defun-aux (scope-local-new bare beg local) - name (cdr args) body))))))) - (scope-n local body))) - -(defun scope-cl-defun-key (local name args body) - (if args - (let ((arg (car args))) - (cond - ((symbol-with-pos-p arg) - (cond - ((eq (bare-symbol arg) '&allow-other-keys) - (if (cdr args) - (scope-cl-defun-aux local name (cddr args) body) - (scope-n local body))) - ((eq (bare-symbol arg) '&aux) - (scope-cl-defun-aux local name (cdr args) body)) - (t (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (scope-cl-defun-key (scope-local-new bare beg local) - name (cdr args) body)))))) - ((consp arg) - (let* ((var (car arg)) - (var (if (consp var) (cadr var) var)) - (init (cadr arg)) - (svar (caddr arg)) - (beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (nconc - (scope-1 local init) - (when svar - (let ((sbeg (symbol-with-pos-pos svar))) - (list (list sbeg (length (symbol-name (bare-symbol svar))) - sbeg)))) - (scope-cl-defun-key - (scope-local-new bare beg - (if svar - (scope-local-new (bare-symbol svar) - (symbol-with-pos-pos svar) - local) - local)) - name (cdr args) body))))))) - (scope-n local body))) - -(defun scope-cl-defun-rest (local name args body) - (let* ((var (car args)) - (beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare))) - (l (scope-local-new bare beg local))) - (cons - (list beg len beg) - (if (cdr args) - (let ((next (cadr args)) - (more (cddr args))) - (cond - ((eq (bare-symbol next) '&key) - (scope-cl-defun-key l name more body)) - ((eq (bare-symbol next) '&aux) - (scope-cl-defun-aux l name more body)))) - (scope-n l body))))) - -(defun scope-cl-defun-optional (local name args body) - (if args - (let ((arg (car args))) - (cond - ((symbol-with-pos-p arg) - (cond - ((memq (bare-symbol arg) '(&rest &body)) - (scope-cl-defun-rest local name (cdr args) body)) - ((eq (bare-symbol arg) '&key) - (scope-cl-defun-key local name (cdr args) body)) - ((eq (bare-symbol arg) '&aux) - (scope-cl-defun-aux local name (cdr args) body)) - (t (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (scope-cl-defun-optional (scope-local-new bare beg local) - name (cdr args) body)))))) - ((consp arg) - (let* ((var (car arg)) - (init (cadr arg)) - (svar (caddr arg)) - (beg (symbol-with-pos-pos var)) - (bare (bare-symbol var)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (nconc - (scope-1 local init) - (when svar - (let ((sbeg (symbol-with-pos-pos svar))) - (list (list sbeg (length (symbol-name (bare-symbol svar))) - sbeg)))) - (scope-cl-defun-optional - (scope-local-new bare beg - (if svar - (scope-local-new (bare-symbol svar) - (symbol-with-pos-pos svar) - local) - local)) - name (cdr args) body))))))) - (scope-n local body))) - -(defun scope-cl-defun-1 (local name args body) - (if args - (let ((arg (car args))) - (cond - ((eq (bare-symbol arg) '&optional) - (scope-cl-defun-optional local name (cdr args) body)) - ((memq (bare-symbol arg) '(&rest &body)) - (scope-cl-defun-rest local name (cdr args) body)) - ((eq (bare-symbol arg) '&key) - (scope-cl-defun-key local name (cdr args) body)) - ((eq (bare-symbol arg) '&aux) - (scope-cl-defun-aux local name (cdr args) body)) - (t (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (cons - (list beg len beg) - (scope-cl-defun-1 (scope-local-new (bare-symbol arg) - (symbol-with-pos-pos arg) - local) - name (cdr args) body)))))) - (scope-n local body))) - -(defun scope-cl-defun (local name args body) - (scope-cl-defun-1 local name args (if (stringp (car body)) (cdr body) body))) - -(defun scope-seq-let (local args sequence body) - (nconc - (scope-1 local sequence) - (mapcar (lambda (arg) - (let* ((beg (symbol-with-pos-pos arg)) - (bare (bare-symbol arg)) - (len (length (symbol-name bare)))) - (list beg len beg))) - args) - (let ((l local)) - (dolist (arg args) - (when (and (symbol-with-pos-p arg) (not (memq (bare-symbol arg) '(&rest)))) - (setq l (scope-local-new (bare-symbol arg) (symbol-with-pos-pos arg) l)))) - (scope-n l body)))) - -(defun scope-pcase-lambda (local lambda-list body) - (if lambda-list - (let* ((l-r (scope-pcase-pattern local (car lambda-list))) - (l (car l-r)) - (r (cdr l-r))) - (when l (nconc r (scope-pcase-lambda l (cdr lambda-list) body)))) - (scope-n local body))) - -(defun scope-pcase-dolist (local pattern lst body) - (nconc - (scope-1 local lst) - (scope-pcase-1 local pattern body))) - -(defun scope-pcase-let-1 (local0 local bindings body) - (if bindings - (let* ((binding (car bindings)) - (pat (car binding)) - (exp (cadr binding))) - (nconc - (scope-1 local0 exp) - (let* ((l-r (scope-pcase-pattern local pat)) - (l (car l-r)) - (r (cdr l-r))) - (when l (nconc r (scope-pcase-let-1 local0 l (cdr bindings) body)))))) - (scope-n local body))) - -(defun scope-pcase-let (local bindings body) - (scope-pcase-let-1 local local bindings body)) - -(defun scope-pcase-let* (local bindings body) - (if bindings - (let* ((binding (car bindings)) - (pat (car binding)) - (exp (cadr binding))) - (nconc - (scope-1 local exp) - (let* ((l-r (scope-pcase-pattern local pat)) - (l (car l-r)) - (r (cdr l-r))) - (when l (nconc r (scope-pcase-let* l (cdr bindings) body)))))) - (scope-n local body))) + (cond + ((or (symbol-with-pos-p arg) (symbolp arg)) + (let ((bare (bare-symbol arg)) + (beg (scope-sym-pos arg))) + (cond + ((functionp bare) (when beg (list (list beg (length (symbol-name bare)) 'function)))) + ((or (assq bare scope-flet-alist) (consp arg)) + (scope-1 local arg))))) + ((consp arg) (scope-1 local arg)))) + +;; (defun scope-cl-defun-aux (local name args body) +;; (if args +;; (let ((arg (car args))) +;; (cond +;; ((symbol-with-pos-p arg) +;; (let* ((beg (symbol-with-pos-pos arg)) +;; (bare (bare-symbol arg)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (scope-cl-defun-aux (scope-local-new bare beg local) +;; name (cdr args) body)))) +;; ((consp arg) +;; (let* ((var (car arg)) +;; (init (cadr arg)) +;; (beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (nconc +;; (scope-1 local init) +;; (scope-cl-defun-aux (scope-local-new bare beg local) +;; name (cdr args) body))))))) +;; (scope-n local body))) + +;; (defun scope-cl-defun-key (local name args body) +;; (if args +;; (let ((arg (car args))) +;; (cond +;; ((symbol-with-pos-p arg) +;; (cond +;; ((eq (bare-symbol arg) '&allow-other-keys) +;; (if (cdr args) +;; (scope-cl-defun-aux local name (cddr args) body) +;; (scope-n local body))) +;; ((eq (bare-symbol arg) '&aux) +;; (scope-cl-defun-aux local name (cdr args) body)) +;; (t (let* ((beg (symbol-with-pos-pos arg)) +;; (bare (bare-symbol arg)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (scope-cl-defun-key (scope-local-new bare beg local) +;; name (cdr args) body)))))) +;; ((consp arg) +;; (let* ((var (car arg)) +;; (var (if (consp var) (cadr var) var)) +;; (init (cadr arg)) +;; (svar (caddr arg)) +;; (beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (nconc +;; (scope-1 local init) +;; (when svar +;; (let ((sbeg (symbol-with-pos-pos svar))) +;; (list (list sbeg (length (symbol-name (bare-symbol svar))) +;; sbeg)))) +;; (scope-cl-defun-key +;; (scope-local-new bare beg +;; (if svar +;; (scope-local-new (bare-symbol svar) +;; (symbol-with-pos-pos svar) +;; local) +;; local)) +;; name (cdr args) body))))))) +;; (scope-n local body))) + +;; (defun scope-cl-defun-rest (local name args body) +;; (let* ((var (car args)) +;; (beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare))) +;; (l (scope-local-new bare beg local))) +;; (cons +;; (list beg len beg) +;; (if (cdr args) +;; (let ((next (cadr args)) +;; (more (cddr args))) +;; (cond +;; ((eq (bare-symbol next) '&key) +;; (scope-cl-defun-key l name more body)) +;; ((eq (bare-symbol next) '&aux) +;; (scope-cl-defun-aux l name more body)))) +;; (scope-n l body))))) + +;; (defun scope-cl-defun-optional (local name args body) +;; (if args +;; (let ((arg (car args))) +;; (cond +;; ((symbol-with-pos-p arg) +;; (cond +;; ((memq (bare-symbol arg) '(&rest &body)) +;; (scope-cl-defun-rest local name (cdr args) body)) +;; ((eq (bare-symbol arg) '&key) +;; (scope-cl-defun-key local name (cdr args) body)) +;; ((eq (bare-symbol arg) '&aux) +;; (scope-cl-defun-aux local name (cdr args) body)) +;; (t (let* ((beg (symbol-with-pos-pos arg)) +;; (bare (bare-symbol arg)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (scope-cl-defun-optional (scope-local-new bare beg local) +;; name (cdr args) body)))))) +;; ((consp arg) +;; (let* ((var (car arg)) +;; (init (cadr arg)) +;; (svar (caddr arg)) +;; (beg (symbol-with-pos-pos var)) +;; (bare (bare-symbol var)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (nconc +;; (scope-1 local init) +;; (when svar +;; (let ((sbeg (symbol-with-pos-pos svar))) +;; (list (list sbeg (length (symbol-name (bare-symbol svar))) +;; sbeg)))) +;; (scope-cl-defun-optional +;; (scope-local-new bare beg +;; (if svar +;; (scope-local-new (bare-symbol svar) +;; (symbol-with-pos-pos svar) +;; local) +;; local)) +;; name (cdr args) body))))))) +;; (scope-n local body))) + +;; (defun scope-cl-defun-1 (local name args body) +;; (if args +;; (let ((arg (car args))) +;; (cond +;; ((eq (bare-symbol arg) '&optional) +;; (scope-cl-defun-optional local name (cdr args) body)) +;; ((memq (bare-symbol arg) '(&rest &body)) +;; (scope-cl-defun-rest local name (cdr args) body)) +;; ((eq (bare-symbol arg) '&key) +;; (scope-cl-defun-key local name (cdr args) body)) +;; ((eq (bare-symbol arg) '&aux) +;; (scope-cl-defun-aux local name (cdr args) body)) +;; (t (let* ((beg (symbol-with-pos-pos arg)) +;; (bare (bare-symbol arg)) +;; (len (length (symbol-name bare)))) +;; (cons +;; (list beg len beg) +;; (scope-cl-defun-1 (scope-local-new (bare-symbol arg) +;; (symbol-with-pos-pos arg) +;; local) +;; name (cdr args) body)))))) +;; (scope-n local body))) + +;; (defun scope-cl-defun (local name args body) +;; (scope-cl-defun-1 local name args (if (stringp (car body)) (cdr body) body))) + +;; (defun scope-seq-let (local args sequence body) +;; (nconc +;; (scope-1 local sequence) +;; (mapcar (lambda (arg) +;; (let* ((beg (symbol-with-pos-pos arg)) +;; (bare (bare-symbol arg)) +;; (len (length (symbol-name bare)))) +;; (list beg len beg))) +;; args) +;; (let ((l local)) +;; (dolist (arg args) +;; (when (and (symbol-with-pos-p arg) (not (memq (bare-symbol arg) '(&rest)))) +;; (setq l (scope-local-new (bare-symbol arg) (symbol-with-pos-pos arg) l)))) +;; (scope-n l body)))) + +;; (defun scope-pcase-lambda (local lambda-list body) +;; (if lambda-list +;; (let* ((l-r (scope-pcase-pattern local (car lambda-list))) +;; (l (car l-r)) +;; (r (cdr l-r))) +;; (when l (nconc r (scope-pcase-lambda l (cdr lambda-list) body)))) +;; (scope-n local body))) + +;; (defun scope-pcase-dolist (local pattern lst body) +;; (nconc +;; (scope-1 local lst) +;; (scope-pcase-1 local pattern body))) + +;; (defun scope-pcase-let-1 (local0 local bindings body) +;; (if bindings +;; (let* ((binding (car bindings)) +;; (pat (car binding)) +;; (exp (cadr binding))) +;; (nconc +;; (scope-1 local0 exp) +;; (let* ((l-r (scope-pcase-pattern local pat)) +;; (l (car l-r)) +;; (r (cdr l-r))) +;; (when l (nconc r (scope-pcase-let-1 local0 l (cdr bindings) body)))))) +;; (scope-n local body))) + +;; (defun scope-pcase-let (local bindings body) +;; (scope-pcase-let-1 local local bindings body)) + +;; (defun scope-pcase-let* (local bindings body) +;; (if bindings +;; (let* ((binding (car bindings)) +;; (pat (car binding)) +;; (exp (cadr binding))) +;; (nconc +;; (scope-1 local exp) +;; (let* ((l-r (scope-pcase-pattern local pat)) +;; (l (car l-r)) +;; (r (cdr l-r))) +;; (when l (nconc r (scope-pcase-let* l (cdr bindings) body)))))) +;; (scope-n local body))) (defun scope-declare-function (_local _fn _file arglist _fileonly) (seq-keep (lambda (arg) @@ -741,23 +752,27 @@ Optional argument LOCAL is a local context to extend." (while (keywordp (car body)) (setq body (cddr body))) (scope-n local body)) -(defun scope-letrec (local binders body) - (if binders - (let* ((binder (car binders)) - (sym (car binder)) - (bare (bare-symbol sym)) - (beg (symbol-with-pos-pos sym)) - (l (scope-local-new bare beg local)) - (form (cadr binder))) - (cons - (list beg (length (symbol-name bare)) beg) - (nconc (scope-1 l form) - (scope-letrec l (cdr binders) body)))) - (scope-n local body))) +;; (defun scope-letrec (local binders body) +;; (if binders +;; (let* ((binder (car binders)) +;; (sym (car binder)) +;; (bare (bare-symbol sym)) +;; (beg (symbol-with-pos-pos sym)) +;; (l (scope-local-new bare beg local)) +;; (form (cadr binder))) +;; (cons +;; (list beg (length (symbol-name bare)) beg) +;; (nconc (scope-1 l form) +;; (scope-letrec l (cdr binders) body)))) +;; (scope-n local body))) + +(defsubst scope-sym-bare (sym) + (cond + ((symbolp sym) sym) + ((symbol-with-pos-p sym) (bare-symbol sym)))) (defun scope-loop-for-and (local rest) - (if (and (symbol-with-pos-p (car rest)) - (eq (bare-symbol (car rest)) 'and)) + (if (eq (scope-sym-bare (car rest)) 'and) (scope-loop-for local local (cadr rest) (cddr rest)) (scope-loop local rest))) @@ -767,117 +782,98 @@ Optional argument LOCAL is a local context to extend." (defun scope-loop-for-to (local0 local expr rest) (nconc (scope-1 local0 expr) - (let ((word (car rest)) - (more (cdr rest))) + (when-let ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) (cond - ((symbol-with-pos-pos word) - (let ((bw (bare-symbol word))) - (cond - ((eq bw 'by) - (scope-loop-for-by local0 local (car more) (cdr more))) - (t (scope-loop-for-and local rest))))))))) + ((eq bare 'by) + (scope-loop-for-by local0 local (car more) (cdr more))) + (t (scope-loop-for-and local rest)))))) (defun scope-loop-for-from (local0 local expr rest) (nconc (scope-1 local0 expr) - (let ((word (car rest)) - (more (cdr rest))) + (when-let ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) (cond - ((symbol-with-pos-pos word) - (let ((bw (bare-symbol word))) - (cond - ((memq bw '(to upto downto below above)) - (scope-loop-for-to local0 local (car more) (cdr more))) - ((eq bw 'by) - (scope-loop-for-by local0 local (car more) (cdr more))) - (t (scope-loop-for-and local rest))))))))) + ((memq bare '(to upto downto below above)) + (scope-loop-for-to local0 local (car more) (cdr more))) + ((eq bare 'by) + (scope-loop-for-by local0 local (car more) (cdr more))) + (t (scope-loop-for-and local rest)))))) (defun scope-loop-for-= (local0 local expr rest) (nconc (scope-1 local0 expr) - (let ((word (car rest)) - (more (cdr rest))) + (when-let ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) (cond - ((symbol-with-pos-pos word) - (let ((bw (bare-symbol word))) - (cond - ((eq bw 'then) - (scope-loop-for-by local0 local (car more) (cdr more))) - (t (scope-loop-for-and local rest))))))))) - -(defun scope-loop-for-being-the-hash-keys-of-using (local0 local form rest) + ((eq bare 'then) + (scope-loop-for-by local0 local (car more) (cdr more))) + (t (scope-loop-for-and local rest)))))) + +(defun scope-loop-for-being-the-hash-keys-of-using (local form rest) (let* ((var (cadr form)) - (bare (bare-symbol var)) - (beg (symbol-with-pos-pos var))) - (cons - (list beg (length (symbol-name bare)) beg) + (bare (scope-sym-bare var)) + (beg (scope-sym-pos var))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) (scope-loop-for-and (scope-local-new bare beg local) rest)))) (defun scope-loop-for-being-the-hash-keys-of (local0 local expr rest) (nconc (scope-1 local0 expr) - (let ((word (car rest)) - (more (cdr rest))) - (when (symbol-with-pos-p word) - (let ((bw (bare-symbol word))) - (cond - ((eq bw 'using) - (scope-loop-for-being-the-hash-keys-of-using local0 local (car more) (cdr more))) - (t (scope-loop-for-and local rest)))))))) + (when-let ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) + (cond + ((eq bare 'using) + (scope-loop-for-being-the-hash-keys-of-using local (car more) (cdr more))) + (t (scope-loop-for-and local rest)))))) (defun scope-loop-for-being-the-hash-keys (local0 local word rest) - (when (symbol-with-pos-p word) - (let ((bw (bare-symbol word))) - (cond - ((eq bw 'of) - (scope-loop-for-being-the-hash-keys-of local0 local (car rest) (cdr rest))))))) + (when-let ((bare (scope-sym-bare word))) + (cond + ((eq bare 'of) + (scope-loop-for-being-the-hash-keys-of local0 local (car rest) (cdr rest)))))) (defun scope-loop-for-being-the (local0 local word rest) - (when (symbol-with-pos-p word) - (let ((bw (bare-symbol word))) - (cond - ((memq bw '(buffer buffers)) - (scope-loop-for-and local rest)) - ((memq bw '( hash-key hash-keys + (when-let ((bare (scope-sym-bare word))) + (cond + ((memq bare '(buffer buffers)) + (scope-loop-for-and local rest)) + ((memq bare '( hash-key hash-keys hash-value hash-values key-code key-codes key-binding key-bindings)) - (scope-loop-for-being-the-hash-keys local0 local (car rest) (cdr rest))))))) + (scope-loop-for-being-the-hash-keys local0 local (car rest) (cdr rest)))))) (defun scope-loop-for-being (local0 local next rest) (scope-loop-for-being-the local0 local (car rest) - (if (and (symbol-with-pos-p next) - (memq (bare-symbol next) '(the each))) - (cdr rest) - rest))) + (if (memq (scope-sym-bare next) '(the each)) (cdr rest) rest))) (defun scope-loop-for (local0 local vars rest) (if vars (let* ((var (car (ensure-list vars))) (bare (bare-symbol var)) - (beg (symbol-with-pos-pos var))) - (cons - (list beg (length (symbol-name bare)) beg) + (beg (scope-sym-pos var))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) (scope-loop-for local0 (scope-local-new bare beg local) (cdr-safe vars) rest))) - (let ((word (car rest)) - (more (cdr rest))) + (when-let ((bare (scope-sym-bare (car rest))) + (more (cdr rest))) (cond - ((symbol-with-pos-p word) - (let ((bw (bare-symbol word))) - (cond - ((memq bw '(from upfrom downfrom)) - (scope-loop-for-from local0 local (car more) (cdr more))) - ((memq bw '( to upto downto below above - in on in-ref)) - (scope-loop-for-to local0 local (car more) (cdr more))) - ((memq bw '(by - across across-ref)) - (scope-loop-for-by local0 local (car more) (cdr more))) - ((eq bw '=) - (scope-loop-for-= local0 local (car more) (cdr more))) - ((memq bw '(being)) - (scope-loop-for-being local0 local (car more) (cdr more)))))))))) + ((memq bare '(from upfrom downfrom)) + (scope-loop-for-from local0 local (car more) (cdr more))) + ((memq bare '( to upto downto below above + in on in-ref)) + (scope-loop-for-to local0 local (car more) (cdr more))) + ((memq bare '(by + across across-ref)) + (scope-loop-for-by local0 local (car more) (cdr more))) + ((eq bare '=) + (scope-loop-for-= local0 local (car more) (cdr more))) + ((eq bare 'being) + (scope-loop-for-being local0 local (car more) (cdr more))))))) (defun scope-loop-repeat (local form rest) (nconc (scope-1 local form) (scope-loop local rest))) @@ -885,37 +881,33 @@ Optional argument LOCAL is a local context to extend." (defun scope-loop-collect (local expr rest) (nconc (scope-1 local expr) - (let ((word (car rest)) + (let ((bw (scope-sym-bare (car rest))) (more (cdr rest))) - (if (and (symbol-with-pos-p word) - (eq (bare-symbol word) 'into)) + (if (eq bw 'into) (let* ((var (car more)) - (bare (bare-symbol var)) - (beg (symbol-with-pos-pos var))) - (cons - (list beg (length (symbol-name bare)) beg) + (bare (scope-sym-bare var)) + (beg (scope-sym-pos var))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) (scope-loop (scope-local-new bare beg local) (cdr more)))) (scope-loop local rest))))) (defun scope-loop-with-and (local rest) - (if (and (symbol-with-pos-p (car rest)) - (eq (bare-symbol (car rest)) 'and)) + (if (eq (scope-sym-bare (car rest)) 'and) (scope-loop-with local (cadr rest) (cddr rest)) (scope-loop local rest))) (defun scope-loop-with (local var rest) - (when (symbol-with-pos-p var) - (let* ((bare (bare-symbol var)) - (beg (symbol-with-pos-pos var)) - (l (scope-local-new bare beg local)) - (eql (car rest))) - (cons - (list beg (length (symbol-name bare)) beg) - (if (and (symbol-with-pos-p eql) - (eq (bare-symbol eql) '=)) - (let* ((val (cadr rest)) (more (cddr rest))) - (nconc (scope-1 local val) (scope-loop-with-and l more))) - (scope-loop-with-and l rest)))))) + (let* ((bare (scope-sym-bare var)) + (beg (symbol-with-pos-pos var)) + (l (scope-local-new bare beg local)) + (eql (car rest))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (if (eq (scope-sym-bare eql) '=) + (let* ((val (cadr rest)) (more (cddr rest))) + (nconc (scope-1 local val) (scope-loop-with-and l more))) + (scope-loop-with-and l rest))))) (defun scope-loop-do (local form rest) (nconc @@ -925,27 +917,25 @@ Optional argument LOCAL is a local context to extend." (scope-loop local rest)))) (defun scope-loop-named (local name rest) - (let* ((beg (symbol-with-pos-pos name)) - (bare (bare-symbol name))) - (cons - (list beg (length (symbol-name bare)) beg) - (let ((scope-block-alist (cons (cons bare beg) scope-block-alist))) + (let* ((beg (scope-sym-pos name)) + (bare (scope-sym-bare name))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (let ((scope-block-alist (scope-local-new bare beg scope-block-alist))) (scope-loop local rest))))) (defun scope-loop-finally (local next rest) - (if (symbol-with-pos-p next) - (let ((bare (bare-symbol next))) - (cond - ((eq bare 'do) - (scope-loop-do local (car rest) (cdr rest))) - ((eq bare 'return) - (nconc (scope-1 local (car rest)) - (scope-loop local (cdr rest)))))) + (if-let ((bare (scope-sym-bare next))) + (cond + ((eq bare 'do) + (scope-loop-do local (car rest) (cdr rest))) + ((eq bare 'return) + (nconc (scope-1 local (car rest)) + (scope-loop local (cdr rest))))) (scope-loop-do local next rest))) (defun scope-loop-initially (local next rest) - (if (and (symbol-with-pos-p next) - (eq (bare-symbol next) 'do)) + (if (eq (scope-sym-bare next) 'do) (scope-loop-do local (car rest) (cdr rest)) (scope-loop-do local next rest))) @@ -956,7 +946,7 @@ Optional argument LOCAL is a local context to extend." (let ((scope-loop-if-depth (1+ scope-loop-if-depth))) (scope-loop ;; `if' binds `it'. - (scope-local-new 'it (symbol-with-pos-pos keyword) local) + (scope-local-new 'it (scope-sym-pos keyword) local) rest)))) (defun scope-loop-end (local rest) @@ -969,193 +959,195 @@ Optional argument LOCAL is a local context to extend." (defun scope-loop (local forms) (when forms - (let ((kw (car forms)) - (rest (cdr forms))) + (let* ((kw (car forms)) + (bare (scope-sym-bare kw)) + (rest (cdr forms))) (cond - ((symbol-with-pos-p kw) - (let ((bare (bare-symbol kw))) - (cond - ((memq bare '(for as)) - (scope-loop-for local local (car rest) (cdr rest))) - ((memq bare '( repeat while until always never thereis iter-by - return)) - (scope-loop-repeat local (car rest) (cdr rest))) - ((memq bare '(collect append nconc concat vconcat count sum maximize minimize)) - (scope-loop-collect local (car rest) (cdr rest))) - ((memq bare '(with)) - (scope-loop-with local (car rest) (cdr rest))) - ((memq bare '(do)) (scope-loop-do local (car rest) (cdr rest))) - ((memq bare '(named)) (scope-loop-named local (car rest) (cdr rest))) - ((memq bare '(finally)) (scope-loop-finally local (car rest) (cdr rest))) - ((memq bare '(initially)) (scope-loop-initially local (car rest) (cdr rest))) - ((memq bare '(if when unless)) (scope-loop-if local kw (car rest) (cdr rest))) - ((memq bare '(end)) (scope-loop-end local rest)) - ((memq bare '(and else)) (scope-loop-and local rest))))))))) + ((memq bare '(for as)) + (scope-loop-for local local (car rest) (cdr rest))) + ((memq bare '( repeat while until always never thereis iter-by + return)) + (scope-loop-repeat local (car rest) (cdr rest))) + ((memq bare '(collect append nconc concat vconcat count sum maximize minimize)) + (scope-loop-collect local (car rest) (cdr rest))) + ((memq bare '(with)) + (scope-loop-with local (car rest) (cdr rest))) + ((memq bare '(do)) (scope-loop-do local (car rest) (cdr rest))) + ((memq bare '(named)) (scope-loop-named local (car rest) (cdr rest))) + ((memq bare '(finally)) (scope-loop-finally local (car rest) (cdr rest))) + ((memq bare '(initially)) (scope-loop-initially local (car rest) (cdr rest))) + ((memq bare '(if when unless)) (scope-loop-if local kw (car rest) (cdr rest))) + ((memq bare '(end)) (scope-loop-end local rest)) + ((memq bare '(and else)) (scope-loop-and local rest)))))) (defun scope-named-let (local name bindings body) - (let ((bare (bare-symbol name)) - (beg (symbol-with-pos-pos name))) - (cons - (list beg (length (symbol-name bare)) beg) - (nconc - (mapcan (lambda (binding) - (cond - ((consp binding) - (cons - (let* ((sym (car binding)) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym)) - (len (length (symbol-name bare)))) - (list beg len beg)) - (scope-1 local (cadr binding)))) - (binding - (let* ((sym binding) - (beg (symbol-with-pos-pos sym)) - (bare (bare-symbol sym)) - (len (length (symbol-name bare)))) - (list (list beg len beg)))))) - bindings) - (let ((l local)) - (dolist (binding bindings) - (when-let ((sym (if (consp binding) (car binding) binding))) - (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l)))) - (let ((scope-flet-alist (cons (cons bare beg) scope-flet-alist))) (scope-n l body))))))) + (let ((bare (scope-sym-bare name)) + (beg (scope-sym-pos name))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (mapcan (lambda (binding) + (let* ((sym (car (ensure-list binding))) + (beg (symbol-with-pos-pos sym)) + (bare (bare-symbol sym))) + (nconc + (when beg (list (list beg (length (symbol-name bare)) beg))) + (scope-1 local (cadr binding))))) + bindings) + (let ((l local)) + (dolist (binding bindings) + (when-let ((sym (car (ensure-list binding))) + (bare (scope-sym-bare sym))) + (setq l (scope-local-new bare (scope-sym-pos sym) l)))) + (let ((scope-flet-alist (scope-local-new bare beg scope-flet-alist))) (scope-n l body)))))) + +(defun scope-with-slots (local spec-list object body) + (nconc + (scope-1 local object) + (scope-let local spec-list body))) (defvar scope-assume-func-p nil) (defun scope-1 (local form &optional top-level) (cond ((consp form) - (let ((f (car form)) - (forms (cdr form))) - (cond - ((symbol-with-pos-p f) - (let ((bare (bare-symbol f))) + (let* ((f (car form)) (bare (scope-sym-bare f)) + (forms (cdr form))) + (when bare + (cond + ((assq bare scope-flet-alist) + (cons (list (symbol-with-pos-pos f) (length (symbol-name bare)) + (alist-get bare scope-flet-alist)) + (scope-n local forms))) + ((get bare 'scope-function) + (funcall (get bare 'scope-function) local forms)) + ((eq bare 'eval) + (nconc + (let ((q (scope-sym-bare (car-safe (car forms))))) + (cond + ((eq q 'quote) (scope-1 local (cadar forms))) + ((and (memq q '(function \`)) + (symbol-with-pos-p (cadar forms))) + (scope-s local (cadar forms))))) + (if (symbol-with-pos-p f) + (cons + (list (symbol-with-pos-pos f) (length (symbol-name bare)) 'function) + (scope-n local forms)) + (scope-n local forms)))) + ((functionp bare) + (if (symbol-with-pos-p f) + (cons + (list (symbol-with-pos-pos f) (length (symbol-name bare)) 'function) + (scope-n local forms)) + (scope-n local forms))) + ((special-form-p bare) (cond - ((functionp bare) - (cons - (list (symbol-with-pos-pos f) (length (symbol-name bare)) 'function) - (scope-n local forms))) - ((or (memq bare '( if and or while - save-excursion save-restriction save-current-buffer - catch unwind-protect - progn prog1 eval-when-compile eval-and-compile with-eval-after-load - with-memoization cl-assert cl-incf cl-decf setf - ;; We could recognize contant symbols bindings - ;; in `cl-progv', but it is not really worth the - ;; trouble since this macro is specifically - ;; intended for computing bindings at run time. - cl-progv)) - (eq (get bare 'edebug-form-spec) t)) + ((eq bare 'let) + (scope-let local (car forms) (cdr forms))) + ((eq bare 'let*) + (scope-let* local (car forms) (cdr forms))) + ((eq bare 'cond) (scope-cond local forms)) + ((eq bare 'setq) (scope-setq local forms)) + ((memq bare '( defconst defvar)) + (scope-defvar local (car forms) (cadr forms))) + ((eq bare 'condition-case) + (scope-condition-case local (car forms) (cadr forms) (cddr forms))) + ((eq bare 'function) + (scope-sharpquote local (car forms))) + ((memq bare '( if and or while + save-excursion save-restriction save-current-buffer + catch unwind-protect + progn prog1)) + (scope-n local forms)))) + ((macrop bare) + (cond + ((eq (get bare 'edebug-form-spec) t) (scope-n local forms)) + ((eq bare 'lambda) (scope-lambda local (car forms) (cdr forms))) + ((eq bare 'cl-loop) (scope-loop local forms)) + ((memq bare '(named-let)) + (scope-named-let local (car forms) (cadr forms) (cdr forms))) + ((memq bare '(cl-flet)) + (scope-flet local (car forms) (cdr forms))) + ((memq bare '(cl-labels)) + (scope-labels local (car forms) (cdr forms))) + ((memq bare '(eval-when-compile eval-and-compile)) (scope-n local forms)) - ((macrop bare) - (cond - ((memq bare '( defun defmacro defsubst define-inline)) - (scope-defun local (car forms) (cadr forms) (cddr forms))) - ((memq bare '( cl-defgeneric)) - (scope-defgeneric local (car forms) (cadr forms) (cddr forms))) - ((memq bare '(cl-case)) - (scope-case local (car forms) (cdr forms))) - ((memq bare '( cl-defun)) - (scope-cl-defun local (car forms) (cadr forms) (cddr forms))) - ((memq bare '( cl-defmethod)) - (scope-defmethod local (car forms) (cdr forms))) - ((memq bare '(lambda)) - (scope-defun local nil (car forms) (cdr forms))) - ((memq bare '(declare-function)) - (scope-declare-function local (car forms) (cadr forms) - (caddr forms) (cadddr forms))) - ((memq bare '(let-when-compile)) - (scope-let* local (car forms) (cdr forms))) - ((memq bare '(if-let when-let and-let)) - (scope-if-let local (car forms) (cdr forms))) - ((memq bare '(if-let* when-let* and-let* while-let)) - (scope-if-let* local (car forms) (cdr forms))) - ((memq bare '( defvar-local defcustom)) - (scope-defvar local (car forms) (cadr forms))) - ((memq bare '(dolist dotimes)) - (scope-dotimes local (caar forms) (cadar forms) (caddar forms) (cdr forms))) - ((memq bare '(pcase pcase-exhaustive)) - (scope-pcase local (car forms) (cdr forms))) - ((memq bare '(pcase-lambda)) - (scope-pcase-lambda local (car forms) (cdr forms))) - ((memq bare '(pcase-dolist)) - (scope-pcase-dolist local (caar forms) (cadar forms) (cdr forms))) - ((memq bare '(pcase-let)) - (scope-pcase-let local (car forms) (cdr forms))) - ((memq bare '(pcase-let*)) - (scope-pcase-let* local (car forms) (cdr forms))) - ((memq bare '(cl-loop)) - (scope-loop local forms)) - ((memq bare '(setq-local setq-default)) - (scope-setq local forms)) - ((memq bare '(push)) - (scope-push local (car forms) (cadr forms))) - ((memq bare '(pop oref)) - (scope-1 local (car forms))) - ((memq bare '(letrec)) - (scope-letrec local (car forms) (cdr forms))) - ((memq bare '(named-let)) - (scope-named-let local (car forms) (cadr forms) (cdr forms))) - ((memq bare '(cl-flet)) - (scope-flet local (car forms) (cdr forms))) - ((memq bare '(cl-labels)) - (scope-labels local (car forms) (cdr forms))) - ((memq bare '(minibuffer-with-setup-hook)) - (scope-minibuffer-with-setup-hook local (car forms) (cdr forms))) - ((memq bare '(condition-case-unless-debug)) - (scope-condition-case local (car forms) (cadr forms) (cddr forms))) - ((memq bare '(seq-let)) - (scope-seq-let local (car forms) (cadr forms) (cddr forms))) - ((memq bare '( define-derived-mode)) - (scope-define-derived local (car forms) (cadr forms) (caddr forms) (cdddr forms))) - ((memq bare '( define-minor-mode)) - (scope-define-minor local (car forms) (cadr forms) (cddr forms))) - ((memq bare '(inline-quote)) - (scope-backquote local (car forms))) - ((memq bare '(inline-letevals)) - (scope-let local (car forms) (cdr forms))) - ((memq bare '(with-suppressed-warnings)) - (scope-n local (cdr forms))) - ((memq bare '(cl-block)) - (scope-block local (car forms) (cdr forms))) - ((memq bare '(cl-return-from)) - (scope-return-from local (car forms) (cadr forms))) - ((memq bare '(cl-return)) - (scope-return-from local nil (cadr forms))) - ((get bare 'scope-function) ;For custom extensions. - (funcall (get bare 'scope-function) local forms)))) - ((special-form-p bare) - (cond - ((eq bare 'let) - (scope-let local (car forms) (cdr forms))) - ((eq bare 'let*) - (scope-let* local (car forms) (cdr forms))) - ((eq bare 'cond) (scope-cond local forms)) - ((eq bare 'setq) (scope-setq local forms)) - ((memq bare '( defconst defvar)) - (scope-defvar local (car forms) (cadr forms))) - ((eq bare 'condition-case) - (scope-condition-case local (car forms) (cadr forms) (cddr forms))) - ((get bare 'scope-function) - (funcall (get bare 'scope-function) local forms)))) - ((assq bare scope-flet-alist) - (cons (list (symbol-with-pos-pos f) (length (symbol-name bare)) - (alist-get bare scope-flet-alist)) - (scope-n local forms))) - ((get bare 'scope-function) - (funcall (get bare 'scope-function) local forms)) - ;; Assume nothing about unknown top-level forms. - (top-level nil) - (scope-assume-func-p (scope-n local forms))))) - ;; Symbol without position, a quotation marker that the reader - ;; expands into a symbol but does not annotate with a position. - ((symbolp f) - (cond - ((eq f '\`) (scope-backquote local (car forms))) - ((eq f 'function) (scope-sharpquote local (car forms)))))))) - ((symbol-with-pos-p form) - (scope-s local form)))) + ((memq bare '(with-slots)) + (scope-with-slots local (car forms) (cadr forms) (cddr forms))) + ;; ((memq bare '( defun defmacro defsubst define-inline)) + ;; (scope-defun local (car forms) (cadr forms) (cddr forms))) + ;; FIXME: Bring back manual handling of cl-def*, these macros + ;; are evil in the sense that they macroexpand their bodies + ;; for optimization. That means we don't see important + ;; intermediate forms, like `with-slots'. + ;; ((memq bare '( cl-defgeneric)) + ;; (scope-defgeneric local (car forms) (cadr forms) (cddr forms))) + ;; ((memq bare '(cl-case)) + ;; (scope-case local (car forms) (cdr forms))) + ;; ((memq bare '( cl-defun)) + ;; (scope-cl-defun local (car forms) (cadr forms) (cddr forms))) + ;; ((memq bare '( cl-defmethod)) + ;; (scope-defmethod local (car forms) (cdr forms))) + ;; ((memq bare '(declare-function)) + ;; (scope-declare-function local (car forms) (cadr forms) + ;; (caddr forms) (cadddr forms))) + ;; ((memq bare '(let-when-compile)) + ;; (scope-let* local (car forms) (cdr forms))) + ;; ((memq bare '(if-let when-let and-let)) + ;; (scope-if-let local (car forms) (cdr forms))) + ;; ((memq bare '(if-let* when-let* and-let* while-let)) + ;; (scope-if-let* local (car forms) (cdr forms))) + ;; ((memq bare '( defvar-local defcustom)) + ;; (scope-defvar local (car forms) (cadr forms))) + ;; ((memq bare '(dolist dotimes)) + ;; (scope-dotimes local (caar forms) (cadar forms) (caddar forms) (cdr forms))) + ;; ((memq bare '(pcase pcase-exhaustive)) + ;; (scope-pcase local (car forms) (cdr forms))) + ;; ((memq bare '(pcase-lambda)) + ;; (scope-pcase-lambda local (car forms) (cdr forms))) + ;; ((memq bare '(pcase-dolist)) + ;; (scope-pcase-dolist local (caar forms) (cadar forms) (cdr forms))) + ;; ((memq bare '(pcase-let)) + ;; (scope-pcase-let local (car forms) (cdr forms))) + ;; ((memq bare '(pcase-let*)) + ;; (scope-pcase-let* local (car forms) (cdr forms))) + ;; ((memq bare '(setq-local setq-default)) + ;; (scope-setq local forms)) + ;; ((memq bare '(push)) + ;; (scope-push local (car forms) (cadr forms))) + ;; ((memq bare '(pop oref)) + ;; (scope-1 local (car forms))) + ;; ((memq bare '(letrec)) + ;; (scope-letrec local (car forms) (cdr forms))) + ;; ((memq bare '(minibuffer-with-setup-hook)) + ;; (scope-minibuffer-with-setup-hook local (car forms) (cdr forms))) + ;; ((memq bare '(condition-case-unless-debug)) + ;; (scope-condition-case local (car forms) (cadr forms) (cddr forms))) + ;; ((memq bare '(seq-let)) + ;; (scope-seq-let local (car forms) (cadr forms) (cddr forms))) + ;; ((memq bare '( define-derived-mode)) + ;; (scope-define-derived local (car forms) (cadr forms) (caddr forms) (cdddr forms))) + ;; ((memq bare '( define-minor-mode)) + ;; (scope-define-minor local (car forms) (cadr forms) (cddr forms))) + ;; ((memq bare '(inline-quote)) + ;; (scope-backquote local (car forms))) + ;; ((memq bare '(inline-letevals)) + ;; (scope-let local (car forms) (cdr forms))) + ;; ((memq bare '(with-suppressed-warnings)) + ;; (scope-n local (cdr forms))) + ((memq bare '(cl-block)) + (scope-block local (car forms) (cdr forms))) + ((memq bare '(cl-return-from)) + (scope-return-from local (car forms) (cadr forms))) + ;; ((memq bare '(cl-return)) + ;; (scope-return-from local nil (cadr forms))) + ;; ((get bare 'scope-function) ;For custom extensions. + ;; (funcall (get bare 'scope-function) local forms)) + (t (scope-1 local (let ((symbols-with-pos-enabled t)) + (macroexpand-1 form)))))) + ;; Assume nothing about unknown top-level forms. + (top-level nil) + (scope-assume-func-p (scope-n local forms)))))) + ((symbol-with-pos-p form) (scope-s local form)))) (defun scope-n (local body) (mapcan (apply-partially #'scope-1 local) body)) @@ -1197,7 +1189,8 @@ starting with a top-level form, by inspecting HEAD at each level: and returns nil. If an unknown HEAD occurs in a nested form, by default it is similarly ignored, but if you set `scope-assume-func-p' to non-nil, then this function assumes that such HEADs are functions." - (scope-1 nil (read-positioning-symbols stream) t)) + (let ((scope-counter 0)) (scope-1 nil (read-positioning-symbols stream) t))) + (provide 'scope) ;;; scope.el ends here -- 2.39.2