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