source: release/1.6/source/cocoa-ide/hemlock/unused/archive/elisp/read-table.lisp

(in-package "ELISP-INTERNALS")

(defvar *elisp-readtable* (copy-readtable))

(cl:defun read-vector (stream char)
  (when (char= char #\[)
    (coerce (read-delimited-list #\] stream t) 'vector)))

(cl:defun read-character (stream char)
  (if (char= char #\?) 
      (read-string-char stream :event)
      (values)))

;;; Note to self. Implement this, head hurts, another day.
;;; Is hopefully mostly done...
(cl:defun emit-character (charspec context)
  (cl:case context
    (:character
     (cl:let ((char (char-code (car (last charspec)))))
       (if (member :control charspec)
           (setf char (mod char 32)))
       (if (member :meta charspec)
           (setf char (+ 128 char)))
       (code-char char)
     ))
    (:event
     (cl:let ((string (with-output-to-string (s)
                        (write-char #\" s)
                        (loop for entity in charspec
                              do (case entity
                                   (:control
                                    (write-char #\C s)
                                    (write-char #\- s))
                                   (:meta
                                    (write-char #\M s)
                                    (write-char #\- s))
                                   (t (write-char entity s))))
                        (write-char #\" s))))
       (with-input-from-string (hackstring string)
         (eval (hemlock-ext::parse-key-fun hackstring #\k 2))))
     )))

(defun read-octal (stream acc level)
  (cl:if (= level 3)
      (code-char acc)
    (let ((char (cl:read-char stream nil stream t)))
      (case char
        ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
         (if (and (char= char #\0) (zerop acc))
             (code-char 0)
           (let ((value (position char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) :test #'char=)))
             (cl:if (< (+ value (* 8 acc)) 256)
                    (read-octal stream (+ value (* 8 acc)) (1+ level))
                    (progn (unread-char char stream) (code-char acc))))))
        (t (if (zerop acc)
               char
             (progn
               (unread-char char stream)
               (code-char acc))))))))

(cl:defun read-string-char (stream context)
  (cl:let ((char (cl:read-char stream nil stream t)))
    (if (char= char #\\)
        (cl:let ((next (cl:read-char stream nil stream t)))
          (case next
            (#\a (emit-character '(:control #\g) context))
            (#\n (emit-character '(:control #\j) context)) 
            (#\b (emit-character '(:control #\h) context))
            (#\r (emit-character '(:control #\m) context))
            (#\v (emit-character '(:control #\k) context))
            (#\f (emit-character '(:control #\l) context))
            (#\t (emit-character '(:control #\i) context))
            (#\e (emit-character '(:control #\[) context))
            (#\\ #\\)
            (#\" #\")
            (#\d (emit-character '(#\Rubout) context))
            ((#\C #\M)
             (unread-char next stream)
             (emit-character
              (do ((char (read-char stream) (read-char stream))
                   (expect-dash nil (not expect-dash))
                   (terminate nil)
                   (collection nil))
                  ((or (and expect-dash (not (char= char #\-)))
                       terminate)
                   (unread-char char stream)
                   (nreverse collection))
                (cond (expect-dash)
                      ((char= char #\M)
                       (setf collection (cons :meta collection)))
                      ((char= char #\C)
                       (setf collection (cons :control collection)))
                      (t (setf terminate t)
                         (setf collection (cons char collection)))))
              context))
            ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
             (read-octal stream 0 0)
            )))
      char)))

(cl:defun read-string (stream char)
  (if (char= char #\")
      (with-output-to-string (s)
        (loop for char = (read-string-char stream :character)
              if (char= char #\") return s
              else do (cl:write-char char s)))))

(cl:defun sharp-ampersand (stream ignore arg)
  (declare (ignore ignore arg))
  (let ((length (cl:read stream t stream t)))
    (if (not (integerp length))
        (values)
      (let ((string (read stream stream stream t))
            (rv (make-array (list length) :element-type 'bit :initial-element 0)))
        (if (stringp string)
            (progn
              (loop for ix from 0 to (1- length)
                  do (multiple-value-bind (char shift) (truncate ix 8)
                       (let ((val (char-code (char string char))))
                         (unless (zerop (logand val (ash 1 shift)))
                           (setf (aref rv ix) 1)))))
              rv)
          (values))))))

(set-macro-character #\[ 'read-vector nil *elisp-readtable*)
(set-macro-character #\] (get-macro-character #\)) nil *elisp-readtable*)
(set-macro-character #\? 'read-character nil *elisp-readtable*)
(set-macro-character #\" 'read-string nil *elisp-readtable*)
(set-dispatch-macro-character #\# #\& #'sharp-ampersand *elisp-readtable*)
(set-syntax-from-char #\[ #\()
(set-syntax-from-char #\] #\))