diff options
| -rw-r--r-- | elisp/geiser-syntax.el | 62 |
1 files changed, 44 insertions, 18 deletions
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)) |