Skip to content
Snippets Groups Projects
Commit 2db772f7 authored by dtc's avatar dtc
Browse files

Streamline the Gray streams related dispatch code.

parent 20fb9e4e
No related branches found
No related tags found
No related merge requests found
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.26 1998/05/05 00:14:36 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.27 1998/05/15 01:01:02 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -336,24 +336,23 @@ ...@@ -336,24 +336,23 @@
;; This flushes whitespace chars, returning the last char it read (a ;; This flushes whitespace chars, returning the last char it read (a
;; non-white one). It always gets an error on end-of-file. ;; non-white one). It always gets an error on end-of-file.
(let ((stream (in-synonym-of stream))) (let ((stream (in-synonym-of stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (prepare-for-fast-read-char stream
(prepare-for-fast-read-char stream (do ((attribute-table (character-attribute-table *readtable*))
(do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t)))
(char (fast-read-char t) (fast-read-char t))) ((/= (the fixnum (aref attribute-table (char-code char)))
((/= (the fixnum (aref attribute-table (char-code char))) #.whitespace)
#.whitespace) (done-with-fast-read-char)
(done-with-fast-read-char) char)))
char)))) ;; Fundamental-stream.
(fundamental-stream (do ((attribute-table (character-attribute-table *readtable*))
(do ((attribute-table (character-attribute-table *readtable*)) (char (stream-read-char stream) (stream-read-char stream)))
(char (stream-read-char stream) (stream-read-char stream))) ((or (eq char :eof)
((or (eq char :eof) (/= (the fixnum (aref attribute-table (char-code char)))
(/= (the fixnum (aref attribute-table (char-code char))) #.whitespace))
#.whitespace)) (if (eq char :eof)
(if (eq char :eof) (error 'end-of-file :stream stream)
(error 'end-of-file :stream stream) char))))))
char)))))))
;;;; Temporary initialization hack. ;;;; Temporary initialization hack.
...@@ -544,16 +543,15 @@ ...@@ -544,16 +543,15 @@
(defun read-comment (stream ignore) (defun read-comment (stream ignore)
(declare (ignore ignore)) (declare (ignore ignore))
(let ((stream (in-synonym-of stream))) (let ((stream (in-synonym-of stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (prepare-for-fast-read-char stream
(prepare-for-fast-read-char stream (do ((char (fast-read-char nil nil)
(do ((char (fast-read-char nil nil) (fast-read-char nil nil)))
(fast-read-char nil nil))) ((or (not char) (char= char #\newline))
((or (not char) (char= char #\newline)) (done-with-fast-read-char))))
(done-with-fast-read-char))))) ;; Fundamental-stream.
(fundamental-stream (do ((char (stream-read-char stream) (stream-read-char stream)))
(do ((char (stream-read-char stream) (stream-read-char stream))) ((or (eq char :eof) (char= char #\newline))))))
((or (eq char :eof) (char= char #\newline)))))))
;;don't return anything ;;don't return anything
(values)) (values))
...@@ -606,24 +604,23 @@ ...@@ -606,24 +604,23 @@
;;for a very long string, this could end up bloating the read buffer. ;;for a very long string, this could end up bloating the read buffer.
(reset-read-buffer) (reset-read-buffer)
(let ((stream (in-synonym-of stream))) (let ((stream (in-synonym-of stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (prepare-for-fast-read-char stream
(prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t)))
(do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech)
((char= char closech) (done-with-fast-read-char))
(done-with-fast-read-char)) (if (escapep char) (setq char (fast-read-char t)))
(if (escapep char) (setq char (fast-read-char t))) (ouch-read-buffer char)))
(ouch-read-buffer char)))) ;; Fundamental-stream.
(fundamental-stream (do ((char (stream-read-char stream) (stream-read-char stream)))
(do ((char (stream-read-char stream) (stream-read-char stream))) ((or (eq char :eof) (char= char closech))
((or (eq char :eof) (char= char closech)) (if (eq char :eof)
(error 'end-of-file :stream stream)))
(when (escapep char)
(setq char (stream-read-char stream))
(if (eq char :eof) (if (eq char :eof)
(error 'end-of-file :stream stream))) (error 'end-of-file :stream stream)))
(when (escapep char) (ouch-read-buffer char))))
(setq char (stream-read-char stream))
(if (eq char :eof)
(error 'end-of-file :stream stream)))
(ouch-read-buffer char)))))
(read-buffer-to-string)) (read-buffer-to-string))
(defun read-right-paren (stream ignore) (defun read-right-paren (stream ignore)
...@@ -985,38 +982,37 @@ ...@@ -985,38 +982,37 @@
SYMBOL SYMBOL
;;not a dot, dots, or number. ;;not a dot, dots, or number.
(let ((stream (in-synonym-of stream))) (let ((stream (in-synonym-of stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (prepare-for-fast-read-char stream
(prepare-for-fast-read-char stream (prog ()
(prog () SYMBOL-LOOP
SYMBOL-LOOP (ouch-read-buffer char)
(ouch-read-buffer char) (setq char (fast-read-char nil nil))
(setq char (fast-read-char nil nil)) (unless char (go RETURN-SYMBOL))
(unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table)
(case (char-class char attribute-table) (#.escape (done-with-fast-read-char)
(#.escape (done-with-fast-read-char) (go ESCAPE))
(go ESCAPE)) (#.delimiter (done-with-fast-read-char)
(#.delimiter (done-with-fast-read-char) (unread-char char stream)
(unread-char char stream) (go RETURN-SYMBOL))
(go RETURN-SYMBOL)) (#.multiple-escape (done-with-fast-read-char)
(#.multiple-escape (done-with-fast-read-char) (go MULT-ESCAPE))
(go MULT-ESCAPE)) (#.package-delimiter (done-with-fast-read-char)
(#.package-delimiter (done-with-fast-read-char) (go COLON))
(go COLON)) (t (go SYMBOL-LOOP)))))
(t (go SYMBOL-LOOP)))))) ;; Fundamental-stream.
(fundamental-stream (prog ()
(prog () SYMBOL-LOOP
SYMBOL-LOOP (ouch-read-buffer char)
(ouch-read-buffer char) (setq char (stream-read-char stream))
(setq char (stream-read-char stream)) (when (eq char :eof) (go RETURN-SYMBOL))
(when (eq char :eof) (go RETURN-SYMBOL)) (case (char-class char attribute-table)
(case (char-class char attribute-table) (#.escape (go ESCAPE))
(#.escape (go ESCAPE)) (#.delimiter (stream-unread-char stream char)
(#.delimiter (stream-unread-char stream char) (go RETURN-SYMBOL))
(go RETURN-SYMBOL)) (#.multiple-escape (go MULT-ESCAPE))
(#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON))
(#.package-delimiter (go COLON)) (t (go SYMBOL-LOOP))))))
(t (go SYMBOL-LOOP)))))))
ESCAPE ESCAPE
;;saw an escape. ;;saw an escape.
;;don't put the escape in the read-buffer. ;;don't put the escape in the read-buffer.
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.18 1998/05/05 00:14:37 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.19 1998/05/15 01:01:02 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -351,35 +351,34 @@ ...@@ -351,35 +351,34 @@
(defun sharp-vertical-bar (stream sub-char numarg) (defun sharp-vertical-bar (stream sub-char numarg)
(ignore-numarg sub-char numarg) (ignore-numarg sub-char numarg)
(let ((stream (in-synonym-of stream))) (let ((stream (in-synonym-of stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (prepare-for-fast-read-char stream
(prepare-for-fast-read-char stream (do ((level 1)
(do ((level 1) (prev (fast-read-char) char)
(prev (fast-read-char) char) (char (fast-read-char) (fast-read-char)))
(char (fast-read-char) (fast-read-char))) (())
(()) (cond ((and (char= prev #\|) (char= char #\#))
(cond ((and (char= prev #\|) (char= char #\#)) (setq level (1- level))
(setq level (1- level)) (when (zerop level)
(when (zerop level) (done-with-fast-read-char)
(done-with-fast-read-char) (return (values)))
(return (values))) (setq char (fast-read-char)))
(setq char (fast-read-char))) ((and (char= prev #\#) (char= char #\|))
((and (char= prev #\#) (char= char #\|)) (setq char (fast-read-char))
(setq char (fast-read-char)) (setq level (1+ level))))))
(setq level (1+ level))))))) ;; Fundamental-stream.
(fundamental-stream (do ((level 1)
(do ((level 1) (prev (read-char stream t) char)
(prev (read-char stream t) char) (char (read-char stream t) (read-char stream t)))
(char (read-char stream t) (read-char stream t))) (())
(()) (cond ((and (char= prev #\|) (char= char #\#))
(cond ((and (char= prev #\|) (char= char #\#)) (setq level (1- level))
(setq level (1- level)) (when (zerop level)
(when (zerop level) (return (values)))
(return (values))) (setq char (read-char stream t)))
(setq char (read-char stream t))) ((and (char= prev #\#) (char= char #\|))
((and (char= prev #\#) (char= char #\|)) (setq char (read-char stream t))
(setq char (read-char stream t)) (setq level (1+ level))))))))
(setq level (1+ level)))))))))
(defun sharp-illegal (stream sub-char ignore) (defun sharp-illegal (stream sub-char ignore)
(declare (ignore ignore)) (declare (ignore ignore))
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain. ;;; Carnegie Mellon University, and has been placed in the public domain.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.19 1998/05/05 00:14:35 dtc Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.20 1998/05/15 01:01:03 dtc Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -107,41 +107,37 @@ ...@@ -107,41 +107,37 @@
(T ,@(if check-type `((check-type ,svar ,check-type))) (T ,@(if check-type `((check-type ,svar ,check-type)))
,svar))))) ,svar)))))
;;; With-Mumble-Stream calls the function in the given Slot of the Stream with ;;; With-Mumble-Stream calls the function in the given Slot of the
;;; the Args for lisp-streams or the pcl-fn for fundamental-streams. ;;; Stream with the Args for lisp-streams, or the Function with the
;;; Args for fundamental-streams.
;;; ;;;
(defmacro with-in-stream (stream lisp-dispatch &optional pcl-dispatch) (defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
`(let ((stream (in-synonym-of ,stream))) `(let ((stream (in-synonym-of ,stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (funcall (,slot stream) stream ,@args)
,(destructuring-bind (slot &rest args) lisp-dispatch ,@(when stream-dispatch
`(funcall (,slot stream) stream ,@args))) `(,(destructuring-bind (function &rest args) stream-dispatch
,@(when pcl-dispatch `(,function stream ,@args)))))))
`((fundamental-stream
,(destructuring-bind (pcl-fn &rest args) pcl-dispatch (defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch)
`(,pcl-fn stream ,@args))))))))
(defmacro with-out-stream (stream lisp-dispatch &optional pcl-dispatch)
`(let ((stream (out-synonym-of ,stream))) `(let ((stream (out-synonym-of ,stream)))
(etypecase stream (if (lisp-stream-p stream)
(lisp-stream (funcall (,slot stream) stream ,@args)
,(destructuring-bind (slot &rest args) lisp-dispatch ,@(when stream-dispatch
`(funcall (,slot stream) stream ,@args))) `(,(destructuring-bind (function &rest args) stream-dispatch
,@(when pcl-dispatch `(,function stream ,@args)))))))
`((fundamental-stream
,(destructuring-bind (pcl-fn &rest args) pcl-dispatch
`(,pcl-fn stream ,@args))))))))
;;;; These are hacks to make the reader win. ;;;; These are hacks to make the reader win.
;;; Prepare-For-Fast-Read-Char -- Internal ;;; Prepare-For-Fast-Read-Char -- Internal
;;; ;;;
;;; This macro sets up some local vars for use by the Fast-Read-Char ;;; This macro sets up some local vars for use by the
;;; macro within the enclosed lexical scope. ;;; Fast-Read-Char macro within the enclosed lexical scope. The stream
;;; is assumed to be a lisp-stream.
;;; ;;;
(defmacro prepare-for-fast-read-char (stream &body forms) (defmacro prepare-for-fast-read-char (stream &body forms)
`(let* ((%frc-stream% (in-synonym-of ,stream lisp-stream)) `(let* ((%frc-stream% ,stream)
(%frc-method% (lisp-stream-in %frc-stream%)) (%frc-method% (lisp-stream-in %frc-stream%))
(%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
(%frc-index% (lisp-stream-in-index %frc-stream%))) (%frc-index% (lisp-stream-in-index %frc-stream%)))
...@@ -178,10 +174,10 @@ ...@@ -178,10 +174,10 @@
;;; Prepare-For-Fast-Read-Byte -- Internal ;;; Prepare-For-Fast-Read-Byte -- Internal
;;; ;;;
;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin ;;; Just like Prepare-For-Fast-Read-Char except that we get the Bin
;;; method. ;;; method. The stream is assumed to be a lisp-stream.
;;; ;;;
(defmacro prepare-for-fast-read-byte (stream &body forms) (defmacro prepare-for-fast-read-byte (stream &body forms)
`(let* ((%frc-stream% (in-synonym-of ,stream lisp-stream)) `(let* ((%frc-stream% ,stream)
(%frc-method% (lisp-stream-bin %frc-stream%)) (%frc-method% (lisp-stream-bin %frc-stream%))
(%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) (%frc-buffer% (lisp-stream-in-buffer %frc-stream%))
(%frc-index% (lisp-stream-in-index %frc-stream%))) (%frc-index% (lisp-stream-in-index %frc-stream%)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment