From 6c21ff8a3d0bb719f63bf989aa7f8035ef79e3a0 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Mon, 4 May 1998 01:27:24 +0000 Subject: [PATCH] Gray streams support: * Rename the 'stream structure class to sys:lisp-stream. * Add a new none hierarchical 'stream built-in class which inherits from: instance, t. * Hack in the new stream class as a mixin for the structure base lisp-stream class which now inherits from: stream, structure-object, instance, t. * Add a new 'fundamental-stream standard-class which includes 'stream as a mixin, and add PCL hacks to allow this to be redefined after PCL is loaded to be (defclass fundamental-stream (standard-object stream) ...). * Add appropriate support to the base stream functions to dispatch to the Gray stream functions for the handling of fundamental-streams. Some of the lisp-streams encapsulating CLOS streams still need a little work. --- code/class.lisp | 25 +- code/defstruct.lisp | 15 +- code/exports.lisp | 52 ++-- code/fd-stream.lisp | 6 +- code/filesys.lisp | 4 +- code/globals.lisp | 12 +- code/load.lisp | 4 +- code/pprint.lisp | 4 +- code/print.lisp | 12 +- code/reader.lisp | 123 ++++++--- code/sharpm.lisp | 46 +++- code/stream.lisp | 542 ++++++++++++++++++++++--------------- code/struct.lisp | 13 +- code/sysmacs.lisp | 67 +++-- compiler/generic/core.lisp | 4 +- hemlock/bit-stream.lisp | 4 +- hemlock/eval-server.lisp | 4 +- hemlock/rompsite.lisp | 4 +- hemlock/shell.lisp | 4 +- hemlock/streams.lisp | 18 +- hemlock/struct.lisp | 4 +- hemlock/ts-stream.lisp | 4 +- hemlock/tty-stream.lisp | 4 +- pcl/braid.lisp | 4 + pcl/cache.lisp | 17 +- pcl/defs.lisp | 6 +- pcl/std-class.lisp | 2 +- 27 files changed, 625 insertions(+), 379 deletions(-) diff --git a/code/class.lisp b/code/class.lisp index 9b2223c37..b041bc19e 100644 --- a/code/class.lisp +++ b/code/class.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/class.lisp,v 1.39 1998/03/21 08:11:50 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/class.lisp,v 1.40 1998/05/04 01:27:10 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -763,7 +763,10 @@ (null :translation (member nil) :inherits (list sequence mutable-sequence mutable-collection generic-sequence collection symbol) - :direct-superclasses (list symbol))))) + :direct-superclasses (list symbol)) + + (stream :hierarchical nil :state :read-only + :inherits (instance t))))) ;;; See also type-init.lisp where we finish setting up the translations for ;;; built-in types. @@ -804,6 +807,24 @@ (find-layout name 0 inherit-layouts inheritance-depth) :invalidate nil)))))) +;;; Define temporary PCL standard-classes; these will be setup +;;; correctly and the lisp layout replaced by a PCL wrapper after PCL +;;; is loaded and the class defined. +(cold-load-init + (dolist (x '((fundamental-stream (t instance stream)))) + (let* ((name (first x)) + (inherits (second x)) + (class (lisp::make-standard-class :name name)) + (class-cell (lisp::find-class-cell name))) + (setf (lisp::class-cell-class class-cell) class) + (setf (info type class name) class-cell) + (setf (info type kind name) :instance) + (let ((inherit-layouts + (map 'vector #'(lambda (x) + (lisp::class-layout (lisp:find-class x))) + inherits))) + (lisp::register-layout (lisp::find-layout name 0 inherit-layouts -1) + :invalidate nil))))) ;;; Now that we have set up the class heterarchy, seal the sealed classes. ;;; This must be done after the subclasses have been set up. diff --git a/code/defstruct.lisp b/code/defstruct.lisp index 69ac4021f..d42fa325d 100644 --- a/code/defstruct.lisp +++ b/code/defstruct.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/defstruct.lisp,v 1.62 1998/04/20 11:32:50 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.63 1998/05/04 01:27:11 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1304,7 +1304,11 @@ #'(lambda (x) (typep x (find-class class)))) (fdefinition constructor))) (setf (class-direct-superclasses class) - (list (layout-class (svref inherits (1- (length inherits)))))) + (if (eq (dd-name info) 'lisp-stream) + ;; Hack to add stream as a superclass mixin to lisp-streams. + (list (layout-class (svref inherits (1- (length inherits)))) + (layout-class (svref inherits (- (length inherits) 2)))) + (list (layout-class (svref inherits (1- (length inherits))))))) (let ((new-layout (make-layout :class class :inherits inherits :inheritance-depth (length inherits) @@ -1475,8 +1479,11 @@ (compiler-layout-or-lose (first include)) (class-layout (find-class (or (first superclass-opt) 'structure-object)))))) - (concatenate 'simple-vector (layout-inherits super) (vector super)))) - + (if (eq (dd-name info) 'lisp-stream) + ;; Hack to added the stream class as a mixin for lisp-streams. + (concatenate 'simple-vector (layout-inherits super) + (vector super (class-layout (find-class 'stream)))) + (concatenate 'simple-vector (layout-inherits super) (vector super))))) ;;; %COMPILER-ONLY-DEFSTRUCT -- Internal ;;; diff --git a/code/exports.lisp b/code/exports.lisp index de5b4e14d..f04c16c65 100644 --- a/code/exports.lisp +++ b/code/exports.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/exports.lisp,v 1.152 1998/05/01 01:02:54 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.153 1998/05/04 01:27:12 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -989,18 +989,35 @@ "*DEFAULT-PACKAGE-USE-LIST*" "*GC-RUN-TIME*" "CONNECT-TO-UNIX-SOCKET" "DEFINE-HASH-TABLE-TEST" - "DO-HASH" - "*EFFICIENCY-NOTE-LIMIT*" - "*ERROR-PRINT-LINES*" - "CREATE-UNIX-SOCKET" - "*INLINE-EXPANSION-LIMIT*" - "INSTANCE" - "*EFFICIENCY-NOTE-COST-THRESHOLD*" - "*USE-IMPLEMENTATION-TYPES*" - "*BYTE-COMPILE-TOP-LEVEL*" - "*BYTE-COMPILE-DEFAULT*" - "PURIFY" "MAP-APROPOS" - "*BATCH-MODE*")) + + "DO-HASH" + "*EFFICIENCY-NOTE-LIMIT*" + "*ERROR-PRINT-LINES*" + "CREATE-UNIX-SOCKET" + "*INLINE-EXPANSION-LIMIT*" + "INSTANCE" + "*EFFICIENCY-NOTE-COST-THRESHOLD*" + "*USE-IMPLEMENTATION-TYPES*" + "*BYTE-COMPILE-TOP-LEVEL*" + "*BYTE-COMPILE-DEFAULT*" + "PURIFY" "MAP-APROPOS" + "*BATCH-MODE*" + + ;; Gray streams extension. + "FUNDAMENTAL-BINARY-STREAM" "FUNDAMENTAL-BINARY-INPUT-STREAM" + "FUNDAMENTAL-BINARY-OUTPUT-STREAM" "FUNDAMENTAL-CHARACTER-STREAM" + "FUNDAMENTAL-CHARACTER-INPUT-STREAM" + "FUNDAMENTAL-CHARACTER-OUTPUT-STREAM" + "FUNDAMENTAL-INPUT-STREAM" "FUNDAMENTAL-OUTPUT-STREAM" + "FUNDAMENTAL-STREAM" + "STREAM-ADVANCE-TO-COLUMN" "STREAM-CLEAR-INPUT" + "STREAM-CLEAR-OUTPUT" "STREAM-FINISH-OUTPUT" "STREAM-FORCE-OUTPUT" + "STREAM-FRESH-LINE" "STREAM-LINE-COLUMN" "STREAM-LINE-LENGTH" + "STREAM-LISTEN" "STREAM-PEEK-CHAR" "STREAM-READ-BYTE" + "STREAM-READ-CHAR" "STREAM-READ-CHAR-NO-HANG" "STREAM-READ-LINE" + "STREAM-START-LINE-P" "STREAM-TERPRI" "STREAM-UNREAD-CHAR" + "STREAM-WRITE-BYTE" "STREAM-WRITE-CHAR" "STREAM-WRITE-STRING")) + (defpackage "LOOP") (dolist (name @@ -1240,11 +1257,12 @@ "DEFAULT-INTERRUPT" "DEFENUMERATION" "DEFOPERATOR" "DEFRECORD" "DEPORT-BOOLEAN" "DEPORT-INTEGER" "DOUBLE-FLOAT-RADIX" "ENABLE-INTERRUPT" "ENUMERATION" "FD-STREAM" "FD-STREAM-FD" - "FD-STREAM-P" "FIND-IF-IN-CLOSURE" - "FOREIGN-SYMBOL-ADDRESS" "GET-PAGE-SIZE" "GET-SYSTEM-INFO" + "FD-STREAM-P" "FIND-IF-IN-CLOSURE" "FOREIGN-SYMBOL-ADDRESS" + "GET-PAGE-SIZE" "GET-SYSTEM-INFO" "IGNORE-INTERRUPT" - "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" "LONG-FLOAT-RADIX" - "LONG-WORDS" "MACRO" "MAKE-CT-A-VAL" "MAKE-FD-STREAM" + "INT-SAP" "INVALIDATE-DESCRIPTOR" "IO-TIMEOUT" + "LISP-STREAM" "LONG-FLOAT-RADIX" "LONG-WORDS" + "MACRO" "MAKE-CT-A-VAL" "MAKE-FD-STREAM" "MAKE-INDENTING-STREAM" "MAKE-OBJECT-SET" "MAP-PORT" "MAP-XWINDOW" "NATURALIZE-BOOLEAN" "NATURALIZE-INTEGER" "NULL-TERMINATED-STRING" "OBJECT-SET-OPERATION" "OUTPUT-RAW-BYTES" "PARSE-BODY" diff --git a/code/fd-stream.lisp b/code/fd-stream.lisp index 96f48c81d..74a6d58fd 100644 --- a/code/fd-stream.lisp +++ b/code/fd-stream.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/fd-stream.lisp,v 1.42 1998/01/04 22:46:41 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fd-stream.lisp,v 1.43 1998/05/04 01:27:13 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -61,7 +61,7 @@ (defstruct (fd-stream (:print-function %print-fd-stream) (:constructor %make-fd-stream) - (:include stream + (:include lisp-stream (misc #'fd-stream-misc-routine))) (name nil) ; The name of this stream @@ -858,7 +858,7 @@ non-server method is also significantly more efficient for large reads. (when (eql size 1) (setf (fd-stream-n-bin stream) #'fd-stream-read-n-bytes) (when buffer-p - (setf (stream-in-buffer stream) + (setf (lisp-stream-in-buffer stream) (make-array in-buffer-length :element-type '(unsigned-byte 8))))) (setf input-size size) diff --git a/code/filesys.lisp b/code/filesys.lisp index 1f07131d2..990496a60 100644 --- a/code/filesys.lisp +++ b/code/filesys.lisp @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.48 1998/04/24 13:10:15 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.49 1998/05/04 01:27:13 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -847,7 +847,7 @@ non-nil, then Unix dot files are included too (as ls -a). When :vervose is supplied and non-nil, then a long listing of miscellaneous information is output one file per line." - (let ((*standard-output* (out-synonym-of stream)) + (let ((*standard-output* (stream-synonym-of stream)) (pathname pathname)) (if verbose (print-directory-verbose pathname all return-list) diff --git a/code/globals.lisp b/code/globals.lisp index 2a38a74d6..e719e7ffb 100644 --- a/code/globals.lisp +++ b/code/globals.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/globals.lisp,v 1.15 1998/02/05 18:51:14 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/globals.lisp,v 1.16 1998/05/04 01:27:14 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -64,3 +64,13 @@ hemlock-internals::device-init hemlock::ts-stream-p hemlock::ts-stream-wire hemlock-internals::window-hunk)) + +;;; Gray streams functions not defined until after PCL is loaded. +(declaim (ftype (function * *) + stream-advance-to-column stream-clear-input + stream-clear-output stream-finish-output stream-force-output + stream-fresh-line stream-line-column stream-line-length + stream-listen stream-peek-char stream-read-byte + stream-read-char stream-read-char-no-hang stream-read-line + stream-start-line-p stream-terpri stream-unread-char + stream-write-byte stream-write-char stream-write-string)) diff --git a/code/load.lisp b/code/load.lisp index 2d0ae537b..ac527ac9e 100644 --- a/code/load.lisp +++ b/code/load.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/load.lisp,v 1.69 1998/03/21 08:11:58 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.70 1998/05/04 01:27:14 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -66,7 +66,7 @@ "Count of the number of recursive loads.") (declaim (type index *load-depth*)) (defvar *fasl-file*) -(declaim (type stream fasl-file)) +(declaim (type lisp-stream fasl-file)) ;;; LOAD-FRESH-LINE -- internal. diff --git a/code/pprint.lisp b/code/pprint.lisp index 3d708c7b7..47afb1200 100644 --- a/code/pprint.lisp +++ b/code/pprint.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/pprint.lisp,v 1.23 1998/02/24 17:36:10 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pprint.lisp,v 1.24 1998/05/04 01:27:14 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -45,7 +45,7 @@ (defconstant default-line-length 80) (defstruct (pretty-stream - (:include stream + (:include sys:lisp-stream (:out #'pretty-out) (:sout #'pretty-sout) (:misc #'pretty-misc)) diff --git a/code/print.lisp b/code/print.lisp index dd2d11998..058932a8e 100644 --- a/code/print.lisp +++ b/code/print.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/print.lisp,v 1.70 1998/04/03 03:37:02 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.71 1998/05/04 01:27:15 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -148,14 +148,14 @@ ((:pprint-dispatch *print-pprint-dispatch*) *print-pprint-dispatch*)) "Outputs OBJECT to the specified stream, defaulting to *standard-output*" - (output-object object (out-synonym-of stream)) + (output-object object (stream-synonym-of stream)) object) (defun prin1 (object &optional stream) "Outputs a mostly READable printed representation of OBJECT on the specified stream." (let ((*print-escape* T)) - (output-object object (out-synonym-of stream))) + (output-object object (stream-synonym-of stream))) object) (defun princ (object &optional stream) @@ -163,13 +163,13 @@ specified stream." (let ((*print-escape* NIL) (*print-readably* NIL)) - (output-object object (out-synonym-of stream))) + (output-object object (stream-synonym-of stream))) object) (defun print (object &optional stream) "Outputs a terpri, the mostly READable printed represenation of OBJECT, and space to the stream." - (let ((stream (out-synonym-of stream))) + (let ((stream (stream-synonym-of stream))) (terpri stream) (prin1 object stream) (write-char #\space stream) @@ -179,7 +179,7 @@ "Prettily outputs the Object preceded by a newline." (let ((*print-pretty* t) (*print-escape* t) - (stream (out-synonym-of stream))) + (stream (stream-synonym-of stream))) (terpri stream) (output-object object stream)) (values)) diff --git a/code/reader.lisp b/code/reader.lisp index 89e2d7e4a..d67100445 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.24 1998/03/28 17:11:50 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.25 1998/05/04 01:27:15 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -333,15 +333,27 @@ (defmacro eofp (char) `(eq ,char eof-object)) (defun flush-whitespace (stream) - ;;This flushes whitespace chars, returning the last char it read (a non-white - ;;one). It always gets an error on end-of-file. - (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)))) - + ;; 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 (stream-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))))))) ;;;; Temporary initialization hack. @@ -531,11 +543,17 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) - (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)))) + (let ((stream (stream-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))))))) ;;don't return anything (values)) @@ -587,12 +605,25 @@ ;;this accumulates chars until it sees same char that invoked it. ;;for a very long string, this could end up bloating the read buffer. (reset-read-buffer) - (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))) + (let ((stream (stream-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 (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))))) (read-buffer-to-string)) (defun read-right-paren (stream ignore) @@ -953,23 +984,39 @@ (t (go SYMBOL))) SYMBOL ;;not a dot, dots, or number. - (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))))) + (let ((stream (stream-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))))))) ESCAPE ;;saw an escape. ;;don't put the escape in the read-buffer. diff --git a/code/sharpm.lisp b/code/sharpm.lisp index adaa6d2e3..bd12f50ab 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.16 1998/04/17 00:42:59 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sharpm.lisp,v 1.17 1998/05/04 01:27:16 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -350,20 +350,36 @@ (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) - (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))))))) + (let ((stream (stream-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))))))))) (defun sharp-illegal (stream sub-char ignore) (declare (ignore ignore)) diff --git a/code/stream.lisp b/code/stream.lisp index ae95fb43c..108da013a 100644 --- a/code/stream.lisp +++ b/code/stream.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/stream.lisp,v 1.29 1998/04/27 10:06:43 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/stream.lisp,v 1.30 1998/05/04 01:27:16 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -163,37 +163,37 @@ (defun input-stream-p (stream) "Returns non-nil if the given Stream can perform input operations." - (and (streamp stream) - (not (eq (stream-in stream) #'closed-flame)) - (or (not (eq (stream-in stream) #'ill-in)) - (not (eq (stream-bin stream) #'ill-bin))))) + (and (lisp-stream-p stream) + (not (eq (lisp-stream-in stream) #'closed-flame)) + (or (not (eq (lisp-stream-in stream) #'ill-in)) + (not (eq (lisp-stream-bin stream) #'ill-bin))))) (defun output-stream-p (stream) "Returns non-nil if the given Stream can perform output operations." - (and (streamp stream) - (not (eq (stream-in stream) #'closed-flame)) - (or (not (eq (stream-out stream) #'ill-out)) - (not (eq (stream-bout stream) #'ill-bout))))) + (and (lisp-stream-p stream) + (not (eq (lisp-stream-in stream) #'closed-flame)) + (or (not (eq (lisp-stream-out stream) #'ill-out)) + (not (eq (lisp-stream-bout stream) #'ill-bout))))) (defun open-stream-p (stream) "Return true if Stream is not closed." (declare (type stream stream)) - (not (eq (stream-in stream) #'closed-flame))) + (not (eq (lisp-stream-in stream) #'closed-flame))) (defun stream-element-type (stream) "Returns a type specifier for the kind of object returned by the Stream." (declare (type stream stream)) - (funcall (stream-misc stream) stream :element-type)) + (funcall (lisp-stream-misc stream) stream :element-type)) (defun interactive-stream-p (stream) "Return true if Stream does I/O on a terminal or other interactive device." (declare (type stream stream)) - (funcall (stream-misc stream) stream :interactive-p)) + (funcall (lisp-stream-misc stream) stream :interactive-p)) (defun open-stream-p (stream) "Return true if and only if STREAM has not been closed." (declare (type stream stream)) - (not (eq (stream-in stream) #'closed-flame))) + (not (eq (lisp-stream-in stream) #'closed-flame))) (defun close (stream &key abort) "Closes the given Stream. No more I/O may be performed, but inquiries @@ -201,18 +201,18 @@ up the side effects of having created the stream." (declare (type stream stream)) (when (open-stream-p stream) - (funcall (stream-misc stream) stream :close abort)) + (funcall (lisp-stream-misc stream) stream :close abort)) t) (defun set-closed-flame (stream) - (setf (stream-in stream) #'closed-flame) - (setf (stream-bin stream) #'closed-flame) - (setf (stream-n-bin stream) #'closed-flame) - (setf (stream-in stream) #'closed-flame) - (setf (stream-out stream) #'closed-flame) - (setf (stream-bout stream) #'closed-flame) - (setf (stream-sout stream) #'closed-flame) - (setf (stream-misc stream) #'closed-flame)) + (setf (lisp-stream-in stream) #'closed-flame) + (setf (lisp-stream-bin stream) #'closed-flame) + (setf (lisp-stream-n-bin stream) #'closed-flame) + (setf (lisp-stream-in stream) #'closed-flame) + (setf (lisp-stream-out stream) #'closed-flame) + (setf (lisp-stream-bout stream) #'closed-flame) + (setf (lisp-stream-sout stream) #'closed-flame) + (setf (lisp-stream-misc stream) #'closed-flame)) ;;;; File position and file length. @@ -230,11 +230,11 @@ (type (or index (member nil :start :end)) position)) (cond (position - (setf (stream-in-index stream) in-buffer-length) - (funcall (stream-misc stream) stream :file-position position)) + (setf (lisp-stream-in-index stream) in-buffer-length) + (funcall (lisp-stream-misc stream) stream :file-position position)) (t - (let ((res (funcall (stream-misc stream) stream :file-position nil))) - (when res (- res (- in-buffer-length (stream-in-index stream)))))))) + (let ((res (funcall (lisp-stream-misc stream) stream :file-position nil))) + (when res (- res (- in-buffer-length (lisp-stream-in-index stream)))))))) ;;; File-Length -- Public @@ -244,7 +244,7 @@ (defun file-length (stream) "This function returns the length of the file that File-Stream is open to." (declare (stream stream)) - (funcall (stream-misc stream) stream :file-length)) + (funcall (lisp-stream-misc stream) stream :file-length)) ;;; Input functions: @@ -254,34 +254,41 @@ "Returns a line of text read from the Stream as a string, discarding the newline character." (declare (ignore recursive-p)) - (prepare-for-fast-read-char stream - (let ((res (make-string 80)) - (len 80) - (index 0)) - (loop - (let ((ch (fast-read-char nil nil))) - (cond (ch - (when (char= ch #\newline) - (done-with-fast-read-char) - (return (values (shrink-vector res index) nil))) - (when (= index len) - (setq len (* len 2)) - (let ((new (make-string len))) - (replace new res) - (setq res new))) - (setf (schar res index) ch) - (incf index)) - ((zerop index) - (done-with-fast-read-char) - (return (values (eof-or-lose (in-synonym-of stream) - eof-errorp eof-value) - t))) - ;; since fast-read-char hit already the eof char, we - ;; shouldn't do another read-char - (t - (done-with-fast-read-char) - (return (values (shrink-vector res index) t))))))))) - + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (prepare-for-fast-read-char stream + (let ((res (make-string 80)) + (len 80) + (index 0)) + (loop + (let ((ch (fast-read-char nil nil))) + (cond (ch + (when (char= ch #\newline) + (done-with-fast-read-char) + (return (values (shrink-vector res index) nil))) + (when (= index len) + (setq len (* len 2)) + (let ((new (make-string len))) + (replace new res) + (setq res new))) + (setf (schar res index) ch) + (incf index)) + ((zerop index) + (done-with-fast-read-char) + (return (values (eof-or-lose stream eof-errorp eof-value) + t))) + ;; since fast-read-char hit already the eof char, we + ;; shouldn't do another read-char + (t + (done-with-fast-read-char) + (return (values (shrink-vector res index) t))))))))) + (fundamental-stream + (multiple-value-bind (string eof) + (stream-read-line stream) + (if (and eof (zerop (length string))) + (values (eof-or-lose stream eof-errorp eof-value) t) + (values string eof))))))) ;;; We proclaim them inline here, then proclaim them notinline at EOF, ;;; so, except in this file, they are not inline by default, but they can be. @@ -291,78 +298,139 @@ recursive-p) "Inputs a character from Stream and returns it." (declare (ignore recursive-p)) - (prepare-for-fast-read-char stream - (prog1 - (fast-read-char eof-errorp eof-value) - (done-with-fast-read-char)))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (prepare-for-fast-read-char stream + (prog1 + (fast-read-char eof-errorp eof-value) + (done-with-fast-read-char)))) + (fundamental-stream + (let ((char (stream-read-char stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char)))))) (defun unread-char (character &optional (stream *standard-input*)) "Puts the Character back on the front of the input Stream." - (let* ((stream (in-synonym-of stream)) - (index (1- (stream-in-index stream))) - (buffer (stream-in-buffer stream))) - (declare (fixnum index)) - (when (minusp index) (error "Nothing to unread.")) - (cond (buffer - (setf (aref buffer index) (char-code character)) - (setf (stream-in-index stream) index)) - (t - (funcall (stream-misc stream) stream :unread character)))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (let ((index (1- (lisp-stream-in-index stream))) + (buffer (lisp-stream-in-buffer stream))) + (declare (fixnum index)) + (when (minusp index) (error "Nothing to unread.")) + (cond (buffer + (setf (aref buffer index) (char-code character)) + (setf (lisp-stream-in-index stream) index)) + (t + (funcall (lisp-stream-misc stream) stream + :unread character))))) + (fundamental-stream + (stream-unread-char stream character)))) nil) (defun peek-char (&optional (peek-type nil) (stream *standard-input*) (eof-errorp t) eof-value recursive-p) "Peeks at the next character in the input Stream. See manual for details." (declare (ignore recursive-p)) - (let* ((stream (in-synonym-of stream)) - (char (read-char stream eof-errorp eof-value))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (read-char stream eof-errorp eof-value))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((eq peek-type t) - (do ((char char (read-char stream eof-errorp eof-value))) - ((or (eq char eof-value) (not (whitespace-char-p char))) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - (t - (unread-char char stream) - char)))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (let ((char (read-char stream eof-errorp eof-value))) + (cond ((eq char eof-value) char) + ((characterp peek-type) + (do ((char char (read-char stream eof-errorp eof-value))) + ((or (eq char eof-value) (char= char peek-type)) + (unless (eq char eof-value) + (unread-char char stream)) + char))) + ((eq peek-type t) + (do ((char char (read-char stream eof-errorp eof-value))) + ((or (eq char eof-value) (not (whitespace-char-p char))) + (unless (eq char eof-value) + (unread-char char stream)) + char))) + (t + (unread-char char stream) + char)))) + (fundamental-stream + (cond ((characterp peek-type) + (do ((char (stream-read-char stream) (stream-read-char stream))) + ((or (eq char :eof) (char= char peek-type)) + (cond ((eq char :eof) + (eof-or-lose stream eof-errorp eof-value)) + (t + (stream-unread-char stream char) + char))))) + ((eq peek-type t) + (do ((char (stream-read-char stream) (stream-read-char stream))) + ((or (eq char :eof) (not (whitespace-char-p char))) + (cond ((eq char :eof) + (eof-or-lose stream eof-errorp eof-value)) + (t + (stream-unread-char stream char) + char))))) + (t + (let ((char (stream-peek-char stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char)))))))) (defun listen (&optional (stream *standard-input*)) "Returns T if a character is availible on the given Stream." - (let ((stream (in-synonym-of stream))) - (or (/= (the fixnum (stream-in-index stream)) in-buffer-length) - ;; Test for t explicitly since misc methods return :eof sometimes. - (eq (funcall (stream-misc stream) stream :listen) t)))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (or (/= (the fixnum (lisp-stream-in-index stream)) in-buffer-length) + ;; Test for t explicitly since misc methods return :eof sometimes. + (eq (funcall (lisp-stream-misc stream) stream :listen) t))) + (fundamental-stream + (stream-listen stream))))) (defun read-char-no-hang (&optional (stream *standard-input*) (eof-errorp t) eof-value recursive-p) "Returns the next character from the Stream if one is availible, or nil." (declare (ignore recursive-p)) - (let ((stream (in-synonym-of stream))) - (if (funcall (stream-misc stream) stream :listen) - ;; On t or :eof get READ-CHAR to do the work. - (read-char stream eof-errorp eof-value) - nil))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (if (funcall (lisp-stream-misc stream) stream :listen) + ;; On t or :eof get READ-CHAR to do the work. + (read-char stream eof-errorp eof-value) + nil)) + (fundamental-stream + (let ((char (stream-read-char-no-hang stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char)))))) + (defun clear-input (&optional (stream *standard-input*)) "Clears any buffered input associated with the Stream." - (let ((stream (in-synonym-of stream))) - (setf (stream-in-index stream) in-buffer-length) - (funcall (stream-misc stream) stream :clear-input) - nil)) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (setf (lisp-stream-in-index stream) in-buffer-length) + (funcall (lisp-stream-misc stream) stream :clear-input)) + (fundamental-stream + (stream-clear-input stream)))) + nil) (defun read-byte (stream &optional (eof-errorp t) eof-value) "Returns the next byte of the Stream." - (prepare-for-fast-read-byte stream - (prog1 - (fast-read-byte eof-errorp eof-value t) - (done-with-fast-read-byte)))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (prepare-for-fast-read-byte stream + (prog1 + (fast-read-byte eof-errorp eof-value t) + (done-with-fast-read-byte)))) + (fundamental-stream + (let ((char (stream-read-byte stream))) + (if (eq char :eof) + (eof-or-lose stream eof-errorp eof-value) + char)))))) (defun read-n-bytes (stream buffer start numbytes &optional (eof-errorp t)) "Reads Numbytes bytes into the Buffer starting at Start, returning the number @@ -373,25 +441,26 @@ available (up to count bytes.) On pipes or similar devices, this function returns as soon as any adata is available, even if the amount read is less than Count and eof has not been hit." - (declare (type index numbytes start) + (declare (type lisp-stream stream) + (type index numbytes start) (type (or (simple-array * (*)) system-area-pointer) buffer)) - (let* ((stream (in-synonym-of stream)) - (in-buffer (stream-in-buffer stream)) - (index (stream-in-index stream)) + (let* ((stream (stream-synonym-of stream lisp-stream)) + (in-buffer (lisp-stream-in-buffer stream)) + (index (lisp-stream-in-index stream)) (num-buffered (- in-buffer-length index))) (declare (fixnum index num-buffered)) (cond ((not in-buffer) - (funcall (stream-n-bin stream) stream buffer start numbytes eof-errorp)) + (funcall (lisp-stream-n-bin stream) stream buffer start numbytes eof-errorp)) ((<= numbytes num-buffered) (%primitive byte-blt in-buffer index buffer start (+ start numbytes)) - (setf (stream-in-index stream) (+ index numbytes)) + (setf (lisp-stream-in-index stream) (+ index numbytes)) numbytes) (t (let ((end (+ start num-buffered))) (%primitive byte-blt in-buffer index buffer start end) - (setf (stream-in-index stream) in-buffer-length) - (+ (funcall (stream-n-bin stream) stream buffer end + (setf (lisp-stream-in-index stream) in-buffer-length) + (+ (funcall (lisp-stream-n-bin stream) stream buffer end (- numbytes num-buffered) eof-errorp) num-buffered)))))) @@ -409,16 +478,16 @@ ;;; myst be an n-bin method. ;;; (defun fast-read-char-refill (stream eof-errorp eof-value) - (let* ((ibuf (stream-in-buffer stream)) - (count (funcall (stream-n-bin stream) stream + (let* ((ibuf (lisp-stream-in-buffer stream)) + (count (funcall (lisp-stream-n-bin stream) stream ibuf in-buffer-extra (- in-buffer-length in-buffer-extra) nil)) (start (- in-buffer-length count))) (declare (type index start count)) (cond ((zerop count) - (setf (stream-in-index stream) in-buffer-length) - (funcall (stream-in stream) stream eof-errorp eof-value)) + (setf (lisp-stream-in-index stream) in-buffer-length) + (funcall (lisp-stream-in stream) stream eof-errorp eof-value)) (t (when (/= start in-buffer-extra) (bit-bash-copy ibuf (+ (* in-buffer-extra vm:byte-bits) @@ -426,7 +495,7 @@ ibuf (+ (the index (* start vm:byte-bits)) (* vm:vector-data-offset vm:word-bits)) (* count vm:byte-bits))) - (setf (stream-in-index stream) (1+ start)) + (setf (lisp-stream-in-index stream) (1+ start)) (code-char (aref ibuf start)))))) @@ -436,22 +505,22 @@ ;;; unreading. ;;; (defun fast-read-byte-refill (stream eof-errorp eof-value) - (let* ((ibuf (stream-in-buffer stream)) - (count (funcall (stream-n-bin stream) stream + (let* ((ibuf (lisp-stream-in-buffer stream)) + (count (funcall (lisp-stream-n-bin stream) stream ibuf 0 in-buffer-length nil)) (start (- in-buffer-length count))) (declare (type index start count)) (cond ((zerop count) - (setf (stream-in-index stream) in-buffer-length) - (funcall (stream-bin stream) stream eof-errorp eof-value)) + (setf (lisp-stream-in-index stream) in-buffer-length) + (funcall (lisp-stream-bin stream) stream eof-errorp eof-value)) (t (unless (zerop start) (bit-bash-copy ibuf (* vm:vector-data-offset vm:word-bits) ibuf (+ (the index (* start vm:byte-bits)) (* vm:vector-data-offset vm:word-bits)) (* count vm:byte-bits))) - (setf (stream-in-index stream) (1+ start)) + (setf (lisp-stream-in-index stream) (1+ start)) (aref ibuf start))))) @@ -459,21 +528,26 @@ (defun write-char (character &optional (stream *standard-output*)) "Outputs the Character to the Stream." - (with-out-stream stream stream-out character) + (with-stream stream (lisp-stream-out character) + (stream-write-char character)) character) (defun terpri (&optional (stream *standard-output*)) "Outputs a new line to the Stream." - (with-out-stream stream stream-out #\newline) + (with-stream stream (lisp-stream-out #\newline) (stream-terpri)) nil) (defun fresh-line (&optional (stream *standard-output*)) "Outputs a new line to the Stream if it is not positioned at the begining of a line. Returns T if it output a new line, nil otherwise." - (let ((stream (out-synonym-of stream))) - (when (/= (or (charpos stream) 1) 0) - (funcall (stream-out stream) stream #\newline) - t))) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (when (/= (or (charpos stream) 1) 0) + (funcall (lisp-stream-out stream) stream #\newline) + t)) + (fundamental-stream + (stream-fresh-line stream))))) (defun write-string (string &optional (stream *standard-output*) &key (start 0) (end (length (the vector string)))) @@ -483,11 +557,18 @@ (defun write-string* (string &optional (stream *standard-output*) (start 0) (end (length (the vector string)))) (declare (fixnum start end)) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) (offset-end end)) - (with-out-stream stream stream-sout data offset-start offset-end)) - (with-out-stream stream stream-sout string start end)) - string) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) + (offset-end end)) + (funcall (lisp-stream-sout stream) + stream data offset-start offset-end)) + (funcall (lisp-stream-sout stream) stream string start end)) + string) + (fundamental-stream + (stream-write-string stream string start end))))) (defun write-line (string &optional (stream *standard-output*) &key (start 0) (end (length string))) @@ -497,48 +578,55 @@ (defun write-line* (string &optional (stream *standard-output*) (start 0) (end (length string))) (declare (fixnum start end)) - (let ((stream (out-synonym-of stream))) - (if (array-header-p string) - (with-array-data ((data string) (offset-start start) (offset-end end)) - (with-out-stream stream stream-sout data offset-start offset-end)) - (with-out-stream stream stream-sout string start end)) - (funcall (stream-out stream) stream #\newline)) - string) + (let ((stream (stream-synonym-of stream))) + (etypecase stream + (lisp-stream + (if (array-header-p string) + (with-array-data ((data string) (offset-start start) + (offset-end end)) + (with-stream stream (lisp-stream-sout data offset-start + offset-end))) + (with-stream stream (lisp-stream-sout string start end))) + (funcall (lisp-stream-out stream) stream #\newline)) + (fundamental-stream + (stream-write-string stream string start end) + (stream-write-char stream #\Newline))) + string)) (defun charpos (&optional (stream *standard-output*)) "Returns the number of characters on the current line of output of the given Stream, or Nil if that information is not availible." - (with-out-stream stream stream-misc :charpos)) + (with-stream stream (lisp-stream-misc :charpos) (stream-line-column))) (defun line-length (&optional (stream *standard-output*)) "Returns the number of characters that will fit on a line of output on the given Stream, or Nil if that information is not available." - (with-out-stream stream stream-misc :line-length)) + (with-stream stream (lisp-stream-misc :line-length) (stream-line-length))) (defun finish-output (&optional (stream *standard-output*)) "Attempts to ensure that all output sent to the Stream has reached its destination, and only then returns." - (with-out-stream stream stream-misc :finish-output) + (with-stream stream (lisp-stream-misc :finish-output) (stream-finish-output)) nil) (defun force-output (&optional (stream *standard-output*)) "Attempts to force any buffered output to be sent." - (with-out-stream stream stream-misc :force-output) + (with-stream stream (lisp-stream-misc :force-output) (stream-force-output)) nil) (defun clear-output (&optional (stream *standard-output*)) "Clears the given output Stream." - (with-out-stream stream stream-misc :clear-output) + (with-stream stream (lisp-stream-misc :clear-output) (stream-force-output)) nil) (defun write-byte (integer stream) "Outputs the Integer to the binary Stream." - (with-out-stream stream stream-bout integer) + (with-stream stream (lisp-stream-bout integer) (stream-write-byte)) integer) ;;;; Broadcast streams: -(defstruct (broadcast-stream (:include stream +(defstruct (broadcast-stream (:include lisp-stream (out #'broadcast-out) (bout #'broadcast-bout) (sout #'broadcast-sout) @@ -559,37 +647,37 @@ `(defun ,fun (stream ,@args) (dolist (stream (broadcast-stream-streams stream)) (funcall (,method stream) stream ,@args))))) - (out-fun broadcast-out stream-out char) - (out-fun broadcast-bout stream-bout byte) - (out-fun broadcast-sout stream-sout string start end)) + (out-fun broadcast-out lisp-stream-out char) + (out-fun broadcast-bout lisp-stream-bout byte) + (out-fun broadcast-sout lisp-stream-sout string start end)) (defun broadcast-misc (stream operation &optional arg1 arg2) (let ((streams (broadcast-stream-streams stream))) (case operation (:charpos (dolist (stream streams) - (let ((charpos (funcall (stream-misc stream) stream :charpos))) + (let ((charpos (funcall (lisp-stream-misc stream) stream :charpos))) (if charpos (return charpos))))) (:line-length (let ((min nil)) (dolist (stream streams min) - (let ((res (funcall (stream-misc stream) stream :line-length))) + (let ((res (funcall (lisp-stream-misc stream) stream :line-length))) (when res (setq min (if min (min res min) res))))))) (:element-type (let (res) (dolist (stream streams (if (> (length res) 1) `(and ,@res) res)) - (pushnew (funcall (stream-misc stream) stream :element-type) res + (pushnew (funcall (lisp-stream-misc stream) stream :element-type) res :test #'equal)))) (:close) (t (let ((res nil)) (dolist (stream streams res) - (setq res (funcall (stream-misc stream) stream operation + (setq res (funcall (lisp-stream-misc stream) stream operation arg1 arg2)))))))) ;;;; Synonym Streams: -(defstruct (synonym-stream (:include stream +(defstruct (synonym-stream (:include lisp-stream (in #'synonym-in) (bin #'synonym-bin) (n-bin #'synonym-n-bin) @@ -618,9 +706,9 @@ (declare (optimize (safety 1))) (let ((syn (symbol-value (synonym-stream-symbol stream)))) (funcall (,slot syn) syn ,@args))))) - (out-fun synonym-out stream-out ch) - (out-fun synonym-bout stream-bout n) - (out-fun synonym-sout stream-sout string start end)) + (out-fun synonym-out lisp-stream-out ch) + (out-fun synonym-bout lisp-stream-bout n) + (out-fun synonym-sout lisp-stream-sout string start end)) ;;; Bind synonym stream to this so that SPIO can turn on the right frob in @@ -652,15 +740,15 @@ (let ((syn (symbol-value (synonym-stream-symbol stream))) (*previous-stream* stream)) (case operation - (:listen (or (/= (the fixnum (stream-in-index syn)) in-buffer-length) - (funcall (stream-misc syn) syn :listen))) + (:listen (or (/= (the fixnum (lisp-stream-in-index syn)) in-buffer-length) + (funcall (lisp-stream-misc syn) syn :listen))) (t - (funcall (stream-misc syn) syn operation arg1 arg2))))) + (funcall (lisp-stream-misc syn) syn operation arg1 arg2))))) ;;;; Two-Way streams: (defstruct (two-way-stream - (:include stream + (:include lisp-stream (in #'two-way-in) (bin #'two-way-bin) (n-bin #'two-way-n-bin) @@ -689,9 +777,9 @@ `(defun ,name (stream ,@args) (let ((syn (two-way-stream-output-stream stream))) (funcall (,slot syn) syn ,@args))))) - (out-fun two-way-out stream-out ch) - (out-fun two-way-bout stream-bout n) - (out-fun two-way-sout stream-sout string start end)) + (out-fun two-way-out lisp-stream-out ch) + (out-fun two-way-bout lisp-stream-bout n) + (out-fun two-way-sout lisp-stream-sout string start end)) (macrolet ((in-fun (name fun &rest args) `(defun ,name (stream ,@args) @@ -703,11 +791,11 @@ (defun two-way-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) - (in-method (stream-misc in)) + (in-method (lisp-stream-misc in)) (out (two-way-stream-output-stream stream)) - (out-method (stream-misc out))) + (out-method (lisp-stream-misc out))) (case operation - (:listen (or (/= (the fixnum (stream-in-index in)) in-buffer-length) + (:listen (or (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) (funcall in-method in :listen))) ((:finish-output :force-output :clear-output) (funcall out-method out operation arg1 arg2)) @@ -727,7 +815,7 @@ ;;;; Concatenated Streams: (defstruct (concatenated-stream - (:include stream + (:include lisp-stream (in #'concatenated-in) (bin #'concatenated-bin) (misc #'concatenated-misc)) @@ -765,7 +853,7 @@ (let ((left (concatenated-stream-current stream))) (when left (let* ((current (car left)) - (misc (stream-misc current))) + (misc (lisp-stream-misc current))) (case operation (:listen (loop @@ -778,7 +866,7 @@ (unless current ;; No further streams. EOF. (return :eof)) - (setf misc (stream-misc current))) + (setf misc (lisp-stream-misc current))) (stuff ;; Stuff's available. (return t)) @@ -811,17 +899,17 @@ (result (,fun in ,@args))) (funcall (,out-slot out) out result) result))))) - (in-fun echo-in read-char stream-out eof-errorp eof-value) - (in-fun echo-bin read-byte stream-bout eof-errorp eof-value)) + (in-fun echo-in read-char lisp-stream-out eof-errorp eof-value) + (in-fun echo-bin read-byte lisp-stream-bout eof-errorp eof-value)) (defun echo-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) - (in-method (stream-misc in)) + (in-method (lisp-stream-misc in)) (out (two-way-stream-output-stream stream)) - (out-method (stream-misc out))) + (out-method (lisp-stream-misc out))) (case operation (:listen (or (not (null (echo-stream-unread-stuff stream))) - (/= (the fixnum (stream-in-index in)) in-buffer-length) + (/= (the fixnum (lisp-stream-in-index in)) in-buffer-length) (funcall in-method in :listen))) (:unread (push arg1 (echo-stream-unread-stuff stream))) (:element-type @@ -849,7 +937,7 @@ ;;;; String Input Streams: (defstruct (string-input-stream - (:include stream + (:include lisp-stream (in #'string-inch) (bin #'string-binch) (n-bin #'string-stream-read-n-bytes) @@ -934,7 +1022,7 @@ ;;;; String Output Streams: (defstruct (string-output-stream - (:include stream + (:include lisp-stream (out #'string-ouch) (sout #'string-sout) (misc #'string-out-misc)) @@ -1016,8 +1104,8 @@ (defun dump-output-stream-string (in-stream out-stream) "Dumps the characters buffer up in the In-Stream to the Out-Stream as Get-Output-Stream-String would return them." - (write-string (string-output-stream-string in-stream) out-stream - :start 0 :end (string-output-stream-index in-stream)) + (write-string* (string-output-stream-string in-stream) out-stream + 0 (string-output-stream-index in-stream)) (setf (string-output-stream-index in-stream) 0)) ;;;; Fill-pointer streams: @@ -1026,7 +1114,7 @@ ;;; the CLM, but they are required for the implementation of With-Output-To-String. (defstruct (fill-pointer-output-stream - (:include stream + (:include lisp-stream (out #'fill-pointer-ouch) (sout #'fill-pointer-sout) (misc #'fill-pointer-misc)) @@ -1107,7 +1195,7 @@ ;;;; Indenting streams: -(defstruct (indenting-stream (:include stream +(defstruct (indenting-stream (:include lisp-stream (out #'indenting-out) (sout #'indenting-sout) (misc #'indenting-misc)) @@ -1132,15 +1220,15 @@ `(do ((i 0 (+ i 60)) (indentation (indenting-stream-indentation ,stream))) ((>= i indentation)) - (funcall (stream-sout ,sub-stream) ,sub-stream - " " - 0 (min 60 (- indentation i))))) + (write-string* + " " + ,sub-stream 0 (min 60 (- indentation i))))) ;;; Indenting-Out writes a character to an indenting stream. (defun indenting-out (stream char) (let ((sub-stream (indenting-stream-stream stream))) - (funcall (stream-out sub-stream) sub-stream char) + (write-char char sub-stream) (if (char= char #\newline) (indenting-indent stream sub-stream)))) @@ -1153,11 +1241,11 @@ ((= i end)) (let ((newline (position #\newline string :start i :end end))) (cond (newline - (funcall (stream-sout sub-stream) sub-stream string i (1+ newline)) + (write-string* string sub-stream i (1+ newline)) (indenting-indent stream sub-stream) (setq i (+ newline 1))) (t - (funcall (stream-sout sub-stream) sub-stream string i end) + (write-string* string sub-stream i end) (setq i end)))))) ;;; Indenting-Misc just treats just the :Line-Length message differently. @@ -1165,20 +1253,36 @@ ;;; the stream's indentation. (defun indenting-misc (stream operation &optional arg1 arg2) - (let* ((sub-stream (indenting-stream-stream stream)) - (method (stream-misc sub-stream))) - (case operation - (:line-length - (let ((line-length (funcall method sub-stream operation))) - (if line-length - (- line-length (indenting-stream-indentation stream))))) - (:charpos - (let* ((sub-stream (indenting-stream-stream stream)) - (charpos (funcall method sub-stream operation))) - (if charpos - (- charpos (indenting-stream-indentation stream))))) - (t - (funcall method sub-stream operation arg1 arg2))))) + (let ((sub-stream (indenting-stream-stream stream))) + (etypecase sub-stream + (lisp-stream + (let ((method (lisp-stream-misc sub-stream))) + (case operation + (:line-length + (let ((line-length (funcall method sub-stream operation))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let ((charpos (funcall method sub-stream operation))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + (funcall method sub-stream operation arg1 arg2))))) + (fundamental-stream + (case operation + (:line-length + (let ((line-length (stream-line-length sub-stream))) + (if line-length + (- line-length (indenting-stream-indentation stream))))) + (:charpos + (let ((charpos (stream-line-column sub-stream))) + (if charpos + (- charpos (indenting-stream-indentation stream))))) + (t + ;; XX TODO + (format t "* Warning: ignoring ~s ~s ~s on ~s~%" + operation arg1 arg2 sub-stream))))))) + (proclaim '(maybe-inline read-char unread-char read-byte listen)) @@ -1187,7 +1291,7 @@ ;;;; Case frobbing streams, used by format ~(...~). (defstruct (case-frob-stream - (:include stream + (:include lisp-stream (:misc #'case-frob-misc)) (:constructor %make-case-frob-stream (target out sout))) (target (required-argument) :type stream)) @@ -1233,14 +1337,14 @@ (:close) (t (let ((target (case-frob-stream-target stream))) - (funcall (stream-misc target) target op arg1 arg2))))) + (funcall (lisp-stream-misc target) target op arg1 arg2))))) (defun case-frob-upcase-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) - (funcall (stream-out target) target (char-upcase char)))) + (funcall (lisp-stream-out target) target (char-upcase char)))) (defun case-frob-upcase-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1250,7 +1354,7 @@ (let* ((target (case-frob-stream-target stream)) (len (length str)) (end (or end len))) - (funcall (stream-sout target) target + (funcall (lisp-stream-sout target) target (if (and (zerop start) (= len end)) (string-upcase str) (nstring-upcase (subseq str start end))) @@ -1261,7 +1365,7 @@ (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) - (funcall (stream-out target) target (char-downcase char)))) + (funcall (lisp-stream-out target) target (char-downcase char)))) (defun case-frob-downcase-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1271,7 +1375,7 @@ (let* ((target (case-frob-stream-target stream)) (len (length str)) (end (or end len))) - (funcall (stream-sout target) target + (funcall (lisp-stream-sout target) target (if (and (zerop start) (= len end)) (string-downcase str) (nstring-downcase (subseq str start end))) @@ -1283,13 +1387,13 @@ (type base-char char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (funcall (stream-out target) target (char-upcase char)) + (funcall (lisp-stream-out target) target (char-upcase char)) (setf (case-frob-stream-out stream) #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-aux-sout)) (t - (funcall (stream-out target) target char))))) + (funcall (lisp-stream-out target) target char))))) (defun case-frob-capitalize-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1314,16 +1418,16 @@ #'case-frob-capitalize-aux-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-aux-sout)) - (funcall (stream-sout target) target str 0 len))) + (funcall (lisp-stream-sout target) target str 0 len))) (defun case-frob-capitalize-aux-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (funcall (stream-out target) target (char-downcase char))) + (funcall (lisp-stream-out target) target (char-downcase char))) (t - (funcall (stream-out target) target char) + (funcall (lisp-stream-out target) target char) (setf (case-frob-stream-out stream) #'case-frob-capitalize-out) (setf (case-frob-stream-sout stream) @@ -1352,20 +1456,20 @@ #'case-frob-capitalize-out) (setf (case-frob-stream-sout stream) #'case-frob-capitalize-sout)) - (funcall (stream-sout target) target str 0 len))) + (funcall (lisp-stream-sout target) target str 0 len))) (defun case-frob-capitalize-first-out (stream char) (declare (type case-frob-stream stream) (type base-char char)) (let ((target (case-frob-stream-target stream))) (cond ((alphanumericp char) - (funcall (stream-out target) target (char-upcase char)) + (funcall (lisp-stream-out target) target (char-upcase char)) (setf (case-frob-stream-out stream) #'case-frob-downcase-out) (setf (case-frob-stream-sout stream) #'case-frob-downcase-sout)) (t - (funcall (stream-out target) target char))))) + (funcall (lisp-stream-out target) target char))))) (defun case-frob-capitalize-first-sout (stream str start end) (declare (type case-frob-stream stream) @@ -1387,7 +1491,7 @@ (setf (case-frob-stream-sout stream) #'case-frob-downcase-sout) (return)))) - (funcall (stream-sout target) target str 0 len))) + (funcall (lisp-stream-sout target) target str 0 len))) ;;;; Public interface from "EXTENSIONS" package. @@ -1416,7 +1520,7 @@ "This takes a stream and waits for text or a command to appear on it. If text appears before a command, this returns nil, and otherwise it returns a command." - (let ((cmdp (funcall (lisp::stream-misc stream) stream :get-command))) + (let ((cmdp (funcall (lisp-stream-misc stream) stream :get-command))) (cond (cmdp) ((listen stream) nil) @@ -1504,7 +1608,7 @@ (type index i)) (funcall write-function (first rem) stream)))) (string - (write-string seq stream :start start :end end)) + (write-string* seq stream start end)) (vector (let ((write-function (if (subtypep (stream-element-type stream) 'character) diff --git a/code/struct.lisp b/code/struct.lisp index 4d09a42eb..16ebb5926 100644 --- a/code/struct.lisp +++ b/code/struct.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/struct.lisp,v 1.19 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/struct.lisp,v 1.20 1998/05/04 01:27:16 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -20,13 +20,13 @@ (deftype in-buffer-type () `(simple-array (unsigned-byte 8) (,in-buffer-length))) -;;; Change the kind of stream to :instance so that the defstruct doesn't flame -;;; out. +;;; Change the kind of lisp-stream to :instance so that the defstruct +;;; doesn't flame out. ;;; (eval-when (compile eval) - (setf (info type kind 'stream) :instance)) + (setf (info type kind 'lisp-stream) :instance)) -(defstruct (stream (:predicate streamp) (:print-function %print-stream)) +(defstruct (lisp-stream (:print-function %print-stream)) ;; ;; Buffered input. (in-buffer nil :type (or in-buffer-type null)) @@ -39,6 +39,9 @@ (sout #'ill-out :type function) ; String output function (misc #'do-nothing :type function)) ; Less used methods +(declaim (inline streamp)) +(defun streamp (stream) + (typep stream 'stream)) ;;; Alien value structures: diff --git a/code/sysmacs.lisp b/code/sysmacs.lisp index e20cecb77..668f46496 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.17 1994/10/31 04:11:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/sysmacs.lisp,v 1.18 1998/05/04 01:27:17 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -88,35 +88,30 @@ (error 'end-of-file :stream ,stream) ,eof-value)) -;;; These macros handle the special cases of t and nil for input and +;;; This macros handle the special cases of t and nil for input and ;;; output streams. ;;; -(defmacro in-synonym-of (stream) - (let ((svar (gensym))) - `(let ((,svar ,stream)) - (cond ((null ,svar) *standard-input*) - ((eq ,svar t) *terminal-io*) - (t (check-type ,svar stream) - ,svar))))) - -(defmacro out-synonym-of (stream) +(defmacro stream-synonym-of (stream &optional check-type) (let ((svar (gensym))) `(let ((,svar ,stream)) (cond ((null ,svar) *standard-output*) ((eq ,svar t) *terminal-io*) - (T (check-type ,svar stream) + (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. -;;; -(defmacro with-in-stream (stream slot &rest args) - `(let ((stream (in-synonym-of ,stream))) - (funcall (,slot stream) stream ,@args))) - -(defmacro with-out-stream (stream slot &rest args) - `(let ((stream (out-synonym-of ,stream))) - (funcall (,slot stream) stream ,@args))) +;;; the Args for lisp-streams or the pcl-fn for fundamental-streams. +;;; +(defmacro with-stream (stream lisp-dispatch &optional pcl-dispatch) + `(let ((stream (stream-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)))))))) ;;;; These are hacks to make the reader win. @@ -127,20 +122,21 @@ ;;; macro within the enclosed lexical scope. ;;; (defmacro prepare-for-fast-read-char (stream &body forms) - `(let* ((%frc-stream% (in-synonym-of ,stream)) - (%frc-method% (stream-in %frc-stream%)) - (%frc-buffer% (stream-in-buffer %frc-stream%)) - (%frc-index% (stream-in-index %frc-stream%))) - (declare (type index %frc-index%)) + `(let* ((%frc-stream% (stream-synonym-of ,stream lisp-stream)) + (%frc-method% (lisp-stream-in %frc-stream%)) + (%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) + (%frc-index% (lisp-stream-in-index %frc-stream%))) + (declare (type index %frc-index%) + (type lisp-stream %frc-stream%)) ,@forms)) ;;; Done-With-Fast-Read-Char -- Internal ;;; ;;; This macro must be called after one is done with fast-read-char -;;; inside it's scope to decache the stream-in-index. +;;; inside it's scope to decache the lisp-stream-in-index. ;;; (defmacro done-with-fast-read-char () - `(setf (stream-in-index %frc-stream%) %frc-index%)) + `(setf (lisp-stream-in-index %frc-stream%) %frc-index%)) ;;; Fast-Read-Char -- Internal ;;; @@ -153,7 +149,7 @@ (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)) ((= %frc-index% in-buffer-length) (prog1 (fast-read-char-refill %frc-stream% ,eof-errorp ,eof-value) - (setq %frc-index% (stream-in-index %frc-stream%)))) + (setq %frc-index% (lisp-stream-in-index %frc-stream%)))) (t (prog1 (code-char (aref %frc-buffer% %frc-index%)) (incf %frc-index%))))) @@ -166,11 +162,12 @@ ;;; method. ;;; (defmacro prepare-for-fast-read-byte (stream &body forms) - `(let* ((%frc-stream% (in-synonym-of ,stream)) - (%frc-method% (stream-bin %frc-stream%)) - (%frc-buffer% (stream-in-buffer %frc-stream%)) - (%frc-index% (stream-in-index %frc-stream%))) - (declare (type index %frc-index%)) + `(let* ((%frc-stream% (stream-synonym-of ,stream lisp-stream)) + (%frc-method% (lisp-stream-bin %frc-stream%)) + (%frc-buffer% (lisp-stream-in-buffer %frc-stream%)) + (%frc-index% (lisp-stream-in-index %frc-stream%))) + (declare (type index %frc-index%) + (type lisp-stream %frc-stream%)) ,@forms)) ;;; Fast-Read-Byte, Done-With-Fast-Read-Byte -- Internal @@ -187,7 +184,7 @@ (funcall %frc-method% %frc-stream% ,eof-errorp ,eof-value)) ((= %frc-index% in-buffer-length) (prog1 (fast-read-byte-refill %frc-stream% ,eof-errorp ,eof-value) - (setq %frc-index% (stream-in-index %frc-stream%)))) + (setq %frc-index% (lisp-stream-in-index %frc-stream%)))) (t (prog1 (aref %frc-buffer% %frc-index%) (incf %frc-index%)))))) diff --git a/compiler/generic/core.lisp b/compiler/generic/core.lisp index 397f564eb..2a21a483d 100644 --- a/compiler/generic/core.lisp +++ b/compiler/generic/core.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/compiler/generic/core.lisp,v 1.37 1997/11/11 18:51:58 dtc Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/core.lisp,v 1.38 1998/05/04 01:27:17 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -312,7 +312,7 @@ (defstruct (code-instruction-stream (:print-function %print-code-inst-stream) - (:include stream + (:include lisp-stream (lisp::sout #'code-inst-stream-sout) (lisp::bout #'code-inst-stream-bout) (lisp::misc #'code-inst-stream-misc)) diff --git a/hemlock/bit-stream.lisp b/hemlock/bit-stream.lisp index 68cb27d63..218c5eca9 100644 --- a/hemlock/bit-stream.lisp +++ b/hemlock/bit-stream.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/hemlock/bit-stream.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bit-stream.lisp,v 1.4 1998/05/04 01:27:18 dtc Rel $") ;;; ;;; ********************************************************************** ;;; @@ -26,7 +26,7 @@ ;;; does not invoke the exposed/changed handler in Bit-Screen.Lisp; also, the ;;; hunk's input and changed handler slots are not set. ;;; -(defstruct (bitmap-hunk-output-stream (:include stream +(defstruct (bitmap-hunk-output-stream (:include sys:lisp-stream (out #'bitmap-hunk-out) (sout #'bitmap-hunk-sout) (misc #'bitmap-hunk-misc)) diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp index bc863514b..5deb24db3 100644 --- a/hemlock/eval-server.lisp +++ b/hemlock/eval-server.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/hemlock/eval-server.lisp,v 1.6 1997/01/18 14:31:52 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.7 1998/05/04 01:27:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -781,7 +781,7 @@ (defvar *eval-form-stream* (make-two-way-stream - (lisp::make-stream + (lisp::make-lisp-stream :in #'(lambda (&rest junk) (declare (ignore junk)) (error "You cannot read when handling an eval_form request."))) diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp index 99601ba97..108051d8c 100644 --- a/hemlock/rompsite.lisp +++ b/hemlock/rompsite.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/hemlock/rompsite.lisp,v 1.10 1997/08/24 16:54:09 pw Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rompsite.lisp,v 1.11 1998/05/04 01:27:19 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -459,7 +459,7 @@ stream)) (defvar *illegal-read-stream* - (lisp::make-stream :in #'in-hemlock-standard-input-read)) + (lisp::make-lisp-stream :in #'in-hemlock-standard-input-read)) (defmacro site-wrapper-macro (&body body) `(unwind-protect diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp index 2cb1f89f5..6d97d3479 100644 --- a/hemlock/shell.lisp +++ b/hemlock/shell.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/hemlock/shell.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/shell.lisp,v 1.5 1998/05/04 01:27:20 dtc Rel $") ;;; ;;; ********************************************************************** ;;; @@ -63,7 +63,7 @@ ;;; (defstruct (shell-filter-stream - (:include stream + (:include sys:lisp-stream (:out #'shell-filter-out) (:sout #'shell-filter-string-out) (:misc #'shell-filter-output-misc)) diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp index 878811f67..9e517e87b 100644 --- a/hemlock/streams.lisp +++ b/hemlock/streams.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/hemlock/streams.lisp,v 1.4 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/streams.lisp,v 1.5 1998/05/04 01:27:20 dtc Rel $") ;;; ;;; ********************************************************************** ;;; @@ -26,7 +26,7 @@ modify-kbdmac-stream)) (defstruct (hemlock-output-stream - (:include stream + (:include sys:lisp-stream (:misc #'hemlock-output-misc)) (:print-function %print-hemlock-output-stream) (:constructor internal-make-hemlock-output-stream ())) @@ -56,14 +56,14 @@ (setf (hemlock-output-stream-mark stream) mark) (case buffered (:none - (setf (lisp::stream-out stream) #'hemlock-output-unbuffered-out - (lisp::stream-sout stream) #'hemlock-output-unbuffered-sout)) + (setf (lisp::lisp-stream-out stream) #'hemlock-output-unbuffered-out + (lisp::lisp-stream-sout stream) #'hemlock-output-unbuffered-sout)) (:line - (setf (lisp::stream-out stream) #'hemlock-output-line-buffered-out - (lisp::stream-sout stream) #'hemlock-output-line-buffered-sout)) + (setf (lisp::lisp-stream-out stream) #'hemlock-output-line-buffered-out + (lisp::lisp-stream-sout stream) #'hemlock-output-line-buffered-sout)) (:full - (setf (lisp::stream-out stream) #'hemlock-output-buffered-out - (lisp::stream-sout stream) #'hemlock-output-buffered-sout)) + (setf (lisp::lisp-stream-out stream) #'hemlock-output-buffered-out + (lisp::lisp-stream-sout stream) #'hemlock-output-buffered-sout)) (t (error "~S is a losing value for Buffered." buffered))) stream) @@ -128,7 +128,7 @@ (:element-type 'base-char))) (defstruct (hemlock-region-stream - (:include stream + (:include sys:lisp-stream (:in #'region-in) (:misc #'region-misc)) (:print-function %print-region-stream) diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp index 115c2a5f1..a19b340e0 100644 --- a/hemlock/struct.lisp +++ b/hemlock/struct.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/hemlock/struct.lisp,v 1.5 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/struct.lisp,v 1.6 1998/05/04 01:27:20 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -326,7 +326,7 @@ ;;; These streams write to random typeout buffers for WITH-POP-UP-DISPLAY. ;;; -(defstruct (random-typeout-stream (:include stream) +(defstruct (random-typeout-stream (:include sys:lisp-stream) (:print-function print-random-typeout-stream) (:constructor make-random-typeout-stream (mark))) diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp index b61905da5..520b5ace4 100644 --- a/hemlock/ts-stream.lisp +++ b/hemlock/ts-stream.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/hemlock/ts-stream.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ts-stream.lisp,v 1.4 1998/05/04 01:27:21 dtc Rel $") ;;; ;;; ********************************************************************** ;;; @@ -23,7 +23,7 @@ (defconstant ts-stream-output-buffer-size 512) (defstruct (ts-stream - (:include stream + (:include sys:lisp-stream (in #'%ts-stream-in) (out #'%ts-stream-out) (sout #'%ts-stream-sout) diff --git a/hemlock/tty-stream.lisp b/hemlock/tty-stream.lisp index 567bad950..ced3d6312 100644 --- a/hemlock/tty-stream.lisp +++ b/hemlock/tty-stream.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/hemlock/tty-stream.lisp,v 1.3 1994/10/31 04:50:12 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-stream.lisp,v 1.4 1998/05/04 01:27:21 dtc Rel $") ;;; ;;; ********************************************************************** ;;; @@ -38,7 +38,7 @@ (point-y 0 :type fixnum) (buffer "" :type simple-string)) -(defstruct (tty-hunk-output-stream (:include stream +(defstruct (tty-hunk-output-stream (:include sys:lisp-stream (out #'hunk-out) (sout #'hunk-sout) (misc #'hunk-misc)) diff --git a/pcl/braid.lisp b/pcl/braid.lisp index ff73a7ec6..1b0df186d 100644 --- a/pcl/braid.lisp +++ b/pcl/braid.lisp @@ -626,6 +626,10 @@ (list (lisp:class-name (first (kernel:class-direct-superclasses (lisp:find-class symbol)))))) + ;; Hack to add the stream class as a + ;; mixin to the lisp-stream class. + ((eq symbol 'sys:lisp-stream) + '(structure-object stream)) ((structure-type-included-type-name symbol) (list (structure-type-included-type-name symbol)))) :direct-slots diff --git a/pcl/cache.lisp b/pcl/cache.lisp index 427069ea1..2f81d6fd9 100644 --- a/pcl/cache.lisp +++ b/pcl/cache.lisp @@ -543,6 +543,13 @@ :class (kernel:make-standard-class :name name :pcl-class class))))))) +;;; The following variable may be set to a standard-class that has +;;; already been created by the lisp code and which is to be redefined +;;; by PCL. This allows standard-classes to be defined and used for +;;; type testing and dispatch before PCL is loaded. +#+cmu17 +(defvar *pcl-class-boot* nil) + #+cmu17 ;;; MAKE-WRAPPER -- Interface ;;; @@ -563,7 +570,15 @@ (kernel:layout-class owrap)) ((*subtypep (class-of class) *the-class-standard-class*) - (kernel:make-standard-class :pcl-class class)) + (cond ((and *pcl-class-boot* + (eq (slot-value class 'name) *pcl-class-boot*)) + (let ((found (lisp:find-class (slot-value class 'name)))) + (unless (kernel:class-pcl-class found) + (setf (kernel:class-pcl-class found) class)) + (assert (eq (kernel:class-pcl-class found) class)) + found)) + (t + (kernel:make-standard-class :pcl-class class)))) (t (kernel:make-random-pcl-class :pcl-class class))))))) (t diff --git a/pcl/defs.lisp b/pcl/defs.lisp index fdb8d486e..976b9c18a 100644 --- a/pcl/defs.lisp +++ b/pcl/defs.lisp @@ -182,6 +182,7 @@ *the-class-integer* *the-class-float* *the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector* *the-class-array* + *the-class-stream* *the-class-slot-object* *the-class-standard-object* @@ -592,7 +593,7 @@ (let* ((name (car bic)) (class (lisp:find-class name))) (unless (member name '(t kernel:instance kernel:funcallable-instance - function)) + function stream)) (res `(,name ,(mapcar #'lisp:class-name (direct-supers class)) ,(mapcar #'lisp:class-name (direct-subs class)) @@ -621,6 +622,9 @@ (:metaclass built-in-class)) (defclass kernel:funcallable-instance (function) () + (:metaclass built-in-class)) + + (defclass stream (t) () (:metaclass built-in-class))) (defclass slot-object (#-cmu17 t #+cmu17 kernel:instance) () diff --git a/pcl/std-class.lisp b/pcl/std-class.lisp index aa30049e2..6d24437ff 100644 --- a/pcl/std-class.lisp +++ b/pcl/std-class.lisp @@ -1292,7 +1292,7 @@ (defmethod class-default-initargs ((class built-in-class)) ()) (defmethod validate-superclass ((c class) (s built-in-class)) - (eq s *the-class-t*)) + (or (eq s *the-class-t*) #+cmu (eq s *the-class-stream*))) -- GitLab