src/base/reader.lisp

   1 ;;;; -*- Mode: 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 (defconstant +read-literal-dispatch-char+ #\#)
  45 (defconstant +read-literal-sub-char+ #\/)
  46
  47 (defun read-literal-dispatcher (stream char arg)
  48   (declare (ignore char arg))
  49   (let* ((literal-syntax-name
  50           (with-output-to-string (s)
  51             (loop :for c := (read-char stream t nil t)
  52                   :do (if (char= c +read-literal-sub-char+)
  53                           (loop-finish)
  54                           (write-char c s)))))
  55          (literal-reader
  56           (getf (symbol-plist (read-from-string literal-syntax-name))
  57                 'read-literal-fn)))
  58     (if (functionp literal-reader)
  59         (funcall literal-reader stream)
  60         (error 'unknown-literal-syntax
  61                :stream stream
  62                :name literal-syntax-name))))
  63
  64 (set-dispatch-macro-character +read-literal-dispatch-char+
  65                               +read-literal-sub-char+
  66                               'read-literal-dispatcher)
  67
  68 (defmacro define-literal-reader (name (stream) &body body)
  69   `(setf (getf (symbol-plist ',name) 'read-literal-fn)
  70          (lambda (,stream) ,@body)))