- (ecase (%read-char stream)
- (#\'
- (list 'function (ls-read stream)))
- (#\( (list-to-vector (%read-list stream)))
- (#\: (make-symbol
- (unescape
- (string-upcase-noescaped
- (read-escaped-until stream #'terminalp)))))
- (#\\
- (let ((cname
- (concat (string (%read-char stream))
- (read-until stream #'terminalp))))
+ (let ((ch (%read-char stream)))
+ (case ch
+ (#\'
+ (list 'function (ls-read stream eof-error-p eof-value t)))
+ (#\(
+ (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))))
+ (#\:
+ (make-symbol
+ (unescape-token
+ (string-upcase-noescaped
+ (read-escaped-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 (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)))))
+ ((#\J #\j)
+ (unless (char= (%peek-char stream) #\:)
+ (error "FFI descriptor must start with a semicolon."))
+ (let ((descriptor (subseq (read-until stream #'terminalp) 1))
+ (subdescriptors nil))
+ (do* ((start 0 (1+ end))
+ (end (position #\: descriptor :start start)
+ (position #\: descriptor :start start)))
+ ((null end)
+ (push (subseq descriptor start) subdescriptors)
+ `(oget *root* ,@(reverse subdescriptors)))
+ (push (subseq descriptor start end) subdescriptors))))
+ (otherwise