//CHATTTY.BCPL - Bob Sproull - Pup User Telnet - BCPL // Copyright Xerox Corporation 1979, 1980 // modified: October 19, 1980 4:02 PM (E. Taft) get "Chat.d" get "ChatBSP.d" get "AltoDefs.d" //outgoing procedures external [ ChatTTY GetKey GetString ChatHandlePup DirectKeys SetScreenColor CaretOff FlipCaret ] //incoming procedures external [ //CHAT BigStack SmallStack SendMarkData Sti CheckShiftSwat SendScreenParams BitBlt ChatReadParams ChatComOpen EnqueueAudioOut //OS Gets Puts OpenFile Closes Resets Endofs Ws Wss ReadBlock FileLength FilePos SetFilePos CleanupDiskStream TruncateDiskStream CreateDisplayStream ShowDisplayStream CharWidth GetFont GetBitPos SetBitPos GetLmarg GetRmarg EraseBits Allocate Free Zero InitializeZone MyFrame ReturnFrom SysErr //Pup BSPForceOutput BSPGetMark ReleasePBI Min //QUEUE Enqueue Unqueue //ALTOTIME SetTimer TimerHasExpired //CONTEXT CallContextList InitializeContext Block //ETHERBOOT EtherBoot ] //outgoing statics external [ TTYVersion caretDS; caretShown; timingMarks ] static [ TTYVersion=14 ] //incoming statics external [ ChatZone //Main free-storage zone Parm //Chat parameter vector TTYSoc; TTYStr //Socket, stream for TTY connection Running // 0 = closed; 1 = open; >2 = please close ctxQ //Running contexts ScreenBuffer //Address of usable area for screen ScreenBufferLength // .. length of same.. makeBootFile //OS keys dsp lvUserFinishProc ] //local statics static [ instream //Current source of iput (0=> keyboard) SendTermType=true //True if terminal characteristics s/b sent tyiCtx //Type-In context tyoCtx //Type-Out context WasBlack //True if screen is flashed DIS //Display stream to use MarkCount //Number if "interrupts" received SystemScroll //Normal scroll routine FontPointer //Pointer to current font TStream // Non-zero if typescript going TToGoTillWrap //Count of TypeScript chars till wrap file tsToFlush //Count of TypeScript chars till flush tsTimer //Time until forced TS flush savedUFP caretDS caretShown = false pleaseFinish timingMarks = 0 ] //Note: This code is run with entire OS around. No Junta is done. let ChatTTY() be [ ScreenBuffer=ChatReadParams //Bottom of usable area ScreenBufferLength=23000 let zoneBot=ScreenBuffer+ScreenBufferLength let zoneTop=MyFrame()-400 //Enough for ChatTTY ChatZone=InitializeZone(zoneBot,zoneTop-zoneBot) @#335=zoneTop TypeScriptStart() ScreenSetUp() //Do the main thing: tyiCtx=Allocate(ChatZone,200) tyoCtx=Allocate(ChatZone,200) let comCtx=Allocate(ChatZone,200) savedUFP = @lvUserFinishProc @lvUserFinishProc = TTYHandleFinish [ DirectKeys(DIS) Enqueue(ctxQ, InitializeContext(tyiCtx, 200, TypeIn)) Enqueue(ctxQ, InitializeContext(tyoCtx, 200, TypeOut)) Enqueue(ctxQ, InitializeContext(comCtx, 200, Command)) // Set up the various kinds of error handling TTYStr>>ST.error=ChatHandleBSPError TTYSoc>>BSPSoc.bspOtherPupProc=ChatHandlePup Running=1 //Want to keep open while Running do [ CallContextList(ctxQ!0) CheckShiftSwat() ] if pleaseFinish then finish Unqueue(ctxQ, comCtx) // tyiCtx and tyoCtx were unqueued by Command() CaretOff() Wss(DIS, "*n*l~~~~~~~~ Connection terminated ~~~~~~~~*n*l") @(lv Parm>>PARM.ConnectString) = 0 @(lv Parm>>PARM.InitialString) = 0 ChatComOpen() SendTermType = true ] repeat ] //Type In (to Partner) // This process handles all Alto => Partner traffic // Sets up input stream (given DO file, etc.) // Pre-loads output buffer with MAXC login sequence if any. // Loops processing all traffic. and TypeIn() =valof [TI //Give out whatever initial string there is: let str=lv Parm>>PARM.InitialString for i=1 to str>>STR.length do Puts(TTYStr, str>>STR.char^i) BSPForceOutput(TTYSoc) [MainLoop MainLp: if Parm>>PARM.DoDirective gr 0 then [ BigStack() instream=OpenFile(lv Parm>>PARM.DoFileName, ksTypeReadOnly, charItem) if instream eq 0 % Endofs(instream) then [ Ws("*nDo file does not exist.") instream=0 Parm>>PARM.DoDirective=0 ] Parm>>PARM.DoDirective=-Parm>>PARM.DoDirective SmallStack() ] if SendTermType then //After attach or login,bitte [ SendTermType=false SendScreenParams(TTYSoc) ] //Get a character from prevailing input source: let c=nil test instream eq 0 ifso [ //Read from keyboard c=GetKey(0) //Get a char ] ifnot [ BigStack() test Endofs(instream) then [ Closes(instream) //End of auto file instream=0 if Parm>>PARM.DoDirective eq -2 then Running=4 c=-1 ] or c=Gets(instream) c=SmallStack(c) ] //If it is negative, it was probably simulated input to cause us to loop: if c ge 0 then [ Puts(TTYStr, c) if Parm>>PARM.Echo then Puts(DIS, c) if TStream ne 0 & Parm>>PARM.tsTypeIn ne 0 then TypeScriptChars(c) ] if instream eq 0 & Endofs(keys) ne 0 then BSPForceOutput(TTYSoc) ]MainLoop repeat ]TI // TypeOut -- this process handles all Partner => Alto traffic and TypeOut() be [TO let inChar=Gets(TTYStr) //Get a byte if caretShown then CaretOff() test inChar ge 0 then [ if MarkCount gr 0 then loop if TStream ne 0 & Parm>>PARM.tsTypeOut ne 0 then TypeScriptChars(inChar) if inChar eq 7 then [ ScreenBlack(); loop ] if WasBlack then ScreenWhite() Puts(DIS,inChar) ] or test inChar eq -1 then //Mark [ switchon BSPGetMark(TTYSoc) into [ case MarkSync: MarkCount = MarkCount-1; endcase case MarkTiming: timingMarks = timingMarks+1; Sti(-1); endcase case MarkLineWidth: case MarkPageLength: case MarkTerminalType: Gets(TTYStr); endcase ] ] or if inChar eq -3 then Running=3 //Bad connection -- close ]TO repeat // Command // This process and associated routines handles all commands // (explicit from keyboard; implicit from wanting to close connection // by finishing, hitting EOF on a DO file, etc.) // The state of the world is represented by the value of Running: // 0 Closed // 1 Open // 2 Please close and permit user to establish another connection // 3 Please close because of error or remote disconnect // 4 Please close and finish and Command() be [ Block() if @#177035 ne #177775 & Running eq 1 loop if Running eq 1 then [ DirectKeys(dsp) //So keyboard typing will come here Ws("*nCommand: ") let c=GetKey() let OnOff(flag) be Ws(flag? "ON", "OFF") switchon c into [ case $E: case $e: Parm>>PARM.Echo=not Parm>>PARM.Echo Ws("Echo "); OnOff(Parm>>PARM.Echo) endcase case $C: case $c: Parm>>PARM.ControlChars=not Parm>>PARM.ControlChars Ws("Control chars "); OnOff(Parm>>PARM.ControlChars) endcase case $Q: case $q: Ws("Quit!") Running=4 endcase case $F: case $f: Ws("Font file name:") GetString(lv Parm>>PARM.FontName) ScreenSetUp() endcase case $D: case $d: Ws("Do file name:") GetString(lv Parm>>PARM.DoFileName) Parm>>PARM.DoDirective=1 Sti(-2) //Force receipt of char endcase case $T: case $t: if makeBootFile then docase -1 Ws("Typescript to file:") GetString(lv Parm>>PARM.TSFileName) TypeScriptChars() Parm>>PARM.TypeScriptLength = -1 TypeScriptStart() endcase case $I: case $i: test Parm>>PARM.TypeScriptLength eq 0 ifso Ws("No typescript!") ifnot [ Parm>>PARM.tsTypeIn= not Parm>>PARM.tsTypeIn Ws("TypeScriptChars In: ") OnOff(Parm>>PARM.tsTypeIn) ] endcase case $O: case $o: test Parm>>PARM.TypeScriptLength eq 0 ifso Ws("No typescript!") ifnot [ Parm>>PARM.tsTypeOut= not Parm>>PARM.tsTypeOut Ws("TypeScriptChars Out: ") OnOff(Parm>>PARM.tsTypeOut) ] endcase case $N: case $n: Ws("New connection (break current one) [Confirm] ") switchon GetKey() into [ case $*n: case $Y: case $y: Ws("Yes"); Running=2; endcase default: Ws("No") ] endcase case $?: Ws(" ?") Ws("*NC=Control chars, D=Do file name, E=Echo Change, F=Font file name") Ws("*NI=TypeScriptInput, N=New connection, O=TypeScript Output, Q=Quit") Ws("*nT=Typescript to file") endcase default: Ws("Unknown command.") endcase ] DirectKeys(DIS) ] if Running ge 2 then [ Unqueue(ctxQ, tyiCtx) Unqueue(ctxQ, tyoCtx) Closes(TTYStr) TypeScriptChars() //Flush ts. pleaseFinish = Running ge 4 % (Running eq 3 & not (makeBootFile % Parm>>PARM.Server ne 0)) Running=0 //All finished! ] ] repeat // Various error code. // Stream Errors: simply arrange to return a flag value that indicates // what has happened: // -1: Mark // -2: Interrupt (not yet implementable!) // -3: Grounds for closing connection (bad state) and TTYHandleFinish(code) be [ @lvUserFinishProc=savedUFP let tim=nil SetTimer(lv tim, 3000) // Thirty seconds if Running then Running=2 //Flag to stop everything until Running eq 0 % TimerHasExpired(lv tim) do CallContextList(ctxQ!0) ] and ChatHandleBSPError(str, ec) = valof [ switchon ec into [ case ecMarkEncountered: resultis -1 default: //Bad status -- connection to close Block() //Give other guy chance to run resultis -3 ] ] //Called when an error, interrupt, or abort pup is received, and handed // the very pup. and ChatHandlePup(pbi) be [CPE let woffs = nil switchon pbi>>PBI.pup.type into [ case typeError: [ unless pbi>>PBI.pup.words^11 eq 2 endcase pbi = BigStack(pbi) CaretOff() Ws("*n[Error]") woffs = 12 docase -1 ] case typeAbort: [ pbi = BigStack(pbi) CaretOff() Ws("*n[Abort]") woffs = 1 docase -1 ] case -1: [ let C=lv pbi>>PBI.pup.bytes let sl=pbi>>PBI.pup.length-2*woffs-21 //Text length+1 let fp=C+woffs-1 @fp=(sl lshift 8)+#40 //Length,,space Ws(fp) //Print message if any pbi = SmallStack(pbi) endcase ] // Should really check socket, but not easy.... case typeInterrupt: [ MarkCount=MarkCount+1 //Grumble..... endcase ] ] ReleasePBI(pbi) ]CPE //TypeScript routines // TypeScriptStart() called to get it going. // TypeScriptChars(byte) called to stuff chars into it. // TypeScriptChars(-2) -- check timer and flush if needed // TypeScriptChars() flushes the current buffers to the disk. and TypeScriptStart() be [TSS if TStream ne 0 then [ BigStack(); Closes(TStream); SmallStack() ] TStream = 0 let name = lv Parm>>PARM.TSFileName if Parm>>PARM.TypeScriptLength eq 0 % name>>STR.length eq 0 % makeBootFile then return name = BigStack(name) let s=OpenFile(name, ksTypeReadWrite, charItem, 0, lv Parm>>PARM.TypeScriptFP) test s eq 0 ifso [ Ws("*nCannot open typescript file.") ] ifnot [ if Parm>>PARM.TypeScriptLength ne -1 then SetFilePos(s, 0, Parm>>PARM.TypeScriptLength) TruncateDiskStream(s) //And make this the end. TStream=s //Stream to use. TToGoTillWrap=0 //Flag to wrap on next output tsToFlush=-TypeScriptFlushCount SetTimer(lv tsTimer, TypeScriptTimeOut) ] Zero(lv Parm>>PARM.TypeScriptFP, lFP) SmallStack() ]TSS and TypeScriptChars(arg ;numargs n) be [TSC let TS2(arg) be [TS test arg eq -1 % tsToFlush eq 0 % TimerHasExpired(lv tsTimer) then [ //Flush tsToFlush=-TypeScriptFlushCount-3 SetTimer(lv tsTimer, TypeScriptTimeOut) if Parm>>PARM.TypeScriptLength ne -1 then [ let old=TToGoTillWrap let v=vec 1 FilePos(TStream, v) TS2($<) TS2($=) TS2($>) SetFilePos(TStream, v) TToGoTillWrap=old ] if arg ge 0 then TS2(arg) CleanupDiskStream(TStream) ] or if arg ge 0 then [ tsToFlush=tsToFlush+1 if arg eq #12 & Parm>>PARM.LineFeeds eq false then return if TToGoTillWrap eq 0 & Parm>>PARM.TypeScriptLength ne -1 then [ TToGoTillWrap=-Parm>>PARM.TypeScriptLength Resets(TStream) //Back to beginning ] TToGoTillWrap=TToGoTillWrap+1 Puts(TStream,arg) ] ]TS and TSError(s, ec) be [ test ec eq 1102 // ecEof ifso [ Ws("*nYour Alto disk is full; typescript closed.") Closes(TStream); TStream = 0 ReturnFrom(TS2) ] ifnot SysErr(s, ec) ] if TStream eq 0 then return arg=BigStack(((n eq 0)? -1, arg)) TStream>>ST.error = TSError TS2(arg) TStream>>ST.error = SysErr SmallStack() ]TSC //ScreenSetUp() // [ statics ScreenBuffer, ScreenBufferLength set up ] // Gets font, opens stream for display. // Result is the static DIS to use as display stream // Can be called repeatedly without damage. and ScreenSetUp() be [SSU BigStack() GetFontPointer() //Get current font if DIS then Closes(DIS) //Delete previous version //Compute max size of screen available for text let lin=808-15 //Available scan-lines let a=@#420 while a do //Subtract those already in use [ lin=lin-a>>DCB.height*2 a=@a ] lin=lin/((FontPointer!-2 +1)&(-2)) //Divide by font height unless Parm>>PARM.CalcScreenParms then lin=Parm>>PARM.ScreenLines DIS = CreateDisplayStream(lin, ScreenBuffer, ScreenBufferLength, FontPointer) SystemScroll=DIS>>DS.scroll DIS>>DS.scroll=MyScroll ShowDisplayStream(DIS) if Parm>>PARM.CalcScreenParms then [ //Now divide, but subtract one. This is because MAXC believes that // lines are scrolled on , but OS display routines believe they are // scrolled on . MAXC types the "bells" and stops output between // the and Parm>>PARM.ScreenLines=lin-1 if Parm>>PARM.ScreenLines gr 127 then Parm>>PARM.ScreenLines=127 let wA=CharWidth(DIS, $A) let wa=CharWidth(DIS, $a) Parm>>PARM.ScreenChars=(38*16*4)/(wA+3*wa)-3 if Parm>>PARM.ScreenChars gr 127 then Parm>>PARM.ScreenChars=127 SendTermType=true //Flag to send screen params to Net. ] SmallStack() ]SSU // MyScroll makes carriage return and line feed honestly interpreted // by Chat. and MyScroll(ds, char; numargs n) = valof [MS static farthestRight if n eq 1 then resultis SystemScroll(ds) switchon char into [ case #15: [ let r=GetBitPos(ds) if r gr farthestRight then farthestRight=r SetBitPos(ds, GetLmarg(ds)) resultis char ] case #12: [ let r=GetBitPos(ds) if r ls farthestRight then SetBitPos(ds, farthestRight) farthestRight=0 resultis SystemScroll(ds, #15) ] default: unless Parm>>PARM.ControlChars do if char ls #40 & char ge 0 resultis false case #11: resultis SystemScroll(ds, char) ] ]MS //GetFontPointer(fnam) // Set up a font to use. fnam is the name of the font (no name=> // use system font). Returns font pointer. and GetFontPointer() be [ let def=GetFont(dsp) //System font!!!! if FontPointer ne 0 & FontPointer ne def then Free(ChatZone, FontPointer-2) let fnam=lv Parm>>PARM.FontName FontPointer= valof [ // Do not attempt to read font file if Chat was booted if makeBootFile % fnam>>STR.length eq 0 then resultis def let s=OpenFile(fnam, ksTypeReadOnly) if s eq 0 then [ //Try with .AL let len=fnam>>STR.length fnam>>STR.char^(len+1)=$. fnam>>STR.char^(len+2)=$A fnam>>STR.char^(len+3)=$L fnam>>STR.length=len+3 s=OpenFile(fnam, ksTypeReadOnly) if s eq 0 then [ Ws("*NUnable to find font file.") resultis def ] ] let len=FileLength(s)/2 let font=Allocate(ChatZone, len, true) //Get core for it. if font eq 0 then [ Ws("*NNo room for font storage") Closes(s) resultis def ] Resets(s) ReadBlock(s,font,len) //Read font Closes(s) resultis font+2 //Point to 3rd word ] ] //Call ScreenBlack() when bell is received... and ScreenBlack() be [Black if WasBlack then return WasBlack = true if Parm>>PARM.Ding then [ Resets(dsp) Ws( " $$$$$ $$$$ $$$ $$ $$$$$") Ws("*N $$ $$ $$ $$$$ $$ $$ ") Ws("*N $$ $$ $$ $$ $$$$ $$ $$$") Ws("*N $$ $$ $$ $$ $$$ $$ $$") Ws("*N $$$$$ $$$$ $$ $$ $$$$ ") ] if Parm>>PARM.Flash then SetScreenColor(DIS, 1, true) if Parm>>PARM.Audio then EnqueueAudioOut(20, 200) ]Black and ScreenWhite() be [White unless WasBlack then return WasBlack = false if Parm>>PARM.Ding then [ Resets(dsp); SetScreenColor(dsp, Parm>>PARM.Border) ] if Parm>>PARM.Flash then SetScreenColor(DIS, 0, true) ]White and SetScreenColor(ds, color, lastOnly; numargs na) be [ let dcb = ds>>DS.fdcb while dcb ne ds>>DS.ldcb do [ unless na ge 3 & lastOnly do dcb>>DCB.background = color dcb = dcb>>DCB.next ] dcb>>DCB.background = color ]