elisp/geiser-syntax.el

   1 ;;; geiser-syntax.el -- utilities for parsing scheme syntax
   2
   3 ;; Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Sun Feb 08, 2009 15:03
  11
  12 \f
  13
  14 (require 'geiser-popup)
  15 (require 'geiser-base)
  16
  17 (require 'scheme)
  18
  19 \f
  20 ;;; Indentation:
  21
  22 (defmacro geiser-syntax--scheme-indent (&rest pairs)
  23   `(progn ,@(mapcar (lambda (p)
  24                       `(put ',(car p) 'scheme-indent-function ',(cadr p)))
  25                     pairs)))
  26
  27 (geiser-syntax--scheme-indent
  28  (begin0 1)
  29  (c-declare 0)
  30  (c-lambda 2)
  31  (case-lambda 0)
  32  (case-lambda: 0)
  33  (catch defun)
  34  (class defun)
  35  (class* defun)
  36  (compound-unit/sig 0)
  37  (define: defun)
  38  (dynamic-wind 0)
  39  (for/fold 2)
  40  (instantiate 2)
  41  (interface 1)
  42  (lambda: 1)
  43  (lambda/kw 1)
  44  (let*-values 1)
  45  (let*-values: 1)
  46  (let+ 1)
  47  (let: 1)
  48  (letrec: 1)
  49  (letrec-values 1)
  50  (letrec-values: 1)
  51  (let-values 1)
  52  (let-values: 1)
  53  (let/cc: 1)
  54  (let/ec 1)
  55  (match defun)
  56  (mixin 2)
  57  (module defun)
  58  (opt-lambda 1)
  59  (parameterize 1)
  60  (parameterize-break 1)
  61  (parameterize* 1)
  62  (pmatch defun)
  63  (quasisyntax/loc 1)
  64  (receive 2)
  65  (send* 1)
  66  (sigaction 1)
  67  (syntax-case 2)
  68  (syntax/loc 1)
  69  (type-case defun)
  70  (unit defun)
  71  (unit/sig 2)
  72  (unless 1)
  73  (when 1)
  74  (while 1)
  75  (with-handlers 1)
  76  (with-handlers: 1)
  77  (with-method 1)
  78  (with-syntax 1))
  79
  80 \f
  81 ;;; A simple scheme reader
  82
  83 (defvar geiser-syntax--read/buffer-limit nil)
  84
  85 (defsubst geiser-syntax--read/eos ()
  86   (or (eobp)
  87       (and geiser-syntax--read/buffer-limit
  88            (<= geiser-syntax--read/buffer-limit (point)))))
  89
  90 (defsubst geiser-syntax--read/next-char ()
  91   (unless (geiser-syntax--read/eos)
  92     (forward-char)
  93     (char-after)))
  94
  95 (defsubst geiser-syntax--read/token (token)
  96   (geiser-syntax--read/next-char)
  97   (if (listp token) token (list token)))
  98
  99 (defsubst geiser-syntax--read/elisp ()
 100   (ignore-errors (read (current-buffer))))
 101
 102 (defun geiser-syntax--read/matching (open close)
 103   (let ((count 1)
 104         (p (1+ (point))))
 105     (while (and (> count 0)
 106                 (geiser-syntax--read/next-char))
 107       (cond ((looking-at-p open) (setq count (1+ count)))
 108             ((looking-at-p close) (setq count (1- count)))))
 109     (buffer-substring-no-properties p (point))))
 110
 111 (defsubst geiser-syntax--read/unprintable ()
 112   (geiser-syntax--read/token
 113    (cons 'unprintable (geiser-syntax--read/matching "<" ">"))))
 114
 115 (defun geiser-syntax--read/skip-comment ()
 116   (while (and (geiser-syntax--read/next-char)
 117               (nth 8 (syntax-ppss))))
 118   (geiser-syntax--read/next-token))
 119
 120 (defun geiser-syntax--read/next-token ()
 121   (skip-syntax-forward "->")
 122   (if (geiser-syntax--read/eos) '(eob)
 123     (case (char-after)
 124       (?\; (geiser-syntax--read/skip-comment))
 125       ((?\( ?\[) (geiser-syntax--read/token 'lparen))
 126       ((?\) ?\]) (geiser-syntax--read/token 'rparen))
 127       (?. (if (memq (car (syntax-after (1+ (point)))) '(0 11 12))
 128               (geiser-syntax--read/token 'dot)
 129             (cons 'atom (geiser-syntax--read/elisp))))
 130       (?\# (case (geiser-syntax--read/next-char)
 131              ('nil '(eob))
 132              (?| (geiser-syntax--read/skip-comment))
 133              (?: (if (geiser-syntax--read/next-char)
 134                      (cons 'kwd (geiser-syntax--read/elisp))
 135                    '(eob)))
 136              (?\\ (cons 'char (geiser-syntax--read/elisp)))
 137              (?\( (geiser-syntax--read/token 'vectorb))
 138              (?\< (geiser-syntax--read/unprintable))
 139              ((?' ?` ?,) (geiser-syntax--read/next-token))
 140              (t (let ((tok (geiser-syntax--read/elisp)))
 141                   (if tok (cons 'atom (intern (format "#%s" tok)))
 142                     (geiser-syntax--read/next-token))))))
 143       (?\' (geiser-syntax--read/token '(quote . quote)))
 144       (?\` (geiser-syntax--read/token
 145             `(backquote . ,backquote-backquote-symbol)))
 146       (?, (if (eq (geiser-syntax--read/next-char) ?@)
 147               (geiser-syntax--read/token
 148                `(splice . ,backquote-splice-symbol))
 149             `(unquote . ,backquote-unquote-symbol)))
 150       (?\" (cons 'string (geiser-syntax--read/elisp)))
 151       (t (cons 'atom (geiser-syntax--read/elisp))))))
 152
 153 (defsubst geiser-syntax--read/match (&rest tks)
 154   (let ((token (geiser-syntax--read/next-token)))
 155     (if (memq (car token) tks) token
 156       (error "Unexpected token: %s" token))))
 157
 158 (defsubst geiser-syntax--read/skip-until (&rest tks)
 159   (let (token)
 160     (while (and (not (memq (car token) tks))
 161                 (not (eq (car token) 'eob)))
 162       (setq token (geiser-syntax--read/next-token)))
 163     token))
 164
 165 (defsubst geiser-syntax--read/try (&rest tks)
 166   (let ((p (point))
 167         (tk (ignore-errors (apply 'geiser-syntax--read/match tks))))
 168     (unless tk (goto-char p))
 169     tk))
 170
 171 (defun geiser-syntax--read/list ()
 172   (cond ((geiser-syntax--read/try 'dot)
 173          (let ((tail (geiser-syntax--read)))
 174            (geiser-syntax--read/skip-until 'eob 'rparen)
 175            tail))
 176         ((geiser-syntax--read/try 'rparen 'eob) nil)
 177         (t (cons (geiser-syntax--read)
 178                  (geiser-syntax--read/list)))))
 179
 180 (defun geiser-syntax--read ()
 181   (let ((token (geiser-syntax--read/next-token))
 182         (max-lisp-eval-depth (max max-lisp-eval-depth 3000)))
 183     (case (car token)
 184       (eob nil)
 185       (lparen (geiser-syntax--read/list))
 186       (vectorb (apply 'vector (geiser-syntax--read/list)))
 187       ((quote backquote unquote splice) (list (cdr token)
 188                                               (geiser-syntax--read)))
 189       (kwd (intern (format ":%s" (cdr token))))
 190       (unprintable (format "#<%s>" (cdr token)))
 191       ((char string atom) (cdr token))
 192       (t (error "Reading scheme syntax: unexpected token: %s" token)))))
 193
 194 (defun geiser-syntax--read-from-string (string &optional start end)
 195   (when (stringp string)
 196     (let* ((start (or start 0))
 197            (end (or end (length string)))
 198            (max-lisp-eval-depth (max max-lisp-eval-depth (- end start))))
 199       (with-temp-buffer
 200         (save-excursion (insert string))
 201         (cons (ignore-errors (geiser-syntax--read)) (point))))))
 202
 203 (defsubst geiser-syntax--form-after-point (&optional boundary)
 204   (let ((geiser-syntax--read/buffer-limit (and (numberp boundary) boundary)))
 205     (save-excursion (values (geiser-syntax--read) (point)))))
 206
 207 \f
 208 ;;; Code parsing:
 209
 210 (defsubst geiser-syntax--skip-comment/string ()
 211   (goto-char (or (nth 8 (syntax-ppss)) (point))))
 212
 213 (defsubst geiser-syntax--nesting-level ()
 214   (or (nth 0 (syntax-ppss)) 0))
 215
 216 (defsubst geiser-syntax--pair-length (p)
 217   (if (cdr (last p)) (1+ (safe-length p)) (length p)))
 218
 219 (defun geiser-syntax--scan-sexps (&optional begin)
 220   (let* ((fst (symbol-at-point))
 221          (smth (or fst (not (looking-at-p "[\\s \\s)\\s>\\s<\n]"))))
 222          (path (and fst `((,fst 0)))))
 223     (save-excursion
 224       (geiser-syntax--skip-comment/string)
 225       (while (not (zerop (geiser-syntax--nesting-level)))
 226         (let ((boundary (1+ (point))))
 227           (backward-up-list)
 228           (let ((form
 229                  (nth-value 0 (geiser-syntax--form-after-point boundary))))
 230             (when (and (listp form) (car form) (symbolp (car form)))
 231               (let* ((len (geiser-syntax--pair-length form))
 232                      (pos (if smth (1- len) (progn (setq smth t) len)))
 233                      (prev (and (> pos 1) (nth (1- pos) form)))
 234                      (prev (and (keywordp prev) (list prev))))
 235                 (push `(,(car form) ,pos ,@prev) path)))))))
 236     (nreverse path)))
 237
 238 (defsubst geiser-syntax--binding-form-p (bfs sbfs f)
 239   (or (memq f '(define define* lambda let let* letrec))
 240       (memq f bfs)
 241       (memq f sbfs)))
 242
 243 (defsubst geiser-syntax--binding-form*-p (sbfs f)
 244   (or (eq 'let* f) (memq f sbfs)))
 245
 246 (defun geiser-syntax--scan-locals (bfs sbfs form partial locals)
 247   (flet ((if-symbol (x) (and (symbolp x) x))
 248          (if-list (x) (and (listp x) x))
 249          (normalize (vars) (mapcar (lambda (i) (if (listp i) (car i) i)) vars)))
 250     (let ((form (if (listp form) (normalize form) form)))
 251       (cond ((or (null form) (not (listp form))) (normalize locals))
 252             ((not (geiser-syntax--binding-form-p bfs sbfs (car form)))
 253              (geiser-syntax--scan-locals bfs sbfs
 254                                          (car (last form)) partial locals))
 255             (t
 256              (let* ((head (car form))
 257                     (name (if-symbol (cadr form)))
 258                     (names (if name (if-list (caddr form))
 259                              (if-list (cadr form))))
 260                     (rest (if name (cdddr form) (cddr form)))
 261                     (use-names (or rest
 262                                    (not partial)
 263                                    (geiser-syntax--binding-form*-p sbfs
 264                                                                    head))))
 265                (when name (push name locals))
 266                (when use-names (dolist (n names) (push n locals)))
 267                (dolist (f (butlast rest))
 268                  (when (and (listp f) (eq (car f) 'define))
 269                    (push (cadr f) locals)))
 270                (geiser-syntax--scan-locals bfs sbfs
 271                                            (car (last (or rest names)))
 272                                            partial
 273                                            locals)))))))
 274
 275 (defun geiser-syntax--locals-around-point (bfs sbfs)
 276   (when (eq major-mode 'scheme-mode)
 277     (save-excursion
 278       (geiser-syntax--skip-comment/string)
 279       (let ((boundary (point)))
 280         (while (not (zerop (geiser-syntax--nesting-level)))
 281           (backward-up-list))
 282         (multiple-value-bind (form end)
 283             (geiser-syntax--form-after-point boundary)
 284           (geiser-syntax--scan-locals bfs sbfs form (> end boundary) '()))))))
 285
 286 \f
 287 ;;; Fontify strings as Scheme code:
 288
 289 (geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode)
 290
 291 (defun geiser-syntax--font-lock-buffer ()
 292   (let ((name " *geiser font lock*"))
 293     (or (get-buffer name)
 294         (let ((buffer (get-buffer-create name)))
 295           (set-buffer buffer)
 296           (scheme-mode)
 297           buffer))))
 298
 299 (defun geiser-syntax--scheme-str (str)
 300   (save-current-buffer
 301     (set-buffer (geiser-syntax--font-lock-buffer))
 302     (erase-buffer)
 303     (insert str)
 304     (let ((font-lock-verbose nil)) (font-lock-fontify-buffer))
 305     (buffer-string)))
 306
 307 \f
 308 (provide 'geiser-syntax)
 309 ;;; geiser-syntax.el ends here