From fff6b102f88479f470d3d02a905674c594edb154 Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Mon, 7 Sep 2009 00:17:12 +0200
Subject: Scheme reader improvements: #<>, #||# and other bits.

---
 elisp/geiser-syntax.el | 62 +++++++++++++++++++++++++++++++++++---------------
 1 file changed, 44 insertions(+), 18 deletions(-)

(limited to 'elisp')

diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el
index 13cab62..ca218c8 100644
--- a/elisp/geiser-syntax.el
+++ b/elisp/geiser-syntax.el
@@ -101,32 +101,52 @@
 (defsubst geiser-syntax--read/elisp ()
   (ignore-errors (read (current-buffer))))
 
+(defun geiser-syntax--read/matching (open close)
+  (let ((count 1)
+        (p (1+ (point))))
+    (while (and (> count 0)
+                (geiser-syntax--read/next-char))
+      (cond ((looking-at-p open) (setq count (1+ count)))
+            ((looking-at-p close) (setq count (1- count)))))
+    (buffer-substring-no-properties p (point))))
+
+(defsubst geiser-syntax--read/unprintable ()
+  (geiser-syntax--read/token
+   (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
+
+(defun geiser-syntax--read/skip-comment ()
+  (while (and (geiser-syntax--read/next-char)
+              (nth 8 (syntax-ppss))))
+  (geiser-syntax--read/next-token))
+
 (defun geiser-syntax--read/next-token ()
   (skip-syntax-forward "->")
   (if (geiser-syntax--read/eos) '(eob)
     (case (char-after)
-      (\;
-       (skip-syntax-forward "^>")
-       (geiser-syntax--read/next-token))
+      (?\; (geiser-syntax--read/skip-comment))
       ((?\( ?\[) (geiser-syntax--read/token 'lparen))
       ((?\) ?\]) (geiser-syntax--read/token 'rparen))
       (?. (if (memq (syntax-after (1+ (point))) '(0 11 12))
               (geiser-syntax--read/token 'dot)
             (cons 'atom (geiser-syntax--read/elisp))))
-      (?\# (let ((c (geiser-syntax--read/next-char)))
-             (cond ((not c) '(eob))
-                   ((eq c ?:)
-                    (if (geiser-syntax--read/next-char)
-                        (cons 'kwd (geiser-syntax--read/elisp))
-                      '(eob)))
-                   ((eq c ?\\) (cons 'char (geiser-syntax--read/elisp)))
-                   ((eq c ?\() (geiser-syntax--read/token 'vectorb))
-                   (t (geiser-syntax--read/next-token)))))
+      (?\# (case (geiser-syntax--read/next-char)
+             ('nil '(eob))
+             (?| (geiser-syntax--read/skip-comment))
+             (?: (if (geiser-syntax--read/next-char)
+                     (cons 'kwd (geiser-syntax--read/elisp))
+                   '(eob)))
+             (?\\ (cons 'char (geiser-syntax--read/elisp)))
+             (?\( (geiser-syntax--read/token 'vectorb))
+             (?\< (geiser-syntax--read/unprintable))
+             (t (let ((tok (geiser-syntax--read/elisp)))
+                  (if tok (cons 'atom (intern (format "#%s" tok)))
+                    (geiser-syntax--read/next-token))))))
       (?\' (geiser-syntax--read/token '(quote . quote)))
       (?\` (geiser-syntax--read/token
             `(backquote . ,backquote-backquote-symbol)))
       (?, (if (eq (geiser-syntax--read/next-char) ?@)
-              (geiser-syntax--read/token `(splice . ,backquote-splice-symbol))
+              (geiser-syntax--read/token
+               `(splice . ,backquote-splice-symbol))
             `(unquote . ,backquote-unquote-symbol)))
       (?\" (cons 'string (geiser-syntax--read/elisp)))
       (t (cons 'atom (geiser-syntax--read/elisp))))))
@@ -157,8 +177,10 @@
       (eob nil)
       (lparen (geiser-syntax--read/list))
       (vectorb (apply 'vector (geiser-syntax--read/list)))
-      ((quote backquote unquote splice) (list (cdr token) (geiser-syntax--read)))
+      ((quote backquote unquote splice) (list (cdr token)
+                                              (geiser-syntax--read)))
       (kwd `(:keyword . ,(cdr token)))
+      (unprintable (format "#<%s>" (cdr token)))
       ((char string atom) (cdr token))
       (t (error "Reading scheme syntax: unexpected token: %s" token)))))
 
@@ -185,12 +207,15 @@
       (while (not (zerop (geiser-syntax--nesting-level)))
         (let ((boundary (1+ (point))))
           (backward-up-list)
-          (let ((form (nth-value 0 (geiser-syntax--form-after-point boundary))))
+          (let ((form
+                 (nth-value 0 (geiser-syntax--form-after-point boundary))))
             (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)))
-                     (prev (and prev (geiser-syntax--read/keyword-value prev))))
-                (push `(,(car form) ,len-1 ,@(and prev (symbolp prev) (list prev)))
+                     (prev (and prev
+                                (geiser-syntax--read/keyword-value prev))))
+                (push `(,(car form)
+                        ,len-1 ,@(and prev (symbolp prev) (list prev)))
                       path))))))
       (nreverse path))))
 
@@ -204,7 +229,8 @@
           (t
            (let* ((head (car form))
                   (name (if-symbol (cadr form)))
-                  (names (if name (if-list (caddr form)) (if-list (cadr form))))
+                  (names (if name (if-list (caddr form))
+                           (if-list (cadr form))))
                   (rest (if name (cdddr form) (cddr form)))
                   (use-names (or (eq head 'let*) (not partial) rest)))
              (when name (push name locals))
-- 
cgit v1.2.3