Biting the bullet: a simple, permissive, scheme reader.

Currently put to (let's hope, good) use for context parsing in autodoc
and locals discovery (internal defines are recognised now).

1 files changed, 123 insertions, 86 deletions

diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
index 937107b..5cfbc32 100644
--- a/elisp/geiser-syntax.el
+++ b/elisp/geiser-syntax.el
@@ -80,9 +80,89 @@
  (with-syntax 1))
 
 
-;;; Code parsing:
+;;; A simple scheme reader
+
+(defvar geiser-syntax--read/buffer-limit nil)
+
+(defsubst geiser-syntax--read/eos ()
+  (or (eobp)
+      (and (numberp geiser-syntax--read/buffer-limit)
+           (<= geiser-syntax--read/buffer-limit (point)))))
+
+(defsubst geiser-syntax--read/next-char ()
+  (unless (geiser-syntax--read/eos)
+    (forward-char)
+    (char-after)))
+
+(defsubst geiser-syntax--read/token (token)
+  (geiser-syntax--read/next-char)
+  (if (listp token) token (list token)))
+
+(defsubst geiser-syntax--read/elisp ()
+  (ignore-errors (read (current-buffer))))
+
+(defun geiser-syntax--read/next-token ()
+  (skip-syntax-forward "->")
+  (if (geiser-syntax--read/eos) '(eob)
+    (let ((c (char-after)))
+      (cond ((not c) '(eob))
+            ((eq c '\;)
+             (skip-syntax-forward "^>")
+             (geiser-syntax--read/next-token))
+            ((memq c '(?\( ?\[)) (geiser-syntax--read/token 'lparen))
+            ((memq c '(?\) ?\])) (geiser-syntax--read/token 'rparen))
+            ((eq c ?.)
+             (if (memq (syntax-after (1+ (point))) '(0 11 12))
+                 (geiser-syntax--read/token 'dot)
+               (cons 'atom (geiser-syntax--read/elisp))))
+            ((eq c ?\#)
+             (let ((c (geiser-syntax--read/next-char)))
+               (cond ((not c) '(eob))
+                     ((eq c ?\\) (cons 'char (geiser-syntax--read/elisp)))
+                     ((eq c ?\() (geiser-syntax--read/token 'vectorb))
+                     (t (geiser-syntax--read/next-token)))))
+            ((eq c ?\') (geiser-syntax--read/token '(quote . quote)))
+            ((eq c ?\`) (geiser-syntax--read/token
+                         `(backquote . ,backquote-backquote-symbol)))
+            ((eq c ?,) (if (eq (geiser-syntax--read/next-char) ?@)
+                           (geiser-syntax--read/token
+                            `(splice . ,backquote-splice-symbol))
+                         `(unquote . ,backquote-unquote-symbol)))
+            ((eq c ?\") (cons 'string (geiser-syntax--read/elisp)))
+            (t (cons 'atom (geiser-syntax--read/elisp)))))))
+
+(defsubst geiser-syntax--read/match (&rest tks)
+  (let ((token (geiser-syntax--read/next-token)))
+    (if (memq (car token) tks) token
+      (error "Unexpected token: %s" token))))
+
+(defsubst geiser-syntax--read/try (&rest tks)
+  (let ((p (point))
+        (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
+    (unless tk (goto-char p))
+    tk))
+
+(defun geiser-syntax--read/list ()
+  (cond ((geiser-syntax--read/try 'dot)
+         (let ((tail (geiser-syntax--read)))
+           (geiser-syntax--read/match 'eob 'rparen)
+           tail))
+        ((geiser-syntax--read/try 'rparen 'eob) nil)
+        (t (cons (geiser-syntax--read)
+                 (geiser-syntax--read/list)))))
+
+(defun geiser-syntax--read ()
+  (let ((token (geiser-syntax--read/next-token)))
+    (case (car token)
+      (eob nil)
+      (lparen (geiser-syntax--read/list))
+      (vectorb (apply 'vector (geiser-syntax--read/list)))
+      ((quote backquote unquote splice) (list (cdr token) (geiser-syntax--read)))
+      ((char string atom) (cdr token))
+      (t (error "Reading scheme syntax: unexpected token: %s" token)))))
 
-(geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode)
+
+;;; Code parsing:
 
 (defsubst geiser-syntax--skip-comment/string ()
   (goto-char (or (nth 8 (syntax-ppss)) (point))))
@@ -90,105 +170,62 @@
 (defsubst geiser-syntax--nesting-level ()
   (or (nth 0 (syntax-ppss)) 0))
 
-(defun geiser-syntax--scan-sexp ()
-  (let ((p (point))
-        (n -1)
-        prev head)
-    (ignore-errors
-      (backward-up-list)
-      (save-excursion
-        (forward-char)
-        (skip-syntax-forward "^_w(" p)
-        (when (setq head (symbol-at-point))
-          (while (< (point) p)
-            (setq n (1+ n))
-            (setq prev (symbol-at-point))
-            (forward-sexp))))
-      (if head (list head n (and (> n 1) prev)) 'skip))))
-
 (defun geiser-syntax--scan-sexps ()
   (save-excursion
-    (geiser-syntax--skip-comment/string)
-    (let* ((sap (symbol-at-point))
-           (fst (and sap (geiser-syntax--scan-sexp)))
-           (path (and fst
-                      (cond ((not (listp fst)) `((,sap 0)))
-                             ((eq sap (car fst)) (list fst))
-                             (t (list fst (list sap 0)))))))
-      (while (setq fst (geiser-syntax--scan-sexp))
-        (when (listp fst) (push fst path)))
+    (let* ((fst (symbol-at-point))
+           (path (and fst (list (list fst 0)))))
+      (while (not (zerop (geiser-syntax--nesting-level)))
+        (let ((geiser-syntax--read/buffer-limit (1+ (point))))
+          (backward-up-list)
+          (let ((form (save-excursion (geiser-syntax--read))))
+            (when (and (listp form) (car form) (symbolp (car form)))
+              (let* ((len-1 (1- (length form)))
+                     (prev (and (> len-1 1) (nth (1- len-1) form))))
+                (push `(,(car form) ,len-1 ,@(and prev (symbolp prev) (list prev)))
+                      path))))))
       (nreverse path))))
 
-(defsubst geiser-syntax--listify (l &optional strict)
-  (cond ((vectorp l) (append l nil))
-        ((listp l) l)
-        (strict nil)
-        (t l)))
-
-(defun geiser-syntax--read-list (p)
-  (let ((list (geiser-syntax--listify (ignore-errors (read (current-buffer))) t)))
-    (if (and list (< (point) p))
-        (mapcar 'geiser-syntax--listify list)
-      (goto-char p)
-      nil)))
-
-(defconst geiser-syntax--delim-regexp "\\(?:\\s-\\|\\s<\\|\\s>\\|$\\|\n\\)+")
-
-(defconst geiser-syntax--ident-regexp
-  (format "\\(?:%s\\([^[ (]+?\\)\\)" geiser-syntax--delim-regexp))
-
-(defconst geiser-syntax--let-regexp
-  (format "\\=[[(]let\\(?:\\*\\|rec\\|%s\\|%s\\)%s*[[(]"
-          geiser-syntax--ident-regexp
-          geiser-syntax--delim-regexp
-          geiser-syntax--delim-regexp))
-
-(defconst geiser-syntax--ldefine-regexp
-  (format "[[(]define%s%s" geiser-syntax--ident-regexp geiser-syntax--delim-regexp))
-
-(defconst geiser-syntax--define-regexp
-  (format "[[(]\\(?:define\\)%s[[(]" geiser-syntax--delim-regexp))
-
-(defconst geiser-syntax--lambda-regexp
-  (format "[[(]\\(?:lambda\\)%s[[(]" geiser-syntax--delim-regexp))
-
 (defun geiser-syntax--locals-around-point ()
   (when (eq major-mode 'scheme-mode)
     (save-excursion
       (geiser-syntax--skip-comment/string)
-      (let ((ids))
+      (let* ((ids)
+             (push-id (lambda (n) (when (symbolp n) (push n ids))))
+             (get-arg (lambda (n) (if (listp n) (car n) n)))
+             (push-ids (lambda (is) (mapc push-id (nreverse (mapcar get-arg is))))))
         (while (not (zerop (geiser-syntax--nesting-level)))
-          (let ((p (point)))
+          (let ((geiser-syntax--read/buffer-limit (point)))
             (backward-up-list)
-            (save-excursion
-              (while (< (point) p)
-                (cond ((re-search-forward geiser-syntax--let-regexp p t)
-                       (when (match-string 1) (push (intern (match-string 1)) ids))
-                       (backward-char 1)
-                       (dolist (l (nreverse (geiser-syntax--read-list p)))
-                         (when (and (listp l) (symbolp (car l)))
-                           (push (car l) ids))))
-                      ((looking-at geiser-syntax--ldefine-regexp)
-                       (when (match-string 1) (push (intern (match-string 1)) ids))
-                       (goto-char (min p (match-end 0))))
-                      ((or (looking-at geiser-syntax--define-regexp)
-                           (looking-at geiser-syntax--lambda-regexp))
-                       (goto-char (min p (1- (match-end 0))))
-                       (dolist (s (nreverse (geiser-syntax--read-list p)))
-                         (let ((sn (if (listp s) (car s) s)))
-                           (when (symbolp sn) (push sn ids)))))
-                      ((re-search-forward geiser-syntax--ldefine-regexp p t)
-                       (when (match-string 1) (push (intern (match-string 1)) ids)))
-                      ((re-search-forward geiser-syntax--define-regexp p t)
-                       (backward-char 1)
-                       (let ((s (car (geiser-syntax--read-list p))))
-                         (when (symbolp s) (push s ids))))
-                      (t (goto-char (1+ p))))))))
+            (let* ((form (save-excursion (geiser-syntax--read)))
+                   (head (and (listp form) (car form)))
+                   (snd (and head (cadr form)))
+                   (third (and head (caddr form)))
+                   (is (case head
+                         ((define define*) (if (listp snd) snd (list snd)))
+                         ((let* letrec lambda let)
+                          (if (listp snd) snd
+                            (cons snd (and (eq head 'let)
+                                           (listp third)
+                                           third))))))
+                   (body (and is (case head
+                                   ((define define*) (and (listp snd) (cddr form)))
+                                   ((let let* letrec lambda)
+                                    (if (listp snd) (cddr form)
+                                      (cdddr form)))))))
+              (when is
+                (funcall push-ids
+                         (mapcar 'cdr
+                                 (remove-if (lambda (f) (or (not (listp f))
+                                                       (not (eq (car f) 'define))))
+                                            body)))
+                (funcall push-ids is)))))
         (nreverse ids)))))
 
 
 ;;; Fontify strings as Scheme code:
 
+(geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode)
+
 (defun geiser-syntax--font-lock-buffer ()
   (let ((name " *geiser font lock*"))
     (or (get-buffer name)