(defun context-coloring-backtick-enabled-p (backtick-stack)
(context-coloring-backtick-get-enabled (car backtick-stack)))
+(defun context-coloring-make-let-value (end)
+ (list
+ :end end))
+
+(defun context-coloring-let-value-get-end (let-value)
+ (plist-get let-value :end))
+
(defun context-coloring-emacs-lisp-identifier-syntax-p (syntax-code)
(or (= 2 syntax-code)
(= 3 syntax-code)))
"Move forward through whitespace and comments."
(while (forward-comment 1)))
+(defun context-coloring-at-open-parenthesis ()
+ (= 4 (logand #xFFFF (car (syntax-after (point))))))
+
(defun context-coloring-emacs-lisp-colorize ()
"Color the current buffer by parsing emacs lisp sexps."
(with-silent-modifications
(ppss (syntax-ppss))
(scope-stack `(,(context-coloring-make-scope -1 0))) ; -1 never matches a depth
(backtick-stack `(,(context-coloring-make-backtick -1 nil)))
+ (let-value-stack `(,(context-coloring-make-let-value -1)))
one-word-found-p
in-defun-p
in-lambda-p
+ in-let*-p
function-call-p
defun-arglist
defun-arg
+ let-varlist
+ let-var
variable
variable-end
variable-string
(setq child-0-end (scan-sexps child-0-pos 1))
(setq child-0-string (buffer-substring-no-properties child-0-pos child-0-end))
(cond
- ((string-match-p "defun\\|defmacro" child-0-string)
+ ((string-match-p "\\`defun\\'\\|\\`defmacro\\'" child-0-string)
(setq in-defun-p t))
- ((string-match-p "lambda" child-0-string)
+ ((string-match-p "\\`lambda\\'" child-0-string)
(setq in-lambda-p t))
+ ((string-match-p "\\`let\\*\\'" child-0-string)
+ (setq in-let*-p t))
;; Assume a global function call
(t
(setq function-call-p t)))))
- (when (or in-defun-p in-lambda-p)
+ (when (or in-defun-p
+ in-lambda-p
+ in-let*-p)
(setq scope-stack (cons (context-coloring-make-scope
(nth 0 ppss)
(1+ (context-coloring-scope-get-level
(context-coloring-colorize-region child-0-pos child-0-end 0)
(setq function-call-p nil))
(cond
- ((or in-defun-p in-lambda-p)
+ ((or in-defun-p
+ in-lambda-p)
(goto-char child-0-end)
(when in-defun-p
;; Lookahead for defun name
(goto-char child-1-end))))
;; Lookahead for parameters
(context-coloring-forward-sws)
- (when (= 4 (logand #xFFFF (car (syntax-after (point)))))
+ (when (context-coloring-at-open-parenthesis)
+ ;; Actually it should be `child-1-end' for `lambda'.
(setq child-2-end (scan-sexps (point) 1))
(setq defun-arglist (read (buffer-substring-no-properties
(point)
;; Cleanup
(setq in-defun-p nil)
(setq in-lambda-p nil))
+ (in-let*-p
+ (goto-char child-0-end)
+ ;; Lookahead for bindings
+ (context-coloring-forward-sws)
+ (setq child-1-pos (point))
+ (setq child-1-syntax (syntax-after child-1-pos))
+ (setq child-1-syntax-code (logand #xFFFF (car child-1-syntax)))
+ (when (= 4 child-1-syntax-code)
+ (setq child-1-end (scan-sexps (point) 1))
+ (setq let-varlist (read (buffer-substring-no-properties
+ (point)
+ child-1-end)))
+ (while let-varlist
+ (setq let-var (car let-varlist))
+ (cond
+ ((symbolp let-var)
+ (context-coloring-scope-add-variable
+ (car scope-stack)
+ let-var))
+ ((listp let-var)
+ (context-coloring-scope-add-variable
+ (car scope-stack)
+ (car let-var))
+ ;; TODO: Recurse or use stack to eval var value
+ ))
+ (setq let-varlist (cdr let-varlist)))
+ (goto-char child-1-end))
+ ;; Cleanup
+ (setq in-let*-p nil))
(t
(goto-char (cond
;; If there was a word, continue parsing after it.
(defun context-coloring-test-assert-coloring (map)
"Assert that the current buffer's coloring matches MAP."
- ;; Omit the superfluous, formatting-related leading newline.
- (save-excursion
- (goto-char (point-min))
- (let* ((map (substring map 1))
- (index 0)
- char-string
- char)
- (while (< index (length map))
- (setq char-string (substring map index (1+ index)))
- (setq char (string-to-char char-string))
- (cond
- ;; Newline
- ((= char 10)
- (next-logical-line)
- (beginning-of-line))
- ;; Number
- ((and (>= char 48)
- (<= char 57))
- (context-coloring-test-assert-position-level
- (point) (string-to-number char-string))
- (forward-char))
- ;; ';' = Comment
- ((= char 59)
- (context-coloring-test-assert-position-comment (point))
- (forward-char))
- ;; 's' = String
- ((= char 115)
- (context-coloring-test-assert-position-string (point))
- (forward-char))
- (t
- (forward-char)))
- (setq index (1+ index))))))
+ ;; Omit the superfluous, formatting-related leading newline. Can't use
+ ;; `save-excursion' here because if an assertion fails it will cause future
+ ;; tests to get messed up.
+ (goto-char (point-min))
+ (let* ((map (substring map 1))
+ (index 0)
+ char-string
+ char)
+ (while (< index (length map))
+ (setq char-string (substring map index (1+ index)))
+ (setq char (string-to-char char-string))
+ (cond
+ ;; Newline
+ ((= char 10)
+ (next-logical-line)
+ (beginning-of-line))
+ ;; Number
+ ((and (>= char 48)
+ (<= char 57))
+ (context-coloring-test-assert-position-level
+ (point) (string-to-number char-string))
+ (forward-char))
+ ;; ';' = Comment
+ ((= char 59)
+ (context-coloring-test-assert-position-comment (point))
+ (forward-char))
+ ;; 's' = String
+ ((= char 115)
+ (context-coloring-test-assert-position-string (point))
+ (forward-char))
+ (t
+ (forward-char)))
+ (setq index (1+ index)))))
(defmacro context-coloring-test-assert-region (&rest body)
"Assert something about the face of points in a region.
(xxxxx x ()
(0 0 1 11 11 111 11 1 111))")))
+(context-coloring-test-deftest-emacs-lisp-mode let*
+ (lambda ()
+ (context-coloring-test-assert-coloring "
+11111 11
+ 11 11
+ 11 000011
+ 1000 1 1 1 0 0 00001
+ 22222 22
+ 22 12
+ 22 000022
+ 2000 1 1 2 2 2 0000))
+ 1000 1 1 1 0 0 000011")))
+
(provide 'context-coloring-test)
;;; context-coloring-test.el ends here