:test #'char= :key #'car)))
(set-cat-entry to-char att to-readtable)
(set-cmt-entry to-char mac to-readtable)
- (when from-dpair
- (cond
- (to-dpair
- (let ((table (cdr to-dpair)))
- (clrhash table)
- (shallow-replace/eql-hash-table table (cdr from-dpair))))
- (t
- (let ((pair (cons to-char (make-hash-table))))
- (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+ (cond ((and (not from-dpair) (not to-dpair)))
+ ((and (not from-dpair) to-dpair)
(setf (dispatch-tables to-readtable)
- (push pair (dispatch-tables to-readtable)))))))))
+ (remove to-dpair (dispatch-tables to-readtable))))
+ (to-dpair
+ (let ((table (cdr to-dpair)))
+ (clrhash table)
+ (shallow-replace/eql-hash-table table (cdr from-dpair))))
+ (t
+ (let ((pair (cons to-char (make-hash-table))))
+ (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
+ (setf (dispatch-tables to-readtable)
+ (push pair (dispatch-tables to-readtable))))))))
t)
(defun set-macro-character (char function &optional
"Causes CHAR to be a macro character which invokes FUNCTION when seen
by the reader. The NON-TERMINATINGP flag can be used to make the macro
character non-terminating, i.e. embeddable in a symbol name."
- (let ((designated-readtable (or rt-designator *standard-readtable*)))
+ (let ((designated-readtable (or rt-designator *standard-readtable*))
+ (function (%coerce-callable-to-fun function)))
(assert-not-standard-readtable designated-readtable 'set-macro-character)
(set-cat-entry char (if non-terminatingp
+char-attr-constituent+
(values fun-value
;; NON-TERMINATING-P return value:
(if fun-value
- (or (constituentp char)
- (not (terminating-macrop char)))
+ (or (constituentp char designated-readtable)
+ (not (terminating-macrop char designated-readtable)))
;; ANSI's definition of GET-MACRO-CHARACTER says this
;; value is NIL when CHAR is not a macro character.
;; I.e. this value means not just "non-terminating
(declaim (inline ouch-read-buffer))
(defun ouch-read-buffer (char)
;; When buffer overflow
- (when (>= *ouch-ptr* (length *read-buffer*))
+ (let ((op *ouch-ptr*))
+ (declare (optimize (sb!c::insert-array-bounds-checks 0)))
+ (when (>= op (length *read-buffer*))
;; Size should be doubled.
- (grow-read-buffer))
- (setf (elt *read-buffer* *ouch-ptr*) char)
- (setq *ouch-ptr* (1+ *ouch-ptr*)))
+ (grow-read-buffer))
+ (setf (elt *read-buffer* op) char)
+ (setq *ouch-ptr* (1+ op))))
(defun grow-read-buffer ()
(let* ((rbl (length *read-buffer*))
\f
;;;; READ-FROM-STRING
-(defun read-from-string (string &optional (eof-error-p t) eof-value
- &key (start 0) end
- preserve-whitespace)
- #!+sb-doc
- "The characters of string are successively given to the lisp reader
- and the lisp object built by the reader is returned. Macro chars
- will take effect."
- (declare (string string))
+(defun maybe-note-read-from-string-signature-issue (eof-error-p)
+ ;; The interface is so unintuitive that we explicitly check for the common
+ ;; error.
+ (when (member eof-error-p '(:start :end :preserve-whitespace))
+ (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~
+ Two optional arguments must be provided before the ~
+ first keyword argument.~:@>"
+ eof-error-p 'read-from-string)
+ t))
+
+(declaim (ftype (sfunction (string t t index (or null index) t) (values t index))
+ %read-from-string))
+(defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace)
(with-array-data ((string string :offset-var offset)
(start start)
(end end)
(%read-preserving-whitespace stream eof-error-p eof-value nil)
(read stream eof-error-p eof-value))
(- (string-input-stream-current stream) offset)))))
+
+(defun read-from-string (string &optional (eof-error-p t) eof-value
+ &key (start 0) end preserve-whitespace)
+ #!+sb-doc
+ "The characters of string are successively given to the lisp reader
+ and the lisp object built by the reader is returned. Macro chars
+ will take effect."
+ (declare (string string))
+ (maybe-note-read-from-string-signature-issue eof-error-p)
+ (%read-from-string string eof-error-p eof-value start end preserve-whitespace))
+
+(define-compiler-macro read-from-string (&whole form string &rest args)
+ ;; Check this at compile-time, and rewrite it so we're silent at runtime.
+ (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys)
+ args
+ (cond ((maybe-note-read-from-string-signature-issue eof-error-p)
+ `(read-from-string ,string t ,eof-value ,@keys))
+ (t
+ (let* ((start (gensym "START"))
+ (end (gensym "END"))
+ (preserve-whitespace (gensym "PRESERVE-WHITESPACE"))
+ bind seen ignore)
+ (do ()
+ ((not (cdr keys))
+ ;; Odd number of keys, punt.
+ (when keys (return-from read-from-string form)))
+ (let* ((key (pop keys))
+ (value (pop keys))
+ (var (case key
+ (:start start)
+ (:end end)
+ (:preserve-whitespace preserve-whitespace)
+ (otherwise
+ (return-from read-from-string form)))))
+ (when (member key seen)
+ (setf var (gensym "IGNORE"))
+ (push var ignore))
+ (push key seen)
+ (push (list var value) bind)))
+ (dolist (default (list (list start 0)
+ (list end nil)
+ (list preserve-whitespace nil)))
+ (unless (assoc (car default) bind)
+ (push default bind)))
+ (once-only ((string string))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (%read-from-string ,string ,eof-error-p ,eof-value
+ ,start ,end ,preserve-whitespace))))))))
\f
;;;; PARSE-INTEGER
projects / sbcl.git / blobdiff