diff --git a/code/reader.lisp b/code/reader.lisp index 242449b1abf79419d2a79b1349c2892772824cb0..aa5411f5153a49dfc9b699f9b87c56aeef338217 100644 --- a/code/reader.lisp +++ b/code/reader.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (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 @@ ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (do ((attribute-table (character-attribute-table *readtable*)) - (char (fast-read-char t) (fast-read-char t))) - ((/= (the fixnum (aref attribute-table (char-code char))) - #.whitespace) - (done-with-fast-read-char) - char)))) - (fundamental-stream - (do ((attribute-table (character-attribute-table *readtable*)) - (char (stream-read-char stream) (stream-read-char stream))) - ((or (eq char :eof) - (/= (the fixnum (aref attribute-table (char-code char))) - #.whitespace)) - (if (eq char :eof) - (error 'end-of-file :stream stream) - char))))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (do ((attribute-table (character-attribute-table *readtable*)) + (char (fast-read-char t) (fast-read-char t))) + ((/= (the fixnum (aref attribute-table (char-code char))) + #.whitespace) + (done-with-fast-read-char) + char))) + ;; Fundamental-stream. + (do ((attribute-table (character-attribute-table *readtable*)) + (char (stream-read-char stream) (stream-read-char stream))) + ((or (eq char :eof) + (/= (the fixnum (aref attribute-table (char-code char))) + #.whitespace)) + (if (eq char :eof) + (error 'end-of-file :stream stream) + char)))))) ;;;; Temporary initialization hack. @@ -544,16 +543,15 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (do ((char (fast-read-char nil nil) - (fast-read-char nil nil))) - ((or (not char) (char= char #\newline)) - (done-with-fast-read-char))))) - (fundamental-stream - (do ((char (stream-read-char stream) (stream-read-char stream))) - ((or (eq char :eof) (char= char #\newline))))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char nil nil) + (fast-read-char nil nil))) + ((or (not char) (char= char #\newline)) + (done-with-fast-read-char)))) + ;; Fundamental-stream. + (do ((char (stream-read-char stream) (stream-read-char stream))) + ((or (eq char :eof) (char= char #\newline)))))) ;;don't return anything (values)) @@ -606,24 +604,23 @@ ;;for a very long string, this could end up bloating the read buffer. (reset-read-buffer) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (do ((char (fast-read-char t) (fast-read-char t))) - ((char= char closech) - (done-with-fast-read-char)) - (if (escapep char) (setq char (fast-read-char t))) - (ouch-read-buffer char)))) - (fundamental-stream - (do ((char (stream-read-char stream) (stream-read-char stream))) - ((or (eq char :eof) (char= char closech)) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (do ((char (fast-read-char t) (fast-read-char t))) + ((char= char closech) + (done-with-fast-read-char)) + (if (escapep char) (setq char (fast-read-char t))) + (ouch-read-buffer char))) + ;; Fundamental-stream. + (do ((char (stream-read-char stream) (stream-read-char stream))) + ((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) (error 'end-of-file :stream stream))) - (when (escapep char) - (setq char (stream-read-char stream)) - (if (eq char :eof) - (error 'end-of-file :stream stream))) - (ouch-read-buffer char))))) + (ouch-read-buffer char)))) (read-buffer-to-string)) (defun read-right-paren (stream ignore) @@ -985,38 +982,37 @@ SYMBOL ;;not a dot, dots, or number. (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (fast-read-char nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.escape (done-with-fast-read-char) - (go ESCAPE)) - (#.delimiter (done-with-fast-read-char) - (unread-char char stream) - (go RETURN-SYMBOL)) - (#.multiple-escape (done-with-fast-read-char) - (go MULT-ESCAPE)) - (#.package-delimiter (done-with-fast-read-char) - (go COLON)) - (t (go SYMBOL-LOOP)))))) - (fundamental-stream - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (stream-read-char stream)) - (when (eq char :eof) (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.escape (go ESCAPE)) - (#.delimiter (stream-unread-char stream char) - (go RETURN-SYMBOL)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) - (t (go SYMBOL-LOOP))))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (done-with-fast-read-char) + (go ESCAPE)) + (#.delimiter (done-with-fast-read-char) + (unread-char char stream) + (go RETURN-SYMBOL)) + (#.multiple-escape (done-with-fast-read-char) + (go MULT-ESCAPE)) + (#.package-delimiter (done-with-fast-read-char) + (go COLON)) + (t (go SYMBOL-LOOP))))) + ;; Fundamental-stream. + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (stream-read-char stream)) + (when (eq char :eof) (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.escape (go ESCAPE)) + (#.delimiter (stream-unread-char stream char) + (go RETURN-SYMBOL)) + (#.multiple-escape (go MULT-ESCAPE)) + (#.package-delimiter (go COLON)) + (t (go SYMBOL-LOOP)))))) ESCAPE ;;saw an escape. ;;don't put the escape in the read-buffer. diff --git a/code/sharpm.lisp b/code/sharpm.lisp index 4371d241044e20688165a13a67980f69588889a8..3ac3b80281e396022663a55f37ff33a21a7d46fd 100644 --- a/code/sharpm.lisp +++ b/code/sharpm.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (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 @@ (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) (let ((stream (in-synonym-of stream))) - (etypecase stream - (lisp-stream - (prepare-for-fast-read-char stream - (do ((level 1) - (prev (fast-read-char) char) - (char (fast-read-char) (fast-read-char))) - (()) - (cond ((and (char= prev #\|) (char= char #\#)) - (setq level (1- level)) - (when (zerop level) - (done-with-fast-read-char) - (return (values))) - (setq char (fast-read-char))) - ((and (char= prev #\#) (char= char #\|)) - (setq char (fast-read-char)) - (setq level (1+ level))))))) - (fundamental-stream - (do ((level 1) - (prev (read-char stream t) char) - (char (read-char stream t) (read-char stream t))) - (()) - (cond ((and (char= prev #\|) (char= char #\#)) - (setq level (1- level)) - (when (zerop level) - (return (values))) - (setq char (read-char stream t))) - ((and (char= prev #\#) (char= char #\|)) - (setq char (read-char stream t)) - (setq level (1+ level))))))))) + (if (lisp-stream-p stream) + (prepare-for-fast-read-char stream + (do ((level 1) + (prev (fast-read-char) char) + (char (fast-read-char) (fast-read-char))) + (()) + (cond ((and (char= prev #\|) (char= char #\#)) + (setq level (1- level)) + (when (zerop level) + (done-with-fast-read-char) + (return (values))) + (setq char (fast-read-char))) + ((and (char= prev #\#) (char= char #\|)) + (setq char (fast-read-char)) + (setq level (1+ level)))))) + ;; Fundamental-stream. + (do ((level 1) + (prev (read-char stream t) char) + (char (read-char stream t) (read-char stream t))) + (()) + (cond ((and (char= prev #\|) (char= char #\#)) + (setq level (1- level)) + (when (zerop level) + (return (values))) + (setq char (read-char stream t))) + ((and (char= prev #\#) (char= char #\|)) + (setq char (read-char stream t)) + (setq level (1+ level)))))))) (defun sharp-illegal (stream sub-char ignore) (declare (ignore ignore)) diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp index c41578ad044ada9466fb486c4d141835b1e8790f..3260802e76b235a4df080fabdf287ace4b9c0fad 100644 --- a/code/sysmacs.lisp +++ b/code/sysmacs.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (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 @@ (T ,@(if check-type `((check-type ,svar ,check-type))) ,svar))))) -;;; With-Mumble-Stream calls the function in the given Slot of the Stream with -;;; the Args for lisp-streams or the pcl-fn for fundamental-streams. +;;; With-Mumble-Stream calls the function in the given Slot of the +;;; 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))) - (etypecase stream - (lisp-stream - ,(destructuring-bind (slot &rest args) lisp-dispatch - `(funcall (,slot stream) stream ,@args))) - ,@(when pcl-dispatch - `((fundamental-stream - ,(destructuring-bind (pcl-fn &rest args) pcl-dispatch - `(,pcl-fn stream ,@args)))))))) - -(defmacro with-out-stream (stream lisp-dispatch &optional pcl-dispatch) + (if (lisp-stream-p stream) + (funcall (,slot stream) stream ,@args) + ,@(when stream-dispatch + `(,(destructuring-bind (function &rest args) stream-dispatch + `(,function stream ,@args))))))) + +(defmacro with-out-stream (stream (slot &rest args) &optional stream-dispatch) `(let ((stream (out-synonym-of ,stream))) - (etypecase stream - (lisp-stream - ,(destructuring-bind (slot &rest args) lisp-dispatch - `(funcall (,slot stream) stream ,@args))) - ,@(when pcl-dispatch - `((fundamental-stream - ,(destructuring-bind (pcl-fn &rest args) pcl-dispatch - `(,pcl-fn stream ,@args)))))))) + (if (lisp-stream-p stream) + (funcall (,slot stream) stream ,@args) + ,@(when stream-dispatch + `(,(destructuring-bind (function &rest args) stream-dispatch + `(,function stream ,@args))))))) ;;;; These are hacks to make the reader win. ;;; Prepare-For-Fast-Read-Char -- Internal ;;; -;;; This macro sets up some local vars for use by the Fast-Read-Char -;;; macro within the enclosed lexical scope. +;;; This macro sets up some local vars for use by the +;;; 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) - `(let* ((%frc-stream% (in-synonym-of ,stream lisp-stream)) + `(let* ((%frc-stream% ,stream) (%frc-method% (lisp-stream-in %frc-stream%)) (%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) (%frc-index% (lisp-stream-in-index %frc-stream%))) @@ -178,10 +174,10 @@ ;;; Prepare-For-Fast-Read-Byte -- Internal ;;; ;;; 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) - `(let* ((%frc-stream% (in-synonym-of ,stream lisp-stream)) + `(let* ((%frc-stream% ,stream) (%frc-method% (lisp-stream-bin %frc-stream%)) (%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) (%frc-index% (lisp-stream-in-index %frc-stream%)))