- (ecase (%read-char stream)
- (#\'
- (list 'function (ls-read-1 stream)))
- (#\( (list-to-vector (%read-list stream)))
- (#\: (make-symbol (string-upcase (read-until stream #'terminalp))))
- (#\\
- (let ((cname
- (concat (string (%read-char stream))
- (read-until stream #'terminalp))))
- (cond
- ((string= cname "space") #\space)
- ((string= cname "tab") #\tab)
- ((string= cname "newline") #\newline)
- (t (char cname 0)))))
- (#\+
- (let ((feature (read-until stream #'terminalp)))
- (cond
- ((string= feature "common-lisp")
- (ls-read-1 stream) ;ignore
- (ls-read-1 stream))
- ((string= feature "jscl")
- (ls-read-1 stream))
- (t
- (error "Unknown reader form.")))))))
-
-(defun unescape (x)
+ (let ((ch (%read-char stream)))
+ (cond
+ ((char= ch #\')
+ (list 'function (ls-read stream eof-error-p eof-value t)))
+ ((char= ch #\()
+ (do ((elements nil)
+ (result nil)
+ (index 0 (1+ index)))
+ ((progn (skip-whitespaces-and-comments stream)
+ (or (null (%peek-char stream))
+ (char= (%peek-char stream) #\))))
+ (discard-char stream #\))
+ (setf result (make-array index))
+ (dotimes (i index)
+ (aset result (decf index) (pop elements)))
+ result)
+ (let* ((ix index) ; Can't just use index: the same var would be captured in all fixups
+ (*make-fixup-function* (lambda ()
+ (lambda (obj)
+ (aset result ix obj))))
+ (eof (gensym))
+ (value (ls-read stream nil eof t)))
+ (push value elements))))
+ ((char= ch #\:)
+ (make-symbol
+ (unescape-token
+ (string-upcase-noescaped
+ (read-escaped-until stream #'terminalp)))))
+ ((char= ch #\\)
+ (let ((cname
+ (concat (string (%read-char stream))
+ (read-until stream #'terminalp))))
+ (cond
+ ((string= cname "space") #\space)
+ ((string= cname "tab") #\tab)
+ ((string= cname "newline") #\newline)
+ (t (char cname 0)))))
+ ((or (char= ch #\+)
+ (char= ch #\-))
+ (let ((feature (let ((symbol (ls-read stream eof-error-p eof-value t)))
+ (unless (symbolp symbol)
+ (error "Invalid feature ~S" symbol))
+ (intern (string symbol) "KEYWORD"))))
+ (if (eql (char= ch #\+)
+ (and (find feature *features*) t))
+ (ls-read stream eof-error-p eof-value t)
+ (prog2 (ls-read stream)
+ (ls-read stream eof-error-p eof-value t)))))
+ ((and ch (digit-char-p ch))
+ (let ((id (digit-char-p ch)))
+ (while (and (%peek-char stream)
+ (digit-char-p (%peek-char stream)))
+ (setf id (+ (* id 10) (digit-char-p (%read-char stream)))))
+ (ecase (%peek-char stream)
+ (#\=
+ (%read-char stream)
+ (if (find-labelled-object id)
+ (error "Duplicated label #~S=" id)
+ (progn
+ (add-labelled-object id *future-value*)
+ (let ((obj (ls-read stream eof-error-p eof-value t)))
+ ;; FIXME: somehow the more natural
+ ;; (setf (cdr (find-labelled-object id)) obj)
+ ;; doesn't work
+ (rplacd (find-labelled-object id) obj)
+ obj))))
+ (#\#
+ (%read-char stream)
+ (let ((cell (find-labelled-object id)))
+ (if cell
+ (if (eq (cdr cell) *future-value*)
+ (progn
+ (push (cons (funcall *make-fixup-function*)
+ id)
+ *fixup-locations*)
+ *fixup-value*)
+ (cdr cell))
+ (error "Invalid labelled object #~S#" id)))))))
+ (t
+ (error "Invalid dispatch character after #")))))
+
+(defun unescape-token (x)