syntax.lisp

   1 (in-package :cl-tuples)
   2
   3 ;; to do -- investigate cl-syntax-sugar to see if we can come up with
   4 ;; some nicer custom syntax
   5
   6 ;; make #{ .. } notation become a short hand for (values ...)
   7 (defun |#{-reader| (stream char arg)
   8   (declare (ignore char arg))
   9   `(values ,@(read-delimited-list #\} stream t)))
  10
  11 (defun |#[-reader| (stream char arg)
  12   (declare (ignore char arg))
  13   (let ((form (read-delimited-list #\] stream t)))
  14         (if (tuple-typep (car form))
  15                 (if (is-asterisk-symbol (car form))
  16                         (let* ((form-str (symbol-name (car form)))
  17                                    (tuple-str (subseq form-str 0 (- (length form-str) 1))))
  18                           `(,(make-adorned-symbol tuple-str :asterisk t :suffix "VALUES") ,@(cdr form)))
  19                         `(,(make-adorned-symbol (car form) :prefix "MAKE") ,@(cdr form)))
  20                 (error "~A does not define a tuple type" (car form)))))
  21
  22 (defvar *original-readtable* NIL)
  23
  24 (defvar *restore-reader-syntax* NIL)
  25
  26 (defmacro disable-tuples-syntax ()
  27   '(eval-when (:compile-toplevel :load-toplevel :execute)
  28     (setf *restore-reader-syntax* NIL)
  29     (%disable-tuples-syntax)))
  30
  31 (defmacro locally-disable-tuples-syntax ()
  32   '(eval-when (:compile-toplevel :load-toplevel :execute)
  33     (%disable-tuples-syntax)))
  34
  35 (defun %disable-tuples-syntax ()
  36   (when *original-readtable*
  37     (setf *readtable* *original-readtable*
  38           *original-readtable* NIL))
  39   (values))
  40
  41 (defmacro enable-tuples-syntax ()
  42   '(eval-when (:compile-toplevel :load-toplevel :execute)
  43     (setf *restore-reader-syntax* T)
  44     (%enable-tuples-syntax)))
  45
  46 (defmacro locally-enable-tuples-syntax ()
  47   '(eval-when (:compile-toplevel :load-toplevel :execute)
  48     (%enable-tuples-syntax)))
  49
  50 (defmacro file-enable-tuples-syntax ()
  51   '(eval-when (:compile-toplevel :load-toplevel :execute)
  52     (%enable-tuples-syntax NIL)))
  53
  54 (defun %enable-tuples-syntax (&optional (save-original-p T))
  55   (when save-original-p
  56     (setf *original-readtable* (copy-readtable)))
  57   (when (or (not save-original-p) *original-readtable*)
  58     (setf *readtable* (copy-readtable))
  59     (set-dispatch-macro-character #\# #\{ #'|#{-reader|)
  60         (set-dispatch-macro-character #\# #\[ #'|#[-reader|)
  61     (set-macro-character #\} (get-macro-character #\) nil))
  62         (set-macro-character #\] (get-macro-character #\) nil)))
  63   (values))
  64
  65 (defmacro restore-tuples-syntax-state ()
  66   '(eval-when (:compile-toplevel :load-toplevel :execute)
  67     (if *restore-tuples-syntax*
  68         (%enable-tuples-syntax)
  69         (%disable-tuples-syntax))))