(beg (scope-sym-pos var)))
(when beg
(scope-report 'variable
- beg (length (symbol-name bare)) beg))
+ beg (length (symbol-name bare)) beg))
(scope-loop (scope-local-new bare beg local) (cdr more)))
(scope-loop local rest))))
(when-let ((bare (scope-sym-bare name))
(beg (symbol-with-pos-pos name)))
(scope-report 'rx-construct
- beg (length (symbol-name bare)) beg))
+ beg (length (symbol-name bare)) beg))
(if (cdr rest)
(let ((l scope-rx-alist)
(args (car rest))
(scope-report 'throw-tag beg (length (symbol-name bare))))
(scope-n local body))
-(defun scope-face (_local face-form)
- (when-let (((memq (scope-sym-bare (car-safe face-form)) '(quote \`)))
- (face (cadr face-form)))
- (if (or (scope-sym-bare face)
- (keywordp (scope-sym-bare (car-safe face))))
- (scope-face-1 face)
- (mapc #'scope-face-1 face))))
+(defun scope-face (face)
+ (if (or (scope-sym-bare face)
+ (keywordp (scope-sym-bare (car-safe face))))
+ (scope-face-1 face)
+ (mapc #'scope-face-1 face)))
(defun scope-face-1 (face)
(cond
(defvar warning-minimum-log-level)
+(defmacro scope-define-analyzer (fsym args &rest body)
+ (declare (indent defun))
+ (let ((analyzer (intern (concat "scope--analyze-" (symbol-name fsym)))))
+ `(progn
+ (defun ,analyzer ,args ,@body)
+ (put ',fsym 'scope-analyzer #',analyzer))))
+
+(defmacro scope-define-function-analyzer (fsym args &rest body)
+ (declare (indent defun))
+ (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1"))))
+ `(progn
+ (defun ,helper ,args ,@body)
+ (scope-define-analyzer ,fsym (l f &rest args)
+ (scope-report-s f 'function)
+ (apply #',helper args)
+ (scope-n l args)))))
+
+(defmacro scope-define-macro-analyzer (fsym args &rest body)
+ (declare (indent defun))
+ (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1"))))
+ `(progn
+ (defun ,helper ,args ,@body)
+ (scope-define-analyzer ,fsym (l f &rest args)
+ (scope-report-s f 'macro)
+ (apply #',helper l args)))))
+
+(defmacro scope-define-special-form-analyzer (fsym args &rest body)
+ (declare (indent defun))
+ (let* ((helper (intern (concat "scope--analyze-" (symbol-name fsym) "-1"))))
+ `(progn
+ (defun ,helper ,args ,@body)
+ (scope-define-analyzer ,fsym (l f &rest args)
+ (scope-report-s f 'macro)
+ (apply #',helper l args)))))
+
+(defun scope--unqoute (form)
+ (when (memq (scope-sym-bare (car-safe form)) '(quote function \`))
+ (cadr form)))
+
+(scope-define-analyzer with-suppressed-warnings (l f warnings &rest body)
+ (scope-report-s f 'macro)
+ (dolist (warning warnings)
+ (when-let* ((wsym (car-safe warning)))
+ (scope-report-s wsym 'warning-type)))
+ (scope-n l body))
+
+(scope-define-analyzer eval (l f form &optional lexical)
+ (scope-report-s f 'function)
+ (if-let ((quoted (scope--unqoute form)))
+ (scope-1 l quoted)
+ (scope-1 l form))
+ (scope-1 l lexical))
+
+(scope-define-function-analyzer defalias (definition &optional _docstring)
+ (when-let ((quoted (scope--unqoute definition))) (scope-report-s quoted 'defun)))
+
+(scope-define-function-analyzer custom-declare-variable (sym _default _doc &rest args)
+ (when-let ((quoted (scope--unqoute sym))) (scope-report-s quoted 'defvar))
+ (while-let ((kw (car-safe args))
+ (bkw (scope-sym-bare kw))
+ ((keywordp bkw)))
+ (cl-case bkw
+ (:type
+ (when-let ((quoted (scope--unqoute (cadr args)))) (scope-widget-type-1 quoted)))
+ (:group
+ (when-let ((quoted (scope--unqoute (cadr args)))) (scope-report-s quoted 'group))))
+ (setq args (cddr args))))
+
+(scope-define-function-analyzer custom-declare-group (sym _members _doc &rest args)
+ (when-let ((quoted (scope--unqoute sym))) (scope-report-s quoted 'group))
+ (while-let ((kw (car-safe args))
+ (bkw (scope-sym-bare kw))
+ ((keywordp bkw)))
+ (cl-case bkw
+ (:group
+ (when-let ((quoted (scope--unqoute (cadr args)))) (scope-report-s quoted 'group))))
+ (setq args (cddr args))))
+
+(scope-define-function-analyzer custom-declare-face (face spec _doc &rest args)
+ (when-let ((q (scope--unqoute face))) (scope-report-s q 'defface))
+ (when-let ((q (scope--unqoute spec)))
+ (when (consp q) (dolist (s q) (scope-face (cdr s)))))
+ (while-let ((kw (car-safe args))
+ (bkw (scope-sym-bare kw))
+ ((keywordp bkw)))
+ (cl-case bkw
+ (:group
+ (when-let ((q (scope--unqoute (cadr args)))) (scope-report-s q 'group))))
+ (setq args (cddr args))))
+
+(scope-define-function-analyzer cl-typed (_val type)
+ (when-let ((q (scope--unqoute type)) ((not (booleanp q))))
+ (scope-report-s q 'type)))
+
+(scope-define-function-analyzer throw (tag _value)
+ (when-let ((q (scope--unqoute tag))) (scope-report-s q 'throw-tag)))
+
+(scope-define-function-analyzer run-hooks (&rest hooks)
+ (dolist (hook hooks)
+ (when-let ((q (scope--unqoute hook))) (scope-report-s q 'variable))))
+
+(scope-define-function-analyzer signal (error-symbol _data)
+ (when-let ((q (scope--unqoute error-symbol))) (scope-report-s q 'condition)))
+
+(scope-define-function-analyzer fboundp (symbol)
+ (when-let ((q (scope--unqoute symbol))) (scope-report-s q 'function)))
+
+(scope-define-function-analyzer overlay-put (_ov prop val)
+ (when-let ((q (scope--unqoute prop))
+ ((eq (scope-sym-bare q) 'face))
+ (face (scope--unqoute val)))
+ (scope-face face)))
+
+(scope-define-function-analyzer boundp (var &rest _)
+ (when-let ((q (scope--unqoute var))) (scope-report-s q 'variable)))
+
+(dolist (sym '( set symbol-value define-abbrev-table
+ special-variable-p local-variable-p
+ local-variable-if-set-p
+ default-value set-default make-local-variable
+ buffer-local-value add-to-list
+ add-hook remove-hook run-hook-with-args run-hook-wrapped))
+ (put sym 'scope-analyzer #'scope--analyze-boundp))
+
+(scope-define-function-analyzer defvaralias (new base &optional _docstring)
+ (when-let ((q (scope--unqoute new))) (scope-report-s q 'defvar))
+ (when-let ((q (scope--unqoute base))) (scope-report-s q 'variable)))
+
+(scope-define-function-analyzer define-error (name _message &optional parent)
+ (when-let ((q (scope--unqoute name))) (scope-report-s q 'condition))
+ (when-let ((q (scope--unqoute parent)))
+ (dolist (p (ensure-list q)) (scope-report-s p 'condition))))
+
+(scope-define-function-analyzer featurep (feature &rest _)
+ (when-let ((q (scope--unqoute feature))) (scope-report-s q 'feature)))
+
+(put 'provide 'scope-analyzer #'scope--analyze-featurep)
+(put 'require 'scope-analyzer #'scope--analyze-featurep)
+
+(scope-define-function-analyzer put-text-property (&optional _ _ prop val)
+ (when (eq 'face (scope-sym-bare (scope--unqoute prop)))
+ (when-let ((q (scope--unqoute val))) (scope-face q))))
+
+(put 'remove-overlays 'scope-analyzer #'scope--analyze-put-text-property)
+
+(scope-define-function-analyzer propertize (_string &rest props)
+ (while props
+ (cl-case (scope-sym-bare (scope--unqoute (car props)))
+ (face
+ (when-let ((q (scope--unqoute (cadr props)))) (scope-face q))))
+ (setq props (cddr props))))
+
+(scope-define-function-analyzer eieio-defclass-internal (name superclasses slots options)
+ (when-let ((q (scope--unqoute name))) (scope-report-s q 'type))
+ (when-let ((q (scope--unqoute superclasses)))
+ (dolist (sup q) (scope-report-s sup 'type))))
+
+(scope-define-function-analyzer cl-struct-define
+ (name _doc parent _type _named _slots _children _tab _print)
+ (when-let ((q (scope--unqoute name))) (scope-report-s q 'type))
+ (when-let ((q (scope--unqoute parent))) (scope-report-s q 'type)))
+
+(scope-define-function-analyzer define-widget (name class _doc &rest args)
+ (when-let ((q (scope--unqoute name))) (scope-report-s q 'widget-type))
+ (when-let ((q (scope--unqoute class))) (scope-report-s q 'type))
+ (while-let ((kw (car-safe args))
+ (bkw (scope-sym-bare kw))
+ ((keywordp bkw)))
+ (cl-case bkw
+ (:type
+ (when-let ((q (scope--unqoute (cadr args)))) (scope-widget-type-1 q)))
+ (:args
+ (when-let ((q (scope--unqoute (cadr args)))) (mapc #'scope-widget-type-1 q))))
+ (setq args (cddr args))))
+
+(scope-define-function-analyzer provide-theme (name &rest _)
+ (when-let ((q (scope--unqoute name))) (scope-report-s q 'theme)))
+
+(put 'custom-declare-theme 'scope-analyzer #'scope--analyze-provide-theme)
+
+(scope-define-macro-analyzer define-globalized-minor-mode (l global mode turn-on &rest body)
+ (scope-define-global-minor-mode l global mode turn-on body))
+
+(scope-define-macro-analyzer lambda (l args &rest body)
+ (scope-lambda l args body))
+
+(scope-define-macro-analyzer cl-loop (l &rest clauses)
+ (scope-loop l clauses))
+
+(scope-define-macro-analyzer named-let (l name bindings &rest body)
+ (scope-named-let l name bindings body))
+
+(scope-define-macro-analyzer cl-flet (l bindings &rest body)
+ (scope-flet l bindings body))
+
+(scope-define-macro-analyzer cl-labels (l bindings &rest body)
+ (scope-labels l bindings body))
+
+(scope-define-macro-analyzer with-slots (l spec-list object &rest body)
+ (scope-with-slots l spec-list object body))
+
+(scope-define-macro-analyzer cl-defmethod (l name &rest rest)
+ (scope-defmethod l name rest))
+
+(scope-define-macro-analyzer cl-destructuring-bind (l args expr &rest body)
+ (scope-1 l expr)
+ (scope-cl-lambda l args body))
+
+(scope-define-macro-analyzer declare-function (l fn file &optional arglist fileonly)
+ (scope-declare-function l fn file arglist fileonly))
+
+(scope-define-macro-analyzer cl-block (l name &rest body)
+ (scope-block l name body))
+
+(scope-define-macro-analyzer cl-return-from (l name &optional result)
+ (scope-return-from l name result))
+
+(scope-define-macro-analyzer rx (l &rest regexps)
+ ;; Unsafe macro!
+ (scope-rx l regexps))
+
+(scope-define-macro-analyzer rx-define (l name &rest rest)
+ (scope-rx-define l name rest))
+
+(scope-define-macro-analyzer rx-let (l bindings &rest body)
+ (scope-rx-let l bindings body))
+
+(scope-define-macro-analyzer let-when-compile (l bindings &rest body)
+ ;; Unsafe macro!
+ (scope-let* l bindings body))
+
+(scope-define-macro-analyzer cl-eval-when (l _when &rest body)
+ ;; Unsafe macro!
+ (scope-n l body))
+
+(scope-define-macro-analyzer cl-macrolet (l bindings &rest body)
+ ;; Unsafe macro!
+ (scope-cl-macrolet l bindings body))
+
+(scope-define-macro-analyzer gv-define-expander (l name handler)
+ (scope-gv-define-expander l name handler))
+
+(scope-define-macro-analyzer gv-define-simple-setter (l name setter &rest rest)
+ (scope-gv-define-simple-setter l name setter rest))
+
+(scope-define-macro-analyzer cl-deftype (l name arglist &rest body)
+ (scope-deftype l name arglist body))
+
+(scope-define-macro-analyzer define-minor-mode (l mode doc &rest body)
+ (scope-define-minor-mode l mode doc body))
+
+(scope-define-macro-analyzer setq-local (l &rest args)
+ (scope-setq l args))
+
+(put 'setq-default 'scope-analyzer #'scope--analyze-setq-local)
+
+(scope-define-macro-analyzer cl-defun (l name arglist &rest body)
+ (scope-cl-defun l name arglist body))
+
+(put 'cl-defmacro 'scope-analyzer #'scope--analyze-cl-defun)
+
+(scope-define-macro-analyzer defun (l name arglist &rest body)
+ (scope-defun l name arglist body))
+
+(put 'defmacro 'scope-analyzer #'scope--analyze-defun)
+(put 'ert-deftest 'scope-analyzer #'scope--analyze-defun)
+
+(scope-define-macro-analyzer setf (l &rest args)
+ (scope-n l args))
+
+(dolist (sym '( pop push with-memoization cl-pushnew
+ ;; The following macros evaluate unsafe code.
+ ;; Never expand them!
+ static-if eval-when-compile eval-and-compile))
+ (put sym 'scope-analyzer #'scope--analyze-setf))
+
+(scope-define-analyzer let-alist (l f alist &rest body)
+ (scope-report-s f 'macro)
+ (scope-1 l alist)
+ (let ((scope-current-let-alist-form
+ (cons (or (scope-sym-pos f) (cons 'gen (cl-incf scope-counter)))
+ (scope-sym-pos f))))
+ (scope-n l body)))
+
+(scope-define-special-form-analyzer let (l bindings &rest body)
+ (scope-let-1 l l bindings body))
+
+(scope-define-special-form-analyzer let* (l bindings &rest body)
+ (scope-let* l bindings body))
+
+(scope-define-special-form-analyzer cond (l &rest clauses)
+ (scope-cond l clauses))
+
+(scope-define-special-form-analyzer setq (l &rest args)
+ (scope-setq l args))
+
+(scope-define-special-form-analyzer defvar (l sym &optional init _doc)
+ (scope-defvar l sym init))
+
+(put 'defconst 'scope-analyzer #'scope--analyze-defvar)
+
+(scope-define-special-form-analyzer condition-case (l var bodyform &rest handlers)
+ (scope-condition-case l var bodyform handlers))
+
+(scope-define-special-form-analyzer function (l arg)
+ (scope-sharpquote l arg))
+
+(scope-define-special-form-analyzer quote (_l _arg)) ;Do nothing.
+
+(scope-define-special-form-analyzer catch (l tag &rest body)
+ (scope-catch l tag body))
+
+(defun scope-report-s (sym type)
+ (when-let* ((beg (scope-sym-pos sym)) (bare (bare-symbol sym)))
+ (scope-report type beg (length (symbol-name bare)))))
+
(defun scope-1 (local form)
(cond
((consp form)
(let* ((f (car form)) (bare (scope-sym-bare f))
- (forms (cdr form)))
+ (forms (cdr form)) (this nil))
(when bare
(cond
- ((assq bare scope-flet-alist)
- (scope-report 'function
- (symbol-with-pos-pos f) (length (symbol-name bare))
- (alist-get bare scope-flet-alist))
+ ((setq this (assq bare scope-flet-alist))
+ (scope-report
+ 'function (symbol-with-pos-pos f) (length (symbol-name bare)) this)
(scope-n local forms))
- ((assq bare scope-macrolet-alist)
- (scope-report 'macro
- (symbol-with-pos-pos f) (length (symbol-name bare))
- (alist-get bare scope-macrolet-alist))
+ ((setq this (assq bare scope-macrolet-alist))
+ (scope-report
+ 'macro (symbol-with-pos-pos f) (length (symbol-name bare)) this)
;; Local macros can be unsafe, so we do not expand them.
;; Hence we cannot interpret their arguments.
)
- ((get bare 'scope-function)
- (funcall (get bare 'scope-function) local forms))
- ((functionp bare)
- (cl-case bare
- (eval
- (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))))))
- (defalias
- (when-let* ((alias-form (car forms))
- ((eq (scope-sym-bare (car-safe alias-form)) 'quote))
- (alias (cadr alias-form))
- (beg (scope-sym-pos alias))
- (bare (scope-sym-bare alias)))
- (scope-report 'defun beg (length (symbol-name bare)))))
- (custom-declare-variable
- (when-let* ((sym-form (car forms))
- ((eq (scope-sym-bare (car-safe sym-form)) 'quote))
- (sym (cadr sym-form))
- (beg (scope-sym-pos sym))
- (bare (scope-sym-bare sym)))
- (scope-report 'defvar beg (length (symbol-name bare))))
- (when-let* ((props (cdddr forms))
- (symbols-with-pos-enabled t))
- (when-let ((val-form (plist-get props :type)))
- (scope-widget-type local val-form))
- (when-let ((val-form (plist-get props :group)))
- (scope-quoted-group local val-form))))
- (custom-declare-group
- (scope-quoted-group local (car forms))
- (when-let* ((props (cdddr forms))
- (symbols-with-pos-enabled t)
- (val-form (plist-get props :group)))
- (scope-quoted-group local val-form)))
- (custom-declare-face
- (when-let* ((alias-form (car forms))
- ((eq (scope-sym-bare (car-safe alias-form)) 'quote))
- (alias (cadr alias-form))
- (beg (scope-sym-pos alias))
- (bare (scope-sym-bare alias)))
- (scope-report 'defface beg (length (symbol-name bare))))
- (when-let* ((spec-form (cadr forms))
- ((eq (scope-sym-bare (car-safe spec-form)) 'quote))
- (specs (cadr spec-form))
- ((consp specs)))
- (dolist (spec specs)
- (scope-face local (list 'quote (cdr spec)))))
- (when-let* ((props (cdddr forms))
- (symbols-with-pos-enabled t))
- (when-let ((val-form (plist-get props :group)))
- (scope-quoted-group local val-form))))
- (cl-typep
- (when-let* ((alias-form (cadr forms))
- ((eq (scope-sym-bare (car-safe alias-form)) 'quote))
- (alias (cadr alias-form))
- (beg (scope-sym-pos alias))
- (bare (scope-sym-bare alias)))
- (unless (booleanp bare)
- (scope-report 'type beg (length (symbol-name bare))))))
- (throw
- (when-let* ((tag-form (car forms))
- ((memq (scope-sym-bare (car-safe tag-form)) '(quote \`)))
- (tag (cadr tag-form))
- (beg (scope-sym-pos tag))
- (bare (scope-sym-bare tag)))
- (scope-report 'throw-tag beg (length (symbol-name bare)))))
- (( boundp set symbol-value define-abbrev-table
- special-variable-p local-variable-p
- local-variable-if-set-p
- default-value set-default make-local-variable
- buffer-local-value add-to-list
- add-hook remove-hook run-hook-with-args run-hook-wrapped)
- (when-let* ((var-form (car forms))
- ((memq (scope-sym-bare (car-safe var-form)) '(quote \`)))
- (var (cadr var-form))
- (beg (scope-sym-pos var))
- (bare (scope-sym-bare var)))
- (scope-report 'variable beg (length (symbol-name bare)))))
- ((run-hooks)
- (dolist (var-form forms)
- (when-let* (((memq (scope-sym-bare (car-safe var-form)) '(quote \`)))
- (var (cadr var-form))
- (beg (scope-sym-pos var))
- (bare (scope-sym-bare var)))
- (scope-report 'variable beg (length (symbol-name bare))))))
- ((featurep provide require)
- (when-let* ((feat-form (car forms))
- ((memq (scope-sym-bare (car-safe feat-form)) '(quote \`)))
- (feat (cadr feat-form))
- (beg (scope-sym-pos feat))
- (bare (scope-sym-bare feat)))
- (scope-report 'feature beg (length (symbol-name bare)))))
- ((fboundp)
- (when-let* ((fun-form (car forms))
- ((memq (scope-sym-bare (car-safe fun-form)) '(quote \`)))
- (fun (cadr fun-form))
- (beg (scope-sym-pos fun))
- (bare (scope-sym-bare fun)))
- (scope-report 'function beg (length (symbol-name bare)))))
- (overlay-put
- (when-let* ((prop (cadr forms))
- ((memq (scope-sym-bare (car-safe prop)) '(quote \`)))
- ((eq (scope-sym-bare (cadr prop)) 'face)))
- (scope-face local (caddr forms))))
- ((remove-overlays put-text-property)
- (when-let* ((prop (caddr forms))
- ((memq (scope-sym-bare (car-safe prop)) '(quote \`)))
- ((eq (scope-sym-bare (cadr prop)) 'face)))
- (scope-face local (cadddr forms))))
- (propertize
- (when-let* ((props (cdr forms))
- (symbols-with-pos-enabled t)
- (val-form (plist-get props ''face #'equal)))
- (scope-face local val-form)))
- ((eieio-defclass-internal)
- (when-let* ((name-form (car forms))
- ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
- (name (cadr name-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'type beg (length (symbol-name bare))))
- (when-let* ((sups-form (cadr forms))
- ((memq (scope-sym-bare (car-safe sups-form)) '(quote \`)))
- (sups (cadr sups-form)))
- (dolist (sup (cadr sups-form))
- (when-let* ((beg (scope-sym-pos sup)) (bare (scope-sym-bare sup)))
- (scope-report 'type beg (length (symbol-name bare)))))))
- ((cl-struct-define)
- (when-let* ((name-form (car forms))
- ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
- (name (cadr name-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'type beg (length (symbol-name bare))))
- (when-let* ((prnt-form (caddr forms))
- ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`)))
- (prnt (cadr prnt-form))
- (beg (scope-sym-pos prnt))
- (bare (scope-sym-bare prnt)))
- (scope-report 'type beg (length (symbol-name bare)))))
- ((define-widget)
- (when-let* ((name-form (car forms))
- ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
- (name (cadr name-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'widget-type beg (length (symbol-name bare))))
- (when-let* ((prnt-form (cadr forms))
- ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`)))
- (prnt (cadr prnt-form))
- (beg (scope-sym-pos prnt))
- (bare (scope-sym-bare prnt)))
- (scope-report 'widget-type beg (length (symbol-name bare))))
- (when-let* ((props (cdddr forms))
- (symbols-with-pos-enabled t))
- (when-let ((val-form (plist-get props :type)))
- (scope-widget-type local val-form))
- (when-let ((val-form (plist-get props :args))
- ((memq (scope-sym-bare (car-safe val-form)) '(quote \`)))
- (val (cadr val-form))
- ((consp val)))
- (mapc #'scope-widget-type-1 val))))
- ((define-error)
- (when-let* ((name-form (car forms))
- ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
- (name (cadr name-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'condition beg (length (symbol-name bare))))
- (when-let* ((prnt-form (caddr forms))
- ((memq (scope-sym-bare (car-safe prnt-form)) '(quote \`))))
- (dolist (prnt (ensure-list (cadr prnt-form)))
- (when-let* ((beg (scope-sym-pos prnt)) (bare (scope-sym-bare prnt)))
- (scope-report 'condition beg (length (symbol-name bare)))))))
- ((signal)
- (when-let* ((name-form (car forms))
- ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
- (name (cadr name-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'condition beg (length (symbol-name bare)))))
- ((provide-theme custom-declare-theme)
- (when-let* ((name-form (car forms))
- ((memq (scope-sym-bare (car-safe name-form)) '(quote \`)))
- (name (cadr name-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'theme beg (length (symbol-name bare)))))
- ((defvaralias)
- (when-let* ((new-form (car forms))
- ((memq (scope-sym-bare (car-safe new-form)) '(quote \`)))
- (name (cadr new-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'defvar beg (length (symbol-name bare))))
- (when-let* ((base-form (cadr forms))
- ((memq (scope-sym-bare (car-safe base-form)) '(quote \`)))
- (name (cadr base-form))
- (beg (scope-sym-pos name))
- (bare (scope-sym-bare name)))
- (scope-report 'variable beg (length (symbol-name bare))))))
- (when (symbol-with-pos-p f)
- (scope-report 'function
- (symbol-with-pos-pos f) (length (symbol-name bare))))
- (scope-n local forms))
- ((special-form-p bare)
- (when (symbol-with-pos-p f)
- (scope-report 'special-form
- (symbol-with-pos-pos f) (length (symbol-name 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)))
- ((eq bare 'function)
- (scope-sharpquote local (car forms)))
- ((eq bare 'catch)
- (scope-catch local (car forms) (cdr forms)))
- ((memq bare '( if and or while
- save-excursion save-restriction save-current-buffer
- unwind-protect
- progn prog1))
- (scope-n local forms))))
- ((macrop bare)
- (when (symbol-with-pos-p f)
- (scope-report 'macro
- (symbol-with-pos-pos f) (length (symbol-name bare))))
+ ((setq this (function-get bare 'scope-analyzer)) (apply this local form))
+ ((functionp bare) (scope-report-s f 'function) (scope-n local forms))
+ ((special-form-p bare) (scope-report-s f 'special-form) (scope-n local forms))
+ ((macrop bare) (scope-report-s f 'macro)
(cond
- ((memq bare '(let-alist))
- (scope-1 local (car forms))
- (let ((scope-current-let-alist-form
- (cons (or (scope-sym-pos f)
- (cons 'gen (cl-incf scope-counter)))
- (scope-sym-pos f))))
- (scope-n local (cdr forms))))
((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 '( setf pop push with-memoization cl-pushnew
- ;; The following macros evaluate unsafe code.
- ;; Never expand them!
- static-if eval-when-compile eval-and-compile))
- (scope-n local forms))
- ((memq bare '(with-suppressed-warnings))
- (dolist (warning (car forms))
- (when-let* ((wsym (car-safe warning))
- (beg (scope-sym-pos wsym))
- (bare (scope-sym-bare wsym)))
- (scope-report 'warning-type beg
- (length (symbol-name bare)))))
- (scope-n local (cdr forms)))
- ((memq bare '(with-slots))
- (scope-with-slots local (car forms) (cadr forms) (cddr forms)))
- ((memq bare '(defun defmacro ert-deftest))
- (scope-defun local (car forms) (cadr forms) (cddr forms)))
- ((eq bare 'cl-defmethod)
- (scope-defmethod local (car forms) (cdr forms)))
- ((memq bare '(cl-defun cl-defmacro))
- (scope-cl-defun local (car forms) (cadr forms) (cddr forms)))
- ((memq bare '(cl-destructuring-bind))
- (scope-1 local (cadr forms))
- (scope-cl-lambda local (car forms) (cddr forms)))
- ((memq bare '(declare-function))
- (scope-declare-function local (car forms) (cadr forms)
- (caddr forms) (cadddr 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 '(rx)) ; `rx' is unsafe, never expand!
- (scope-rx local forms))
- ((memq bare '(rx-define))
- (scope-rx-define local (car forms) (cdr forms)))
- ((memq bare '(rx-let))
- (scope-rx-let local (car forms) (cdr forms)))
- ;; ((memq bare '(rx-let-eval))
- ;; (scope-rx-let-eval local (car forms) (cdr forms)))
- ((memq bare '(let-when-compile)) ; `let-when-compile' too!
- (scope-let* local (car forms) (cdr forms)))
- ((memq bare '(cl-eval-when)) ; Likewise!
- (scope-n local (cdr forms)))
- ((memq bare '(cl-macrolet)) ; Also `cl-macrolet'.
- (scope-cl-macrolet local (car forms) (cdr forms)))
- ((memq bare '(gv-define-expander))
- (scope-gv-define-expander local (car forms) (cadr forms)))
- ((memq bare '(gv-define-simple-setter))
- (scope-gv-define-simple-setter
- local (car forms) (cadr forms) (cddr forms)))
- ((memq bare '(cl-deftype))
- (scope-deftype local (car forms) (cadr forms) (cddr forms)))
- ((memq bare '(define-minor-mode))
- (scope-define-minor-mode local (car forms) (cadr forms) (cddr forms)))
- ((memq bare '(define-global-minor-mode define-globalized-minor-mode))
- (scope-define-global-minor-mode
- local (car forms) (cadr forms) (caddr forms) (cdddr forms)))
((scope-safe-macro-p bare)
- (scope-1 local (let ((symbols-with-pos-enabled t))
- ;; Ignore errors from trying to expand
- ;; invalid macro calls such as (dolist).
- (ignore-errors
- (let ((macroexpand-all-environment
- (append
- ;; Inhibit expansion of unsafe
- ;; macros during this expansion.
- ;; We'll encounter them later on
- ;; and handle them manually.
- (mapcar #'list scope-unsafe-macros)
- macroexpand-all-environment))
- (macroexp-inhibit-compiler-macros t)
- (warning-minimum-log-level :emergency))
- (macroexpand-1 form macroexpand-all-environment))))))))
- (scope-assume-func-p
- (when (symbol-with-pos-p f)
- (scope-report 'function
- (symbol-with-pos-pos f) (length (symbol-name bare))))
- (scope-n local forms))))))
+ (let* ((warning-minimum-log-level :emergency)
+ (macroexp-inhibit-compiler-macros t)
+ (symbols-with-pos-enabled t)
+ (macroexpand-all-environment
+ (append (mapcar #'list scope-unsafe-macros) macroexpand-all-environment))
+ (expanded (ignore-errors (macroexpand-1 form macroexpand-all-environment))))
+ (scope-1 local expanded)))))
+ (scope-assume-func-p (scope-report-s f 'function) (scope-n local forms))))))
((symbol-with-pos-p form) (scope-s local form))))
(defun scope-n (local body) (dolist (form body) (scope-1 local form)))
projects / emacs.git / commitdiff