edited by Teitelman April 20, 1983 2:52 pm
DIRECTORY
Atom USING [PropList, GetPropFromList, PutPropOnList],
IO USING [DeliverWhenProc, GetChar, PutChar, EndOf, CharsAvail, Flush, Close, GetIndex, SetIndex, UnsafeGetBlock, UnsafePutBlock, SetEcho, Reset, SignalCode, ErrorCode, ROPE, STREAM, StreamProcs, STREAMRecord, StreamProperty, StreamPropertyRecord, UnsafeBlock, CR, NUL],
IOExtras USING [],
List USING [DotCons, Nconc1],
Process USING [Pause, MsecToTicks],
SafeStorage USING [NewZone]
;
IOImpl: CEDAR PROGRAM
IMPORTS IO, SafeStorage, Atom, List, Process
EXPORTS IO, IOExtras
SHARES IO =
BEGIN OPEN IO;
Zone: PUBLIC ZONE ← SafeStorage.NewZone[];
errors and signals
Signal: PUBLIC SIGNAL [ec: SignalCode, stream: STREAM] = CODE;
Error: PUBLIC ERROR [ec: ErrorCode, stream: STREAM] = CODE;
UserAborted: PUBLIC ERROR [abortee: REF ANY ← NIL, msg: ROPE ← NIL] = CODE;
EndOfStream: PUBLIC ERROR [stream: STREAM] = CODE;
creating streams
CreateProcsStream: PUBLIC PROCEDURE[streamProcs: REF StreamProcs, streamData: REF ANY, backingStream: STREAM ← NIL] RETURNS[handle: STREAM] = {
RETURN[Zone.NEW[STREAMRecord ← [streamProcs: streamProcs, streamData: streamData, backingStream: backingStream] ]];
}; -- of CreateStreamFromProcs
AmbushProcsStream: PUBLIC PROCEDURE[self: STREAM, streamProcs: REF StreamProcs, streamData: REF ANY, reusing: STREAM ← NIL] = {
IF reusing = NIL OR reusing = self -- to prevent circularities due to bugs -- THEN reusing ← Zone.NEW[STREAMRecord ← [streamProcs: NIL, streamData: NIL]];
reusing^ ← self^;
self^ ← [streamProcs: streamProcs, streamData: streamData, propList: reusing.propList, backingStream: reusing];
}; -- of AmbushProcsStream
UnAmbushProcsStream: PUBLIC PROCEDURE[self: STREAM] = {
propList: Atom.PropList = self.propList;
IF self.backingStream = NIL THEN RETURN;
self^ ← self.backingStream^;
self.propList ← propList; -- if any new properties added on while stream ambushed, they should be retained.
}; -- of UnAmbushProcsStream
CreateRefStreamProcs: PUBLIC PROC[
getChar: PROC[self: STREAM] RETURNS[CHARACTER] ← NIL,
endOf: PROC[self: STREAM] RETURNS[BOOLEAN] ← NIL,
charsAvail: PROC[self: STREAM] RETURNS[BOOLEAN] ← NIL,
getBlock: PROC[self: STREAM, block: REF TEXT, startIndex: NAT, stopIndexPlusOne: NAT] RETURNS[nBytesRead: NAT] ← NIL,
unsafeGetBlock: UNSAFE PROC[self: STREAM, block: UnsafeBlock] RETURNS[nBytesRead: INT] ← NIL,
putChar: PROC[self: STREAM, char: CHARACTER] ← NIL,
putBlock: PROC[self: STREAM, block: REF READONLY TEXT, startIndex: NAT, stopIndexPlusOne: NAT] ← NIL,
unsafePutBlock: PROC[self: STREAM, block: UnsafeBlock] ← NIL,
flush: PROC[self: STREAM] ← NIL,
reset: PROC[self: STREAM] ← NIL,
close: PROC[self: STREAM, abort: BOOLEAN ← FALSE] ← NIL,
getIndex: PROC[self: STREAM] RETURNS [INT] ← NIL,
setIndex: PROC[self: STREAM, index: INT] ← NIL,
getLength: PROC[self: STREAM] RETURNS [length: INT] ← NIL,
setLength: PROC[self: STREAM, length: INT] ← NIL,
backup: PROC[self: STREAM, char: CHARACTER] ← NIL,
userAbort: PROC[self: STREAM] RETURNS[abort: BOOLEAN] ← NIL,
setUserAbort: PROC[self: STREAM] ← NIL,
resetUserAbort: PROC[self: STREAM] ← NIL,
setEcho: PROC[self: STREAM, echoTo: STREAM] RETURNS [oldEcho: STREAM] ← NIL,
eraseChar: PROC[self: STREAM, char: CHARACTER] ← NIL,
currentPosition: PROC[self: STREAM] RETURNS[position: INT] ← NIL,
name: ROPE ← NIL
]
RETURNS [REF StreamProcs] = {
AddProc: SAFE PROC [operation, via: PROC ANY RETURNS ANY, procRef: REF ANY, key: ATOM] = {
streamProcs.otherStreamProcs ← Zone.CONS[Zone.NEW[StreamPropertyRecord ← [operation: operation, via: via, proc: procRef, key: key]], streamProcs.otherStreamProcs]
};
streamProcs: REF StreamProcs ← Zone.NEW[StreamProcs ← [
getChar: IF getChar = NIL THEN DefaultGetChar ELSE getChar,
endOf: IF endOf = NIL THEN DefaultEndOf ELSE endOf,
charsAvail: IF charsAvail = NIL THEN DefaultCharsAvail ELSE charsAvail,
getBlock: IF getBlock = NIL THEN DefaultGetBlock ELSE getBlock,
unsafeGetBlock: IF unsafeGetBlock = NIL THEN DefaultUnsafeGetBlock ELSE unsafeGetBlock,
putChar: IF putChar = NIL THEN DefaultPutChar ELSE putChar,
putBlock: IF putBlock = NIL THEN DefaultPutBlock ELSE putBlock,
unsafePutBlock: IF unsafePutBlock = NIL THEN DefaultUnsafePutBlock ELSE unsafePutBlock,
flush: IF flush = NIL THEN DefaultFlush ELSE flush,
reset: IF reset = NIL THEN DefaultReset ELSE reset,
close: IF close = NIL THEN DefaultClose ELSE close,
getIndex: IF getIndex = NIL THEN DefaultGetIndex ELSE getIndex,
setIndex: IF setIndex = NIL THEN DefaultSetIndex ELSE setIndex,
name: IF name = NIL THEN "Anonymous" ELSE name
]] ;
IF getLength # NIL THEN AddProc[operation: GetLength, via: getLength, procRef: Zone.NEW[TypeOfGetLength ← getLength], key: $GetLength];
IF setLength # NIL THEN AddProc[operation: SetLength, via: setLength, procRef: Zone.NEW[TypeOfSetLength ← setLength], key: $SetLength];
IF backup # NIL THEN AddProc[operation: Backup, via: backup, procRef: Zone.NEW[TypeOfBackup ← backup], key: $Backup];
IF userAbort # NIL THEN AddProc[operation: UserAbort, via: userAbort, procRef: Zone.NEW[TypeOfUserAbort ← userAbort], key: $UserAbort];
IF setUserAbort # NIL THEN AddProc[operation: SetUserAbort, via: setUserAbort, procRef: Zone.NEW[TypeOfSetUserAbort ← setUserAbort], key: $SetUserAbort];
IF resetUserAbort # NIL THEN AddProc[operation: ResetUserAbort, via: resetUserAbort, procRef: Zone.NEW[TypeOfResetUserAbort ← resetUserAbort], key: $ResetUserAbort];
IF setEcho # NIL THEN AddProc[operation: SetEcho, via: setEcho, procRef: Zone.NEW[TypeOfSetEcho ← setEcho], key: $SetEcho];
IF eraseChar # NIL THEN AddProc[operation: EraseChar, via: eraseChar, procRef: Zone.NEW[TypeOfEraseChar ← eraseChar], key: $EraseChar];
IF currentPosition # NIL THEN AddProc[operation: CurrentPosition, via: currentPosition, procRef: Zone.NEW[TypeOfCurrentPosition ← currentPosition], key: $CurrentPosition];
RETURN[streamProcs];
}; -- of CreateRefStreamProcs
TypeOfBackup, TypeOfEraseChar: TYPE = PROC[self: STREAM, char: CHARACTER];
TypeOfSetEcho: TYPE = PROCEDURE[self: STREAM, echoTo: STREAM] RETURNS[oldEcho: STREAM];
TypeOfGetLength: TYPE = PROC[self: STREAM] RETURNS[length: INT];
TypeOfSetLength: TYPE = PROC[self: STREAM, length: INT];
TypeOfCurrentPosition: TYPE = PROC [self: STREAM] RETURNS[position: INT];
TypeOfUserAbort: TYPE = PROC [self: STREAM] RETURNS[abort: BOOL];
TypeOfSetUserAbort, TypeOfResetUserAbort, TypeOfWaitUntilCharsAvail: TYPE = PROC[self: STREAM];
TypeOfChangeDeliverWhen: TYPE = PROC [self: STREAM, proc: DeliverWhenProc] RETURNS[oldProc: DeliverWhenProc];
TypeOfGetBufferContents: TYPE = PROC [self: STREAM] RETURNS[buffer: ROPE];
Default Procedures
DefaultGetChar: PROC [self: STREAM] RETURNS[CHARACTER] = {
IF self.backingStream # NIL THEN RETURN[GetChar[self.backingStream]]
ELSE ERROR Error[NotImplementedForThisStream, self];
};
DefaultPutChar: PROC[self: STREAM, char: CHARACTER] = {
IF self.backingStream # NIL THEN PutChar[self.backingStream, char]
ELSE SIGNAL Signal[NotImplementedForThisStream, self];
};
DefaultEndOf: PROC [self: STREAM] RETURNS[BOOLEAN] = {
IF self.backingStream # NIL THEN RETURN[EndOf[self.backingStream]]
ELSE ERROR Error[NotImplementedForThisStream, self];
};
DefaultCharsAvail: PROC [self: STREAM] RETURNS[BOOLEAN] = {
IF self.streamProcs.endOf # DefaultEndOf THEN RETURN[~self.streamProcs.endOf[self]]
ELSE IF self.backingStream # NIL THEN RETURN[CharsAvail[self.backingStream]]
ELSE ERROR Error[NotImplementedForThisStream, self];
};
DefaultReset: PROC[self: STREAM] = {
IF self.backingStream # NIL THEN Reset[self.backingStream];
};
DefaultClose: PROC [self: STREAM, abort: BOOLEAN ← FALSE] = {
IF abort THEN Reset[self] ELSE Flush[self];
IF self.backingStream # NIL THEN Close[self.backingStream, abort];
};
DefaultFlush: PROC[self: STREAM] = {
IF self.backingStream # NIL THEN Flush[self.backingStream];
};
DefaultGetIndex: PROC[self: STREAM] RETURNS [index: INT] = {
IF self.backingStream # NIL THEN RETURN[GetIndex[self.backingStream]]
ELSE ERROR Error[NotImplementedForThisStream, self];
};
DefaultSetIndex: PROC[self: STREAM, index: INT] = {
IF self.backingStream # NIL THEN SetIndex[self.backingStream, index]
ELSE SIGNAL Signal[NotImplementedForThisStream, self];
};
DefaultGetBlock: PROC[self: STREAM, block: REF TEXT, startIndex: NAT, stopIndexPlusOne: NAT] RETURNS[nBytesRead: NAT] = {
IF self.backingStream # NIL THEN RETURN[GetBlock[self.backingStream, block, startIndex, stopIndexPlusOne]]
ELSE {
end: NAT ← MIN[block.maxLength, stopIndexPlusOne];
FOR i: NAT IN [startIndex..end) DO
IF EndOf[self] THEN RETURN[i - startIndex];
block[i] ← GetChar[self];
ENDLOOP;
RETURN[end - startIndex];
};
};
DefaultPutBlock: PROC[self: STREAM, block: REF READONLY TEXT, startIndex: NAT, stopIndexPlusOne: NAT] = {
IF self.backingStream # NIL THEN PutBlock[self.backingStream, block, startIndex, stopIndexPlusOne] the reason this is the wrong thing to do is that the implementation of PutChar at this level may behave differently than simply passing through to backing stream, e.g. buffered streams.
ELSE
IF block # NIL THEN {
end: NAT ← MIN[block.length, stopIndexPlusOne];
FOR i: NAT IN [startIndex..end) DO
PutChar[self, block[i]];
ENDLOOP;
};
};
DefaultUnsafeGetBlock: UNSAFE PROC[self: STREAM, block: UnsafeBlock] RETURNS[nBytesRead: INT] = UNCHECKED {
IF self.backingStream # NIL THEN RETURN[UnsafeGetBlock[self.backingStream, block]]
ELSE ERROR Error[NotImplementedForThisStream, self];
};
DefaultUnsafePutBlock: PROC[self: STREAM, block: UnsafeBlock] = {
IF self.backingStream # NIL THEN UnsafePutBlock[self.backingStream, block]
ELSE Signal[NotImplementedForThisStream, self];
};
Implementing new operations: Implements
The following Allows individual streams to implement operations not provided with slots in streamProcs by storing an appropriate procedure on the streams alist. This procedure will be called with the same arguments as that supplied to the generic operation"s. For example, suppose a stream wants to implement the operation EraseChar. This would be accomplished by calling Implements on the corresponding handle with via a procedure of type PROC[self: handle, char: CHARACTER] (since EraseChar is of type PROC[self: handle, char: CHARACTER]), operation: IO.EraseChar. When EraseChar is called on this stream, it will search the streams otherStreamProcs for the key EraseChar, and if it finds such a key, call the procedure in proc giving it self, char as arguments. proc will be NARROWED to a procedure of the right type at runtime, to insure type safety, but to catch incorrect procedures earlier, i.e. when Implements is called, rather than when the operation is invoked, the check for whether proc is of the right type is also made at the time that Implements is called.
LookupProc: PUBLIC PROC [self: STREAM, operation: PROC ANY RETURNS ANY] RETURNS[proc: REF ANY] = {
RETURN[InlineLookupProc[self, operation]];
};
InlineLookupProc: PROC [self: STREAM, operation: PROC ANY RETURNS ANY] RETURNS[proc: REF ANY] = INLINE
{FOR l: LIST OF StreamProperty ← self.streamProcs.otherStreamProcs, l.rest UNTIL l = NIL DO
IF l.first.operation = operation THEN RETURN[l.first.proc];
ENDLOOP;
};
if procRef and key are supplied, then the AMTypes interface does not have to be used, and via will not be type checked. For internal use. Note: the full definition of Implements that uses the AMTypes interface is in IOAMImpl.
UncheckedImplements: PUBLIC PROC [self: STREAM ← NIL, operation, via: PROC ANY RETURNS ANY, data: REF ANY ← NIL, procRef: REF ANY, key: ATOM] = {
streamProcs: REF StreamProcs ← self.streamProcs;
FOR l: LIST OF StreamProperty ← streamProcs.otherStreamProcs, l.rest UNTIL l = NIL DO
IF l.first.operation = operation AND l.first.via = via THEN {key ← l.first.key; EXIT};
REPEAT
FINISHED => -- not there
{streamProcs.otherStreamProcs ← Zone.CONS[Zone.NEW[StreamPropertyRecord ← [operation: operation, via: via, proc: procRef, key: key]], streamProcs.otherStreamProcs]
};
ENDLOOP;
}; -- of UncheckedImplements
Property list operations
LookupData: PUBLIC PROC [self: STREAM, key: ATOM] RETURNS [REF ANY ← NIL] = {
RETURN[Atom.GetPropFromList[self.propList, key]];
};
StoreData: PUBLIC PROC [self: STREAM, key: ATOM, data: REF ANY] = {self.propList ← Atom.PutPropOnList[self.propList, key, data]};
AddData: PUBLIC PROC [self: STREAM, key: ATOM, data: REF ANY] = {
self.propList ← CONS[List.DotCons[key, data], self.propList];
};
RemoveData: PUBLIC PROC [self: STREAM, key: ATOM] = {
propList: Atom.PropList ← self.propList;
IF propList = NIL THEN RETURN
ELSE IF propList.first.key = key THEN self.propList ← self.propList.rest
ELSE FOR l: Atom.PropList ← propList, l.rest UNTIL l.rest = NIL DO
IF l.rest.first.key = key THEN {l.rest ← l.rest.rest; EXIT};
ENDLOOP;
};
Generic procedures: GetLength, UserAbort, Backup, AppendStreams, SetEcho, EraseChar
many generic procedures are implemented by replacing some of the streams procedures with new procedures, e.g. getChar, endOf, but having the rest of the procedures call through to their original values. I tried implementing CreatedefaultCallThruProcs to make this easier in that the implementor only has to supply the redefined procedures. However, since more than one ambush may be in effect at the same time, the same CallThru procedure cannot be used in each, since it would always find the same procedure to call thru to, i.e. infinite loop. Instead, must have the original procedures stored in the data associated with the corresponding redefinition.
GetLength: PUBLIC PROC[self: STREAM] RETURNS [length: INT] = {
DO
proc: REF ANY ← InlineLookupProc[self, GetLength];
IF proc # NIL THEN RETURN[(NARROW[proc, REF TypeOfGetLength])^ [self] ]
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE ERROR Error[NotImplementedForThisStream, self];
ENDLOOP;
}; -- of GetLength
SetLength: PUBLIC PROC[self: STREAM, length: INT] = {
DO
proc: REF ANY ← InlineLookupProc[self, SetLength];
IF proc # NIL THEN {(NARROW[proc, REF TypeOfSetLength ])^ [self, length]; RETURN}
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE SIGNAL Signal[NotImplementedForThisStream, self];
ENDLOOP;
}; -- of SetLength
UserAbort: PUBLIC PROC[self: STREAM] RETURNS [abort: BOOL] = {
DO
proc: REF ANY ← InlineLookupProc[self, UserAbort];
IF proc # NIL THEN RETURN[(NARROW[proc, REF TypeOfUserAbort])^ [self] ]
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE RETURN[FALSE];
ENDLOOP;
}; -- of UserAbort
SetUserAbort: PUBLIC PROC[self: STREAM] = {
DO
proc: REF ANY ← InlineLookupProc[self, SetUserAbort];
IF proc # NIL THEN {(NARROW[proc, REF TypeOfSetUserAbort])^ [self]; RETURN}
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE SIGNAL Signal[NotImplementedForThisStream, self];
ENDLOOP;
}; -- of SetUserAbort
ResetUserAbort: PUBLIC PROC[self: STREAM] = {
DO
proc: REF ANY ← InlineLookupProc[self, ResetUserAbort];
IF proc # NIL THEN {(NARROW[proc, REF TypeOfResetUserAbort])^ [self] ; RETURN}
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE RETURN;
ENDLOOP;
}; -- of ResetUserAbort
Backup: PUBLIC PROC [self: STREAM, char: CHARACTER] = {
origSelf: STREAM ← self;
DO
proc: REF ANY ← InlineLookupProc[self, Backup];
IF proc # NIL THEN {(NARROW[proc, REF TypeOfBackup ])^ [self, char]; RETURN}
ELSE IF self.backingStream # NIL THEN self ← self.backingStream -- the reason for taking this out is that I have found two cases where backing up the character at a lower level is not right. For example, if you have stream1 layered on stream2 layered on stream3, read a character from stream1, then back it up, and backup is only implemented by stream3, then that means stream2 will see the character twice. Another example, stream1 is layered on stream2, an input rope stream. stream1 "manufactures" characters in certain situations. A call to GetToken might back them up. stream2 will complain because it never saw the character.
ELSE EXIT;
ENDLOOP;
UncheckedImplements[self: origSelf, operation: Backup, via: XBackup, procRef: Zone.NEW[TypeOfBackup ← XBackup], key: $Backup];
implement it by ambushing getChar, getBlock. However, since Backup has to restore the original procs the backup character is consumed, and since the backup operation probably will be performed many times, accomplish the ambush in XBackup reusing the same scratch stream structure.
XBackup[origSelf, char]; -- will add data field. Reason can't be taken care of in call to UncheckedImplements is that UncheckedImplements only called once for the stream class, because subsequently, XPutBAck will be found in the otherStreamProcs slot. However, the data has to be added for each stream instance.
}; -- of Backup
BackupData: TYPE = REF BackupRecord;
BackupRecord: TYPE = RECORD[reuse: STREAM ← NIL, char: CHARACTER];
backupProcs: REF StreamProcs ← CreateRefStreamProcs[
getChar: BackupGetChar,
getBlock: BackupGetBlock,
endOf: BackupEndOf,
charsAvail: BackupCharsAvail,
reset: BackupReset,
the rest of the procedures "call through" by finding the original procedures and calling them
backup: AlreadyBackedUp,
name: "Backed Up"
];
AlreadyBackedUp: PROC [self: STREAM, char: CHARACTER] = {
ERROR Error[IllegalBackup, self];
}; -- of AlreadyBackedUp
XBackup: PROC [self: STREAM, char: CHARACTER] = {
data: BackupData ← NARROW[LookupData[self, $Backup]];
IF self.streamProcs = backupProcs THEN ERROR Error[IllegalBackup, self];
IF data = NIL THEN -- first time for this particular stream.
{data ← Zone.NEW[BackupRecord ← [reuse: CreateProcsStream[NIL, NIL], char: char]];
StoreData[self: self, key: $Backup, data: data]}
ELSE IF data.reuse = self THEN ERROR Error[IllegalBackup, self] -- can occur if user explicitly tries to do a backup on the backingstream
ELSE data.char ← char; -- data is in the streamData slot when stream is backed up. during the period when this stream is not in a backed up state, data remains on property list so it does not have to be reallocated for each putback.
AmbushProcsStream[self: self, streamProcs: backupProcs, streamData: data, reusing: data.reuse];
}; -- of XBackup
BackupGetChar: PROCEDURE [self: STREAM] RETURNS [char: CHARACTER] = {
data: BackupData ← NARROW[self.streamData];
char ← data.char;
IF self.streamProcs = backupProcs THEN UnAmbushProcsStream[self]
ELSE ERROR; -- SHOULDNT HAPPEN.
}; -- of BackupGetChar
BackupGetBlock: PROC[self: STREAM, block: REF TEXT, startIndex: NAT, stopIndexPlusOne: NAT] RETURNS[nBytesRead: NAT] = {
data: BackupData ← NARROW[self.streamData];
end: NAT ← MIN[stopIndexPlusOne, block.maxLength];
block[startIndex] ← data.char;
IF self.streamProcs = backupProcs THEN UnAmbushProcsStream[self]
ELSE ERROR; -- SHOULDNT HAPPEN
FOR i: NAT IN [startIndex+1..stopIndexPlusOne) DO
IF self.EndOf[] THEN RETURN[i - startIndex];
block[i] ← self.GetChar[];
ENDLOOP;
RETURN[stopIndexPlusOne - startIndex];
}; -- of BackupGetBlock
BackupEndOf: PROCEDURE[self: STREAM] RETURNS [BOOLEAN] = {
RETURN[FALSE];
}; -- of BackupEndOf
BackupCharsAvail: PROCEDURE[self: STREAM] RETURNS [BOOLEAN] = {
RETURN[TRUE];
}; -- of BackupCharsAvail
BackupReset: PROCEDURE[self: STREAM] = {
UnAmbushProcsStream[self];
}; -- of BackupReset
AppendStreams: PUBLIC PROC [in: STREAM, from: STREAM, appendToSource: BOOLEAN ← TRUE] = {
origSelf: STREAM ← in;
IF from = NIL OR NOT from.CharsAvail[] THEN RETURN;
DO
proc: REF ANY;
IF appendToSource AND in.backingStream # NIL THEN
{in ← origSelf ← in.backingStream; LOOP};
proc ← InlineLookupProc[in, AppendStreams];
IF proc # NIL THEN
{(NARROW[proc, REF PROC[in: STREAM, from: STREAM, appendToSource: BOOLEAN ← TRUE] ])^ [in, from];
RETURN}
ELSE IF in.backingStream # NIL THEN in ← in.backingStream
ELSE EXIT;
ENDLOOP;
UncheckedImplements[self: origSelf, operation: AppendStreams, via: XAppendStreams, procRef: Zone.NEW[PROC[in: STREAM, from: STREAM, appendToSource: BOOLEAN ← TRUE] ← XAppendStreams], key: $AppendStreams];
implement it by ambushing getChar, getBlock.
However, since AppendStreams has to restore the original procs after stream is exhausted, and since is likely to be done more than once, accomplish the ambush in XAppendStreams reusing the same scratch stream structure.
XAppendStreams[in, from, FALSE]; -- will add data field, ambush procs. Reason can't be taken care of in call to UncheckedImplements is that UncheckedImplements only called once for the stream class, and the data has to be added for each stream instance. i.e. the procedure XAppendStreams will stay around, and this code will not be executed again.
}; -- of AppendStreams
AppendStreamsData: TYPE = REF AppendStreamsRecord;
AppendStreamsRecord: TYPE = RECORD[reuse: STREAM ← NIL, from: LIST OF STREAM];
appendStreamsProcs: REF StreamProcs ← CreateRefStreamProcs[
getChar: AppendStreamsGetChar,
getBlock: AppendStreamsGetBlock,
endOf: AppendStreamsEndOf,
charsAvail: AppendStreamsCharsAvail,
reset: AppendStreamsReset
the rest of the procedures "call through" by finding the original procedures and calling them
];
XAppendStreams: PROC [in: STREAM, from: STREAM, appendToSource: BOOLEAN ← TRUE] = TRUSTED -- LOOPHOLE, polymorphism -- {
data: AppendStreamsData ← NARROW[LookupData[in, $AppendStreams]];
appendToSource is ignored because the implementor is always called at the right level. It must be included for typechecking by UnCheckedImplements
IF data = NIL THEN -- first time for this particular stream.
{data ← Zone.NEW[AppendStreamsRecord ← [reuse: CreateProcsStream[NIL, NIL], from: LIST[from]]];
StoreData[self: in, key: $AppendStreams, data: data];
}
ELSE IF data.from = NIL THEN data.from ← LIST[from] -- stream no longer in append mode.
ELSE
{data.from ← LOOPHOLE[List.Nconc1[LOOPHOLE[data.from, LIST OF REF ANY], from], LIST OF STREAM];
RETURN; -- data points to a stream higher up on food chain which already has procs set up.
};
IF in.streamProcs = appendStreamsProcs THEN ERROR;
AmbushProcsStream[self: in, streamProcs: appendStreamsProcs, streamData: data, reusing: data.reuse];
}; -- of XAppendStreams
AppendStreamsGetChar: PROCEDURE [self: STREAM] RETURNS [char: CHARACTER] = {
data: AppendStreamsData ← NARROW[self.streamData];
FOR lst: LIST OF STREAM ← data.from, lst.rest UNTIL lst = NIL DO
data.from ← lst;
IF lst.first.CharsAvail[] THEN RETURN[lst.first.GetChar[]];
ENDLOOP;
data.from ← NIL;
IF self.streamProcs = appendStreamsProcs THEN UnAmbushProcsStream[self]
ELSE ERROR; -- SHOULDNT HAPPEN
RETURN[self.GetChar[]];
}; -- of AppendStreamsGetChar
AppendStreamsGetBlock: PROC[self: STREAM, block: REF TEXT, startIndex: NAT, stopIndexPlusOne: NAT] RETURNS[nBytesRead: NAT] = {
data: AppendStreamsData ← NARROW[self.streamData];
end: NAT ← MIN[stopIndexPlusOne, block.maxLength];
IF self.streamProcs = appendStreamsProcs THEN UnAmbushProcsStream[self]
ELSE ERROR; -- SHOULDNT HAPPEN
FOR i: NAT IN [startIndex..stopIndexPlusOne) DO
IF self.EndOf[] THEN RETURN[i - startIndex];
block[i] ← self.GetChar[];
ENDLOOP;
RETURN[stopIndexPlusOne - startIndex];
}; -- of AppendStreamsGetBlock
AppendStreamsEndOf: PROCEDURE[self: STREAM] RETURNS [BOOLEAN] = {
data: AppendStreamsData ← NARROW[self.streamData];
FOR lst: LIST OF STREAM ← data.from, lst.rest UNTIL lst = NIL DO
data.from ← lst;
IF lst.first.CharsAvail[] THEN RETURN[FALSE];
ENDLOOP;
the appended streams have run out. restore state and check lower guy.
data.from ← NIL;
IF self.streamProcs = appendStreamsProcs THEN UnAmbushProcsStream[self]
ELSE ERROR; -- SHOULDNT HAPPEN
RETURN[self.EndOf[]];
}; -- of AppendStreamsEndOf
AppendStreamsCharsAvail: PROCEDURE[self: STREAM] RETURNS [BOOLEAN] = {
data: AppendStreamsData ← NARROW[self.streamData];
FOR lst: LIST OF STREAM ← data.from, lst.rest UNTIL lst = NIL DO
data.from ← lst;
IF lst.first.CharsAvail[] THEN RETURN[TRUE];
ENDLOOP;
the appended streams have run out. restore state and check lower guy.
data.from ← NIL;
IF self.streamProcs = appendStreamsProcs THEN UnAmbushProcsStream[self]
ELSE ERROR; -- SHOULDNT HAPPEN
RETURN[self.CharsAvail[]];
}; -- of AppendStreamsCharsAvail
AppendStreamsReset: PROCEDURE[self: STREAM] = {
data: AppendStreamsData ← NARROW[self.streamData];
data.from ← NIL;
UnAmbushProcsStream[self];
}; -- of AppendStreamsReset
SetEcho: PUBLIC PROC [self: STREAM, echoTo: STREAM] RETURNS [oldEcho: STREAM] = {
origSelf: STREAM ← self;
DO
proc: REF ANY ← InlineLookupProc[self, SetEcho];
IF proc # NIL THEN RETURN[(NARROW[proc, REF TypeOfSetEcho])^ [self, echoTo] ]
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE EXIT;
ENDLOOP;
implement it by ambushing getChar, getBlock.
AmbushProcsStream[self: origSelf, streamProcs: setEchoProcs, streamData: NEW[SetEchoRecord ← [echoTo: NIL]]]; -- set echo never restores the procs, so the setEchoProcs will always be in line somewhere, if not in the streamprocs themselves, then nested.
RETURN[origSelf.SetEcho[echoTo]];
}; -- of SetEcho
SetEchoData: TYPE = REF SetEchoRecord;
SetEchoRecord: TYPE = RECORD[echoTo: STREAM, singleFlg: BOOLEAN ← FALSE, char: CHARACTER ← NUL];
setEchoProcs: REF StreamProcs ← CreateRefStreamProcs[
getChar: SetEchoGetChar,
getBlock: SetEchoGetBlock,
endOf: SetEchoEndOf,
charsAvail: SetEchoCharsAvail,
reset: SetEchoReset,
setEcho: XSetEcho,
backup: SetEchoBackup -- if dont handle backup explicitly, the character putback would be echoed twice.
the rest of the procedures "call through" by finding the original procedures and calling them
];
XSetEcho: PROC [self: STREAM, echoTo: STREAM] RETURNS [oldEcho: STREAM] = {
data: SetEchoData ← NARROW[self.streamData];
oldEcho ← data.echoTo;
data.echoTo ← echoTo;
}; -- of XSetEcho
SetEchoBackup: PROC [self: STREAM, char: CHARACTER] = {
data: SetEchoData ← NARROW[self.streamData];
data.singleFlg ← TRUE;
data.char ← char;
}; -- of SetEchoBackup
SetEchoGetChar: PROCEDURE [self: STREAM] RETURNS [char: CHARACTER] = {
data: SetEchoData ← NARROW[self.streamData];
IF data.singleFlg THEN {data.singleFlg ← FALSE; RETURN[data.char]};
char ← self.backingStream.GetChar[];
IF data.echoTo # NIL THEN data.echoTo.PutChar[char];
}; -- of SetEchoGetChar
SetEchoGetBlock: PROC[self: STREAM, block: REF TEXT, startIndex: NAT, stopIndexPlusOne: NAT] RETURNS[nBytesRead: NAT] = {
data: SetEchoData ← NARROW[self.streamData];
end: NAT ← MIN[stopIndexPlusOne, block.maxLength];
FOR i: NAT IN [startIndex..stopIndexPlusOne) DO
IF self.EndOf[] THEN RETURN[i - startIndex];
block[i] ← self.GetChar[]; -- getChar will do the echoing.
ENDLOOP;
RETURN[stopIndexPlusOne - startIndex];
}; -- of SetEchoGetBlock
SetEchoEndOf: PROCEDURE[self: STREAM] RETURNS [BOOLEAN] = {
data: SetEchoData ← NARROW[self.streamData];
RETURN[~data.singleFlg AND self.backingStream.EndOf[]];
}; -- of SetEchoEndOf
SetEchoCharsAvail: PROCEDURE[self: STREAM] RETURNS [BOOLEAN] = {
RETURN[~self.EndOf[]];
}; -- of SetEchoCharsAvail
SetEchoReset: PROCEDURE[self: STREAM] = {
data: SetEchoData ← NARROW[self.streamData];
data.singleFlg ← FALSE;
self.backingStream.Reset[];
}; -- of SetEchoReset
EraseChar: PUBLIC PROC [self: STREAM, char: CHARACTER] = {
DO
proc: REF ANY ← InlineLookupProc[self, EraseChar];
IF proc # NIL THEN {(NARROW[proc, REF TypeOfEraseChar])^ [self, char]; RETURN}
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE {self.PutChar['\\]; self.PutChar[char]; RETURN};
ENDLOOP;
}; -- of EraseChar
ChangeDeliverWhen: PUBLIC PROC [self: STREAM, proc: DeliverWhenProc] RETURNS [oldProc: DeliverWhenProc] = {
DO
ref: REF ANY ← InlineLookupProc[self, ChangeDeliverWhen];
IF ref # NIL THEN RETURN[(NARROW[ref, REF TypeOfChangeDeliverWhen])^ [self, proc] ]
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE SIGNAL Signal[NotImplementedForThisStream, self];
ENDLOOP;
}; -- of ChangeDeliverWhen
GetBufferContents: PUBLIC PROC [self: STREAM] RETURNS[buffer: ROPE] = {
DO
proc: REF ANY ← InlineLookupProc[self, GetBufferContents];
IF proc # NIL THEN RETURN[(NARROW[proc, REF TypeOfGetBufferContents])^ [self] ]
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE SIGNAL Signal[NotImplementedForThisStream, self];
ENDLOOP;
}; -- of GetBufferContents
WaitUntilCharsAvail: PUBLIC PROC [self: STREAM] = {
DO
proc: REF ANY ← InlineLookupProc[self, WaitUntilCharsAvail];
IF self.CharsAvail[] THEN RETURN
ELSE IF proc # NIL THEN {(NARROW[proc, REF TypeOfWaitUntilCharsAvail])^ [self] ; RETURN}
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE TRUSTED {
UNTIL self.CharsAvail[] DO
Process.Pause[Process.MsecToTicks[100]];
ENDLOOP;
EXIT;
};
ENDLOOP;
}; -- of WaitUntilCharsAvail
CurrentPosition: PUBLIC PROC [self: STREAM] RETURNS[position: INT] = {
origSelf: STREAM ← self;
DO
proc: REF ANY ← InlineLookupProc[self, CurrentPosition];
IF proc # NIL THEN RETURN[(NARROW[proc, REF TypeOfCurrentPosition])^ [self] ]
ELSE IF self.backingStream # NIL THEN self ← self.backingStream
ELSE EXIT;
ENDLOOP;
implement it by ambushing putchar, putblock.
UncheckedImplements[self: origSelf, operation: CurrentPosition, via: XPosition, procRef: Zone.NEW[TypeOfCurrentPosition ← XPosition], key: $CurrentPosition];
RETURN[XPosition[self]]; -- will add data field. Reason can't be taken care of in call to UncheckedImplements is that UncheckedImplements only called once for the stream class, and the data has to be added for each stream instance. i.e. the procedure XPosition will stay around, and this code will not be executed again.
}; -- of CurrentPosition
PositionData: TYPE = REF PositionRecord;
PositionRecord: TYPE = RECORD[
putChar: PROCEDURE [self: STREAM, char: CHARACTER],
putBlock: PROC[self: STREAM, block: REF READONLY TEXT, startIndex: NAT, stopIndexPlusOne: NAT],
count: INT ← 0
];
XPosition: PROC [self: STREAM] RETURNS[position: INT] = {
data: PositionData ← NARROW[LookupData[self, $CurrentPosition]];
IF data = NIL THEN {StoreData[self: self, key: $CurrentPosition, data: Zone.NEW[PositionRecord ← [putChar: self.streamProcs.putChar, putBlock: self.streamProcs.putBlock]]]; -- first time for this particular stream.
self.streamProcs ← Zone.NEW[StreamProcs ← self.streamProcs^];
self.streamProcs.putChar ← PositionPutChar;
self.streamProcs.putBlock ← PositionPutBlock;
RETURN[0]};
RETURN[data.count];
}; -- of XPosition
PositionPutChar: PROC [self: STREAM, char: CHARACTER] = {
data: PositionData ← NARROW[LookupData[self, $CurrentPosition]];
IF char = CR THEN data.count ← 0 ELSE data.count ← data.count + 1;
data.putChar[self, char];
}; -- of PositionPutChar
PositionPutBlock: PROC [self: STREAM, block: REF READONLY TEXT, startIndex: NAT, stopIndexPlusOne: NAT] = {
data: PositionData ← NARROW[LookupData[self, $CurrentPosition]];
end: NAT;
count: INT ← data.count;
IF block = NIL THEN RETURN;
end ← MIN[stopIndexPlusOne, block.length];
FOR i: NAT IN [startIndex..end) DO
IF block[i] = CR THEN count ← 0 ELSE count ← count + 1;
ENDLOOP;
data.putBlock[self, block, startIndex, stopIndexPlusOne];
data.count ← count; -- data.putBlock might be the default putblock which calls putChar which would count all of the characters twice.
}; -- of PositionPutBlock
SpaceTo: PUBLIC PROCEDURE [self: STREAM, n: INT, nextLine: BOOLEAN ← TRUE] = {
current: INT ← CurrentPosition[self];
IF current > n THEN
{IF NOT nextLine THEN RETURN;
self.PutChar['\n];
current ← 0
};
WHILE current < n DO
self.PutChar[' ];
current ← current + 1;
ENDLOOP;
}; -- of SpaceTo
END.
12-Mar-82 13:39:42 fixed bug in PositionPutBlock which caused characters to be counted twice.
8-Apr-82 16:11:31 deimplemented default confirm that was using cursor and userinput. Now gives error if no confirm implemented.
26-Apr-82 14:41:13 fixed appendstreams CharsAvail and Endof to check and see if last character had been read and if so, to deambush and go to backingstream, rather than the way it used to work, which was not to deambush until next getchar.
September 1, 1982 10:20 pm changed CreateRefStreamProcs to take setUserAbort and resetUserAbort as arguments. Defined SetUserAbort and ResetUserAbort
October 1, 1982 1:09 pm changed default of close to call flush or reset before nop.
Edited on December 3, 1982 2:09 pm, by Teitelman
moved UnCheckedImplements to IOAmImpl in order to remove useage of AMTypes, AMBridge
changes to: DIRECTORY, IMPORTS, Implements
Edited on February 9, 1983 6:33 pm, by Teitelman
changes to: DefaultCharsAvail, DefaultClose, DefaultGetBlock, DefaultPutBlock
Edited on March 28, 1983 8:39 pm, by Teitelman
changes to: AmbushProcsStream, Backup, AlreadyBackedUp (local of Backup), XBackup (local of Backup), XBackup (local of Backup), XBackup (local of Backup)
Edited on April 20, 1983 2:52 pm, by Teitelman
changes to: Backup