;; 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))
"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)
(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)))
(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
(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)
(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)))
(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)
(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)))
(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)))
(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
(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)))
(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)
(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))
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
projects / emacs.git / commitdiff