-;;; scope.el --- Scope analysis for Emacs Lisp -*- lexical-binding: t; -*-
+;;; scope.el --- Analyze scope of Lisp symbols -*- lexical-binding: t; -*-
;; Copyright (C) 2024 Eshel Yaron
;;; Commentary:
-;; Scope analysis for Emacs Lisp.
-
-;;; Todo:
-
-;; - Fix handling of generalized variables.
-;; - Take callback argument instead of returning list.
+;; Symbol-scope analysis for Emacs Lisp.
;;; Code:
(defvar scope-counter nil)
+(defvar scope-callback #'ignore)
+
(defsubst scope-local-get (sym local)
"Get binding position of symbol SYM in local context LOCAL."
(alist-get sym local))
(defsubst scope-sym-pos (sym)
(when (symbol-with-pos-p sym) (symbol-with-pos-pos sym)))
+(defsubst scope-sym-bare (sym)
+ (cond
+ ((symbolp sym) sym)
+ ((symbol-with-pos-p sym) (bare-symbol sym))))
+
(defun scope-s (local sym)
(let* ((beg (scope-sym-pos sym))
(bare (bare-symbol sym))
(len (length (symbol-name bare))))
(unless (or (booleanp bare) (keywordp bare) (null beg))
- (list (list beg len (scope-local-get bare local))))))
+ (funcall scope-callback 'variable beg len (scope-local-get bare local)))))
(defun scope-let-1 (local0 local bindings body)
(if bindings
(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)))
+ (when beg (funcall scope-callback 'variable 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)
(bare (bare-symbol sym))
(len (length (symbol-name bare)))
(beg (scope-sym-pos sym)))
- (nconc
- (when beg (list (list beg len beg)))
- (scope-1 local (cadr binding))
- (scope-let*
- (scope-local-new bare beg local) (cdr bindings) body)))
+ (when beg (funcall scope-callback 'variable beg len beg))
+ (scope-1 local (cadr binding))
+ (scope-let*
+ (scope-local-new bare beg local) (cdr bindings) body))
(scope-n local body)))
(defun scope-if-let* (local bindings body)
(let* ((sym (car binding))
(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)))
+ (when beg
+ (funcall scope-callback 'variable
+ 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)))
+ (scope-1 local (car binding))
+ (scope-if-let* local (cdr bindings) body))
;; BINDING is just SYMBOL.
(let* ((sym binding)
(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)))))
+ (when beg
+ (funcall scope-callback 'variable
+ 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)
(eq (bare-symbol (caar body)) 'interactive))
(setq int-spec (cadar body))
(setq body (cdr body)))
- (nconc
- (seq-keep (lambda (arg)
- (and (symbol-with-pos-p arg)
- (not (memq (bare-symbol arg) '(&optional &rest _)))
- (let* ((beg (symbol-with-pos-pos arg))
- (bare (bare-symbol arg))
- (len (length (symbol-name bare))))
- (list beg len beg))))
- args)
- (scope-1 local doc-form)
- (scope-1 local int-spec)
- (let ((l local))
- (dolist (arg args)
- (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-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))
+ (dolist (arg args)
+ (and (symbol-with-pos-p arg)
+ (not (memq (bare-symbol arg) '(&optional &rest _)))
+ (let* ((beg (symbol-with-pos-pos arg))
+ (bare (bare-symbol arg))
+ (len (length (symbol-name bare))))
+ (when beg (funcall scope-callback 'variable beg len beg)))))
+ (scope-1 local doc-form)
+ (scope-1 local int-spec)
+ (let ((l local))
+ (dolist (arg args)
+ (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-defun (local name args body)
+ (when-let ((beg (scope-sym-pos name))
+ (bare (scope-sym-bare name)))
+ (funcall scope-callback 'defun beg (length (symbol-name bare)) nil))
+ (scope-lambda local args body))
(defun scope-cond (local clauses)
- (let ((res nil))
- (dolist (clause clauses)
- (setq res (nconc (scope-n local clause) res)))
- res))
+ (dolist (clause clauses) (scope-n local clause)))
(defun scope-setq (local args)
- (when args
- (let ((var (car args)) (val (cadr args)))
- (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-handlers (local handlers)
- (when handlers
- (nconc
- (scope-n local (cdar handlers))
- (scope-condition-case-handlers local (cdr handlers)))))
+ (let ((var nil) (val nil))
+ (while args
+ (setq var (car args)
+ val (cadr args)
+ args (cddr args))
+ (scope-s local var)
+ (scope-1 local val))))
+
+(defun scope-defvar (local name init)
+ (when-let ((beg (scope-sym-pos name))
+ (bare (scope-sym-bare name)))
+ (funcall scope-callback 'defvar beg (length (symbol-name bare)) nil))
+ (scope-1 local init))
(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)))
+ (l (scope-local-new bare beg local)))
+ (when beg
+ (funcall scope-callback 'variable beg (length (symbol-name bare)) beg))
+ (scope-1 local bodyform)
+ (dolist (handler handlers) (scope-n l (cdr handler)))))
(defun scope--backquote (local elements depth)
(cond
(scope--backquote local (cdr elements) (1- depth)))
((eq (car elements) '\`)
(scope--backquote local (cdr elements) (1+ depth)))
- (t (nconc (scope--backquote local (car elements) depth)
- (scope--backquote local (cdr elements) depth)))))
+ (t (scope--backquote local (car elements) depth)
+ (scope--backquote local (cdr elements) depth))))
((vectorp elements)
(scope--backquote local (append elements nil) depth))))
(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))))
+ (when beg
+ (funcall scope-callback 'function 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)
(body (cddr def))
(beg (scope-sym-pos func))
(bare (bare-symbol func)))
+ (when beg
+ (funcall scope-callback 'function beg (length (symbol-name bare)) beg))
(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-lambda local args body)
+ (scope-flet local (cdr defs) forms)))
(scope-n local forms)))
(defvar scope-block-alist nil)
(if name
(let* ((beg (scope-sym-pos name))
(bare (bare-symbol 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-n local body))))
+ (when beg
+ (funcall scope-callback 'block 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)))
(defun scope-return-from (local name result)
- (if-let ((bare (and (symbol-with-pos-p name) (bare-symbol name)))
- (pos (alist-get bare scope-block-alist)))
- (cons
- (list (symbol-with-pos-pos name) (length (symbol-name bare)) pos)
- (scope-1 local result))
- (scope-1 local result)))
+ (when-let ((bare (and (symbol-with-pos-p name) (bare-symbol name)))
+ (pos (alist-get bare scope-block-alist)))
+ (funcall scope-callback 'block
+ (symbol-with-pos-pos name) (length (symbol-name bare)) pos))
+ (scope-1 local result))
(defun scope-sharpquote (local arg)
(cond
(let ((bare (bare-symbol arg))
(beg (scope-sym-pos arg)))
(cond
- ((functionp bare) (when beg (list (list beg (length (symbol-name bare)) 'function))))
+ ((functionp bare)
+ (when beg
+ (funcall scope-callback 'function beg (length (symbol-name bare)) nil)))
((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)
- (and (symbol-with-pos-p arg)
- (not (memq (bare-symbol arg) '(&optional &rest _)))
- (let* ((beg (symbol-with-pos-pos arg))
- (bare (bare-symbol arg))
- (len (length (symbol-name bare))))
- (list beg len beg))))
- arglist))
-
-(defun scope-case (local expr clauses)
- (nconc (scope-1 local expr)
- (mapcan (lambda (clause) (scope-n local (cdr clause))) clauses)))
-
-(defun scope-define-derived (local _child _parent _name body)
- (when (stringp (car body)) (setq body (cdr body)))
- (while (keywordp (car body)) (setq body (cddr body)))
- (scope-n local body))
-
-(defun scope-define-minor (local _mode _doc body)
- (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)))
-
-(defsubst scope-sym-bare (sym)
- (cond
- ((symbolp sym) sym)
- ((symbol-with-pos-p sym) (bare-symbol sym))))
+(defun scope-declare-function (local fn _file arglist _fileonly)
+ (scope-defun local fn arglist nil))
(defun scope-loop-for-and (local rest)
(if (eq (scope-sym-bare (car rest)) 'and)
(scope-loop local rest)))
(defun scope-loop-for-by (local0 local expr rest)
- (nconc (scope-1 local0 expr) (scope-loop-for-and local rest)))
+ (scope-1 local0 expr)
+ (scope-loop-for-and local rest))
(defun scope-loop-for-to (local0 local expr rest)
- (nconc
- (scope-1 local0 expr)
- (when-let ((bare (scope-sym-bare (car rest)))
- (more (cdr rest)))
- (cond
- ((eq bare 'by)
- (scope-loop-for-by local0 local (car more) (cdr more)))
- (t (scope-loop-for-and local rest))))))
+ (scope-1 local0 expr)
+ (when-let ((bare (scope-sym-bare (car rest)))
+ (more (cdr rest)))
+ (cond
+ ((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)
- (when-let ((bare (scope-sym-bare (car rest)))
- (more (cdr rest)))
- (cond
- ((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))))))
+ (scope-1 local0 expr)
+ (when-let ((bare (scope-sym-bare (car rest)))
+ (more (cdr rest)))
+ (cond
+ ((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)
- (when-let ((bare (scope-sym-bare (car rest)))
- (more (cdr rest)))
- (cond
- ((eq bare 'then)
- (scope-loop-for-by local0 local (car more) (cdr more)))
- (t (scope-loop-for-and local rest))))))
+ (scope-1 local0 expr)
+ (when-let ((bare (scope-sym-bare (car rest)))
+ (more (cdr rest)))
+ (cond
+ ((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 (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))))
+ (when beg
+ (funcall scope-callback 'variable 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)
- (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))))))
+ (scope-1 local0 expr)
+ (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-let ((bare (scope-sym-bare word)))
(let* ((var (car (ensure-list vars)))
(bare (bare-symbol var))
(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)))
+ (when beg
+ (funcall scope-callback 'variable beg (length (symbol-name bare)) beg))
+ (scope-loop-for local0 (scope-local-new bare beg local) (cdr-safe vars) rest))
(when-let ((bare (scope-sym-bare (car rest)))
(more (cdr rest)))
(cond
(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)))
+ (scope-1 local form)
+ (scope-loop local rest))
(defun scope-loop-collect (local expr rest)
- (nconc
- (scope-1 local expr)
- (let ((bw (scope-sym-bare (car rest)))
- (more (cdr rest)))
- (if (eq bw 'into)
- (let* ((var (car more))
- (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)))))
+ (scope-1 local expr)
+ (let ((bw (scope-sym-bare (car rest)))
+ (more (cdr rest)))
+ (if (eq bw 'into)
+ (let* ((var (car more))
+ (bare (scope-sym-bare var))
+ (beg (scope-sym-pos var)))
+ (when beg
+ (funcall scope-callback 'variable
+ 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 (eq (scope-sym-bare (car rest)) 'and)
(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)))))
+ (when beg
+ (funcall scope-callback 'variable beg (length (symbol-name bare)) beg))
+ (if (eq (scope-sym-bare eql) '=)
+ (let* ((val (cadr rest)) (more (cddr rest)))
+ (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-1 local form)
- (if (consp (car rest))
- (scope-loop-do local (car rest) (cdr rest))
- (scope-loop local rest))))
+ (scope-1 local form)
+ (if (consp (car rest))
+ (scope-loop-do local (car rest) (cdr rest))
+ (scope-loop local rest)))
(defun scope-loop-named (local name rest)
(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)))))
+ (when beg
+ (funcall scope-callback 'block 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-let ((bare (scope-sym-bare next)))
((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-1 local (car rest))
+ (scope-loop local (cdr rest))))
(scope-loop-do local next rest)))
(defun scope-loop-initially (local next rest)
(defvar scope-loop-if-depth 0)
(defun scope-loop-if (local keyword condition rest)
- (nconc (scope-1 local condition)
- (let ((scope-loop-if-depth (1+ scope-loop-if-depth)))
- (scope-loop
- ;; `if' binds `it'.
- (scope-local-new 'it (scope-sym-pos keyword) local)
- rest))))
+ (scope-1 local condition)
+ (let ((scope-loop-if-depth (1+ scope-loop-if-depth)))
+ (scope-loop
+ ;; `if' binds `it'.
+ (scope-local-new 'it (scope-sym-pos keyword) local)
+ rest)))
(defun scope-loop-end (local rest)
(let ((scope-loop-if-depth (1- scope-loop-if-depth)))
(defun scope-named-let (local name bindings 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))))))
+ (when beg
+ (funcall scope-callback 'function beg (length (symbol-name bare)) beg))
+ (dolist (binding bindings)
+ (let* ((sym (car (ensure-list binding)))
+ (beg (symbol-with-pos-pos sym))
+ (bare (bare-symbol sym)))
+ (when beg
+ (funcall scope-callback 'variable beg (length (symbol-name bare)) beg))
+ (scope-1 local (cadr binding))))
+ (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)))
+ (scope-1 local object)
+ (scope-let local spec-list body))
(defvar scope-assume-func-p nil)
(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)))
+ (funcall scope-callback 'function
+ (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))))
+ (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)))))
+ (when (symbol-with-pos-p f)
+ (funcall scope-callback 'function
+ (symbol-with-pos-pos f) (length (symbol-name bare))
+ nil))
+ (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)))
+ (when (symbol-with-pos-p f)
+ (funcall scope-callback 'function
+ (symbol-with-pos-pos f) (length (symbol-name bare))
+ nil))
+ (scope-n local forms))
((special-form-p bare)
(cond
((eq bare 'let)
(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))
+ ((memq bare '( eval-when-compile eval-and-compile
+ setf pop push with-memoization))
(scope-n local forms))
((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 '(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 '(setq-local setq-default))
+ (scope-setq local 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))))))
+ ;; Ignore errors from trying to expand
+ ;; invalid macro calls such as (dolist).
+ (ignore-errors (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))
+(defun scope-n (local body) (dolist (form body) (scope-1 local form)))
;;;###autoload
-(defun scope (&optional stream)
- "Read and scope-analyze code from STREAM.
+(defun scope (callback &optional stream)
+ "Read and analyze code from STREAM, reporting findings via CALLBACK.
+
+Call CALLBACK for each analyzed symbol SYM with arguments TYPE, POS, LEN
+and BINDER, where TYPE a symbol that specifies the semantics of SYM, one
+of `variable', `function', `block' `defun' and `defvar'; POS is the
+position of SYM in STREAM; LEN is SYM's length; and BINDER is the
+position in which SYM is bound. If SYM is itself a binding occurrence,
+then POS and BINDER are equal. If SYM is not lexically bound, then
+BINDER is nil.
-Return a bindings graph associating symbols with their binders. It is a
-list of elements (OCCURRENCE LEN BINDING) where OCCURRENCE is a buffer
-position where a symbol of length LEN occurs, which is lexically bound
-at position BINDING. If OCCURRENCE is itself a binding occurrence, then
-BINDING is equal to OCCURRENCE. If OCCURRENCE is variable that is not
-lexically bound, then BINDING is nil. If OCCURRENCE is a function name,
-then BINDING is \\+`function'.
+If STREAM is nil, it defaults to the current buffer.
This function recursively analyzes Lisp forms (HEAD . TAIL), usually
starting with a top-level form, by inspecting HEAD at each level:
- If HEAD satisfies `functionp', which means it is a function in the
running Emacs session, analzye the form as a function call.
-- Standard macros and special forms, such as `defun', `if', `let',
- `pcase', `cl-loop', quotes, backquotes and more, are handled specially
- according to their particular semantics.
+- Special forms such as `if', and `let', along with some standard macros
+ like `lambda', `setf' and backquotes, are handled specially according
+ to their particular semantics. Other macros are expanded.
-- If HEAD has the property symbol `scope-function', the value of this
+- If HEAD has the symbol property `scope-function', the value of this
property is used to analyze TAIL. It should be a function that takes
- two arguments, LOCAL and TAIL, and returns a bindings graph for TAIL.
- LOCAL represents the local context around the current form, the
+ two arguments, LOCAL and TAIL, and calls `scope-callback' to report on
+ analyzed symbols in TAIL. `scope-callback' is let-bound to CALLBACK.
+ LOCAL represents the local context around the current form; the
`scope-function' can pass LOCAL to functions such as `scope-1' and
- `scope-n' to obtain bindings graphs for sub-forms. See also
- `scope-local-new' for extending LOCAL with local bindings in TAIL.
+ `scope-n' to analyze sub-forms. See also `scope-local-new' for
+ extending LOCAL with local bindings while analyzing TAIL.
- If within the code under analysis HEAD is a `cl-flet'-bound local
function name, analyze the form as a function call.
- Otherwise, HEAD is unknown. If the HEAD of the top-level form that
- this function reads from STREAM is unknown, this function ignores it
- 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."
- (let ((scope-counter 0)) (scope-1 nil (read-positioning-symbols stream) t)))
-
+ this function reads from STREAM is unknown, then this function ignores
+ it and returns nil. If an unknown HEAD occurs in a nested form, then
+ by default it is similarly ignored, but if `scope-assume-func-p' is
+ non-nil, then this function assumes that such HEADs are functions."
+ (let ((scope-counter 0)
+ (scope-callback callback))
+ (scope-1 nil (read-positioning-symbols (or stream (current-buffer))) t)))
(provide 'scope)
;;; scope.el ends here
projects / emacs.git / commitdiff