src/base/reader.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- Reader utils
   4 ;;;
   5
   6 (in-package :iolib.base)
   7
   8 ;; Reader macros
   9
  10 (defgeneric enable-reader-macro* (name))
  11
  12 (defgeneric disable-reader-macro* (name))
  13
  14 (defmacro enable-reader-macro (name)
  15   `(eval-when (:compile-toplevel)
  16      (enable-reader-macro* ,name)))
  17
  18 (defmacro disable-reader-macro (name)
  19   `(eval-when (:compile-toplevel)
  20      (disable-reader-macro* ,name)))
  21
  22 (defun save-old-readtable (symbol readtable)
  23   (setf (getf (symbol-plist symbol) 'old-readtable) readtable))
  24
  25 (defun get-old-readtable (symbol)
  26   (getf (symbol-plist symbol) 'old-readtable))
  27
  28 (defmethod enable-reader-macro* :before ((name symbol))
  29   (save-old-readtable name *readtable*)
  30   (setf *readtable* (copy-readtable)))
  31
  32 (defmethod disable-reader-macro* ((name symbol))
  33   (assert (readtablep (get-old-readtable name)))
  34   (setf *readtable* (get-old-readtable name))
  35   (save-old-readtable name nil))
  36
  37 (defmacro define-syntax (name &body body)
  38   `(defmethod enable-reader-macro* ((name (eql ',name)))
  39      ,@body))
  40 \f
  41
  42 ;; Literal object dispatcher
  43
  44 (define-condition unknown-literal-syntax (reader-error)
  45   ((name :initarg :name :accessor unknown-literal-syntax-name))
  46   (:report (lambda (s c)
  47              (format s "Unknown literal read syntax: ~S"
  48                      (unknown-literal-syntax-name c)))))
  49
  50 (defconstant +read-literal-dispatch-char+ #\#)
  51 (defconstant +read-literal-sub-char+ #\/)
  52
  53 (defun read-literal-dispatcher (stream char arg)
  54   (declare (ignore char arg))
  55   (let* ((literal-syntax-name
  56           (with-output-to-string (s)
  57             (loop :for c := (read-char stream t nil t)
  58                   :do (if (char= c +read-literal-sub-char+)
  59                           (loop-finish)
  60                           (write-char c s)))))
  61          (literal-reader
  62           (getf (symbol-plist (read-from-string literal-syntax-name))
  63                 'read-literal-fn)))
  64     (if (functionp literal-reader)
  65         (funcall literal-reader stream)
  66         (error 'unknown-literal-syntax
  67                :stream stream
  68                :name literal-syntax-name))))
  69
  70 (set-dispatch-macro-character +read-literal-dispatch-char+
  71                               +read-literal-sub-char+
  72                               'read-literal-dispatcher)
  73
  74 (defmacro define-literal-reader (name (stream) &body body)
  75   `(setf (getf (symbol-plist ',name) 'read-literal-fn)
  76          (lambda (,stream) ,@body)))