(defun scope-let (local bindings body)
(nconc
(mapcan (lambda (binding)
- (if (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)))
+ (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)))))
+ (list (list beg len beg))))))
bindings)
(let ((l local))
(dolist (binding bindings)
(let ((sym (if (consp binding) (car binding) binding)))
- (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l))))
+ (when binding
+ (setq l (scope-local-new (bare-symbol sym) (symbol-with-pos-pos sym) l)))))
(scope-n l body))))
(defun scope-let* (local bindings body)
(scope-letrec l (cdr binders) body))))
(scope-n local body)))
+(defun scope-loop-for-by (local0 local expr rest)
+ (nconc (scope-1 local0 expr) (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)))
+ (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 local rest)))))))))
+
+(defun scope-loop-for-from (local0 local expr rest)
+ (nconc
+ (scope-1 local0 expr)
+ (let ((word (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 local rest)))))))))
+
+(defun scope-loop-for-= (local0 local expr rest)
+ (nconc
+ (scope-1 local0 expr)
+ (let ((word (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 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)
+ (scope-loop (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 local (car more) (cdr more)))
+ (t
+ (scope-loop local more))))))))
+
+(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)))))))
+
+(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 local rest))
+ ((memq bw '( 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)))))))
+
+(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)))
+
+(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)
+ (scope-loop-for local0 (scope-local-new bare beg local) (cdr-safe vars) rest)))
+ (let ((word (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))))))))))
+
+(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))
+ (more (cdr rest)))
+ (if (and (symbol-with-pos-p word)
+ (eq (bare-symbol word) 'into))
+ (let* ((var (car more))
+ (bare (bare-symbol var))
+ (beg (symbol-with-pos-pos var)))
+ (cons
+ (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 (local var eql val rest)
+ (when (and (symbol-with-pos-p var)
+ (symbol-with-pos-p eql)
+ (eq (bare-symbol eql) '=))
+ (let* ((bare (bare-symbol var))
+ (beg (symbol-with-pos-pos var))
+ (l (scope-local-new bare beg local)))
+ (cons
+ (list beg (length (symbol-name bare)) beg)
+ (nconc
+ (scope-1 local val)
+ (scope-loop 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))))
+
+(defun scope-loop (local forms)
+ (when forms
+ (let ((kw (car forms))
+ (rest (cdr forms)))
+ (cond
+ ((symbol-with-pos-p kw)
+ (let ((bare (bare-symbol kw)))
+ (cond
+ ;; FIXME: Handle `and' clause-linking.
+ ((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)))
+ ;; FIXME: Handle `and' clause-linking.
+ ((memq bare '(with))
+ (scope-loop-with local (car rest) (cadr rest) (caddr rest) (cdddr rest)))
+ ((memq bare '(do)) (scope-loop-do local (car rest) (cdr rest))))))))))
+
(defvar scope-assume-func-p nil)
(defun scope-1 (local form &optional top-level)
(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))
projects / emacs.git / commitdiff