| 1 | (in-package "ELISP-INTERNALS")
|
|---|
| 2 |
|
|---|
| 3 | (defvar *elisp-readtable* (copy-readtable))
|
|---|
| 4 |
|
|---|
| 5 | (cl:defun read-vector (stream char)
|
|---|
| 6 | (when (char= char #\[)
|
|---|
| 7 | (coerce (read-delimited-list #\] stream t) 'vector)))
|
|---|
| 8 |
|
|---|
| 9 | (cl:defun read-character (stream char)
|
|---|
| 10 | (if (char= char #\?)
|
|---|
| 11 | (read-string-char stream :event)
|
|---|
| 12 | (values)))
|
|---|
| 13 |
|
|---|
| 14 | ;;; Note to self. Implement this, head hurts, another day.
|
|---|
| 15 | ;;; Is hopefully mostly done...
|
|---|
| 16 | (cl:defun emit-character (charspec context)
|
|---|
| 17 | (cl:case context
|
|---|
| 18 | (:character
|
|---|
| 19 | (cl:let ((char (char-code (car (last charspec)))))
|
|---|
| 20 | (if (member :control charspec)
|
|---|
| 21 | (setf char (mod char 32)))
|
|---|
| 22 | (if (member :meta charspec)
|
|---|
| 23 | (setf char (+ 128 char)))
|
|---|
| 24 | (code-char char)
|
|---|
| 25 | ))
|
|---|
| 26 | (:event
|
|---|
| 27 | (cl:let ((string (with-output-to-string (s)
|
|---|
| 28 | (write-char #\" s)
|
|---|
| 29 | (loop for entity in charspec
|
|---|
| 30 | do (case entity
|
|---|
| 31 | (:control
|
|---|
| 32 | (write-char #\C s)
|
|---|
| 33 | (write-char #\- s))
|
|---|
| 34 | (:meta
|
|---|
| 35 | (write-char #\M s)
|
|---|
| 36 | (write-char #\- s))
|
|---|
| 37 | (t (write-char entity s))))
|
|---|
| 38 | (write-char #\" s))))
|
|---|
| 39 | (with-input-from-string (hackstring string)
|
|---|
| 40 | (eval (hemlock-ext::parse-key-fun hackstring #\k 2))))
|
|---|
| 41 | )))
|
|---|
| 42 |
|
|---|
| 43 | (defun read-octal (stream acc level)
|
|---|
| 44 | (cl:if (= level 3)
|
|---|
| 45 | (code-char acc)
|
|---|
| 46 | (let ((char (cl:read-char stream nil stream t)))
|
|---|
| 47 | (case char
|
|---|
| 48 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
|---|
| 49 | (if (and (char= char #\0) (zerop acc))
|
|---|
| 50 | (code-char 0)
|
|---|
| 51 | (let ((value (position char '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7) :test #'char=)))
|
|---|
| 52 | (cl:if (< (+ value (* 8 acc)) 256)
|
|---|
| 53 | (read-octal stream (+ value (* 8 acc)) (1+ level))
|
|---|
| 54 | (progn (unread-char char stream) (code-char acc))))))
|
|---|
| 55 | (t (if (zerop acc)
|
|---|
| 56 | char
|
|---|
| 57 | (progn
|
|---|
| 58 | (unread-char char stream)
|
|---|
| 59 | (code-char acc))))))))
|
|---|
| 60 |
|
|---|
| 61 | (cl:defun read-string-char (stream context)
|
|---|
| 62 | (cl:let ((char (cl:read-char stream nil stream t)))
|
|---|
| 63 | (if (char= char #\\)
|
|---|
| 64 | (cl:let ((next (cl:read-char stream nil stream t)))
|
|---|
| 65 | (case next
|
|---|
| 66 | (#\a (emit-character '(:control #\g) context))
|
|---|
| 67 | (#\n (emit-character '(:control #\j) context))
|
|---|
| 68 | (#\b (emit-character '(:control #\h) context))
|
|---|
| 69 | (#\r (emit-character '(:control #\m) context))
|
|---|
| 70 | (#\v (emit-character '(:control #\k) context))
|
|---|
| 71 | (#\f (emit-character '(:control #\l) context))
|
|---|
| 72 | (#\t (emit-character '(:control #\i) context))
|
|---|
| 73 | (#\e (emit-character '(:control #\[) context))
|
|---|
| 74 | (#\\ #\\)
|
|---|
| 75 | (#\" #\")
|
|---|
| 76 | (#\d (emit-character '(#\Rubout) context))
|
|---|
| 77 | ((#\C #\M)
|
|---|
| 78 | (unread-char next stream)
|
|---|
| 79 | (emit-character
|
|---|
| 80 | (do ((char (read-char stream) (read-char stream))
|
|---|
| 81 | (expect-dash nil (not expect-dash))
|
|---|
| 82 | (terminate nil)
|
|---|
| 83 | (collection nil))
|
|---|
| 84 | ((or (and expect-dash (not (char= char #\-)))
|
|---|
| 85 | terminate)
|
|---|
| 86 | (unread-char char stream)
|
|---|
| 87 | (nreverse collection))
|
|---|
| 88 | (cond (expect-dash)
|
|---|
| 89 | ((char= char #\M)
|
|---|
| 90 | (setf collection (cons :meta collection)))
|
|---|
| 91 | ((char= char #\C)
|
|---|
| 92 | (setf collection (cons :control collection)))
|
|---|
| 93 | (t (setf terminate t)
|
|---|
| 94 | (setf collection (cons char collection)))))
|
|---|
| 95 | context))
|
|---|
| 96 | ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)
|
|---|
| 97 | (read-octal stream 0 0)
|
|---|
| 98 | )))
|
|---|
| 99 | char)))
|
|---|
| 100 |
|
|---|
| 101 | (cl:defun read-string (stream char)
|
|---|
| 102 | (if (char= char #\")
|
|---|
| 103 | (with-output-to-string (s)
|
|---|
| 104 | (loop for char = (read-string-char stream :character)
|
|---|
| 105 | if (char= char #\") return s
|
|---|
| 106 | else do (cl:write-char char s)))))
|
|---|
| 107 |
|
|---|
| 108 | (cl:defun sharp-ampersand (stream ignore arg)
|
|---|
| 109 | (declare (ignore ignore arg))
|
|---|
| 110 | (let ((length (cl:read stream t stream t)))
|
|---|
| 111 | (if (not (integerp length))
|
|---|
| 112 | (values)
|
|---|
| 113 | (let ((string (read stream stream stream t))
|
|---|
| 114 | (rv (make-array (list length) :element-type 'bit :initial-element 0)))
|
|---|
| 115 | (if (stringp string)
|
|---|
| 116 | (progn
|
|---|
| 117 | (loop for ix from 0 to (1- length)
|
|---|
| 118 | do (multiple-value-bind (char shift) (truncate ix 8)
|
|---|
| 119 | (let ((val (char-code (char string char))))
|
|---|
| 120 | (unless (zerop (logand val (ash 1 shift)))
|
|---|
| 121 | (setf (aref rv ix) 1)))))
|
|---|
| 122 | rv)
|
|---|
| 123 | (values))))))
|
|---|
| 124 |
|
|---|
| 125 | (set-macro-character #\[ 'read-vector nil *elisp-readtable*)
|
|---|
| 126 | (set-macro-character #\] (get-macro-character #\)) nil *elisp-readtable*)
|
|---|
| 127 | (set-macro-character #\? 'read-character nil *elisp-readtable*)
|
|---|
| 128 | (set-macro-character #\" 'read-string nil *elisp-readtable*)
|
|---|
| 129 | (set-dispatch-macro-character #\# #\& #'sharp-ampersand *elisp-readtable*)
|
|---|
| 130 | (set-syntax-from-char #\[ #\()
|
|---|
| 131 | (set-syntax-from-char #\] #\))
|
|---|
