(* This file is the concatenated source for Kermit for the Joyce-Loebl Magiscan image processor, running UCSD p-System. Before compiling you will need to split the file at the clearly marked points, saving each section into a TEXT file of the appropriate name *) **** File DISK.TEXT ************************************************************ (*$S+*) { This Unit is based on the SLVDIMS of Joyce Loebl } { Created by H Balen 22-Aug-84 } { Modified by H Balen 13-May-85 } Unit DiskUnit; Interface Uses M2Types,M2IpRoot,M2Sys; type GreyVal = 0..255; LType = packed array[0..255] of GreyVal; L2Type = packed array[0..255] of char; LineType = record case Boolean of True :(i : LType); False:(b : L2Type) end; BufferType = record case integer of 0 :(i : packed array[0..511] of GreyVal); 1 :(b : packed array[0..1] of L2Type); 2 :(Im : Image ) end; var Fl : File; procedure ImSve( Im : Image; FName : String ); procedure ImLd( var Im : Image; FName : String ); Implementation procedure ImSve; { This procedure saves an image, up to eight bits } var Line : LineType; Buffer: BufferType; A,B,C,D : Image; Blk : integer; procedure Deposit( Im : Image ); { This procedure writes the necessary data to the disk in units of 512 bytes,and Images of Half size } var Blks,RowNum : Integer; Row : PointSet; procedure GetLine( LinePs : PointSet; Im : Image ; var GVal: LType ); { This procedure gets a 256 byte line from the picture } type Idynarray = array[1..1]of Integer; var Mrk : ^Integer; Idyn: ^Idynarray; i : integer; begin { Mark the Heap, and create space } mark(Mrk); New(Idyn); { Sample the image over the pointset and collect data } ImSmp(LinePs,Im,Idyn^[0],i); { Transfer the sampled data to the array for returning } for i := 0 to 255 do GVal[i] := Idyn^[i]; { Clear the heap } Release(Mrk) end{ GetLine }; begin { Define a pointset for sampling purposes } DefWindow(Row,0,0,256,1); { Get the necessary part of the image and save it } for RowNum := 0 to 255 do begin { Move pointset to current sample line } Row.Origin.Y := RowNum; { Sample the current line / collect the Data Values } GetLine(Row,Im,Line.i); if Odd(RowNum) then begin{ Write to the Disk } { Copy to buffer } Buffer.b[1] := Line.b; { Actual write to disk } Blks := BlockWrite(Fl,Buffer.i,1) end else{ Still to fill the Buffer } Buffer.b[0] := Line.b end end{ Deposit }; begin{ Save } { Open the file } Rewrite(Fl,FName); { Collect the attributes of the image } Buffer.Im := Im; { Put image attributes at the beginning of the file } Blk := BlockWrite(Fl,Buffer.Im,1); { Deal with necessary image size } case Im.Res of Half: Deposit(Im); Full: begin with Im do begin { Split the image into 4 Half size images } DefImage(A,Origin.X,Origin.Y,Half,LsBit,NoBits); DefImage(B,Origin.X+256,Origin.Y,Half,LsBit,NoBits); DefImage(C,Origin.X+256,Origin.Y+256,Half,LsBit,NoBits); DefImage(D,Origin.X,Origin.Y+256,Half,LsBit,NoBits); { Save the image on disk } Deposit(A); Deposit(B); Deposit(C); Deposit(D) end{ with } end end{ Case }; { Close the file } Close(Fl,Lock) end{ Save }; procedure ImLd; { This procedure ReLoads a previously saved image } var Buffer : BufferType; Line : LineType; A,B,C,D: Image; L,N,Blk: Integer; Error : Boolean; procedure ReDraw( var Im : Image ); { This procedure draws a Half size image on the screen } var RowNum,Blks : integer; Row : PointSet; procedure PutRow( LinePs : PointSet; var Im : Image; var GVal: LType ); { This procedure gets the current row and draws it } type Idynarray = array[1..1] of integer; var Mrk : ^integer; Idyn: ^Idynarray; i : integer; begin { Mark Heap and make room } mark(Mrk); New(Idyn); { Get the current line } for i := 0 to 255 do Idyn^[i] := GVal[i]; { Draw the line } DrawFn(LinePs,Im,Idyn^[0]); { Tidy the Heap } release(Mrk) end{ PutRow }; begin { Define a PointSet for the current line } DefWindow(Row,0,0,256,1); { Draw the Half image to screen } for RowNum := 0 to 255 do begin { Move the PointSet to the current Line position } Row.Origin.Y := RowNum; if Odd(RowNum) then begin{ Read the Buffer } Line.b := Buffer.b[1]; { and put on screen } PutRow(Row,Im,Line.i) end else begin{ Fill the Buffer from the Disk } Blks := BlockRead(Fl,Buffer.i,1); { Then read it and put on screen } Line.b := Buffer.b[0]; PutRow(Row,Im,Line.i) end end end{ ReDraw }; begin { Take care of possible file name fault } (*$I-*) Reset(Fl,FName); Error := IOResult <> 0; (*$I+*) { If we have the correct file then } if not Error then begin{ Get the details of the stored image } Blk := BlockRead(Fl,Buffer.Im,1); { If the stored image does not match the declared image } if (Buffer.Im.Res <> Im.Res) then{ error } writeln(' ReLoad : Image Resolution incompatible ') else{ Everything ok } begin { Take care of image size } case Im.Res of Half: ReDraw(Im); Full: begin with Im do begin { Split image into 4 Half size images } L := LsBit;N := NoBits; DefImage(A,Origin.X,Origin.Y,Half,L,N); DefImage(B,Origin.X+256,Origin.Y,Half,L,N); DefImage(C,Origin.X+256,Origin.Y+256,Half,L,N); DefImage(D,Origin.X,Origin.Y+256,Half,L,N); { Get each image and draw it } ReDraw(A); ReDraw(B); ReDraw(C); ReDraw(D); end{ With }; end; end{ Case } end; Close(Fl) end{ Not Error } else{ Error in file name } writeln(' ReLoad : Image file open error ') end{ ReLoad }; end{ Save }. **** File FILEUNIT.TEXT ******************************************************** (*$S+*) { This unit contains the primitives necessary to store the incoming data on the disk specified } Unit FileHandle; Interface Uses M2Types,M2IpRoot,M2Sys, (*$U Disk.Code*)DiskUnit; const BufEnd = 512; type BuffType = packed array[1..BufEnd] of char; FStates = (TxtFile,BinFile,ImgFile,CodeFile); { File States } var FileBuf : BuffType; BuffPosn : integer; Disk : String[3]; TF : Text; F : File; TranState : FStates; EOI : boolean; { End of Image ! } procedure FileInit; procedure CloseF(var Name : string; Save : boolean ); function ReadOpenF(var Name : string ; State : FStates ): boolean; function WriteOpenF(var Name : string ; State : FStates ): boolean; procedure SaveBuff(var Buff : BuffType; var Posn : integer; NewLine : boolean ); procedure ReadBuff(var Buff : BuffType; var Posn : integer ); procedure LoadIm(var Name : string ); Implementation var Im,TxtIm : Image; Tab : IOTab; Line : PointSet; YPosn : integer; (* ---------------------------------------------------- *) procedure GetLine(var Line : PointSet; Im : Image; var Buff : BuffType ); type IdynArray = array[1..1]of Integer; var Mrk : ^integer; Idyn : ^IdynArray; i : integer; begin mark(Mrk); New(Idyn); ImSmp(Line,Im,Idyn^[0],i); for i := 0 to 511 do Buff[i+1] := chr(Idyn^[i]); Release(Mrk) end{GetLine}; (* ---------------------------------------------------- *) procedure PutLine(var Line : PointSet; Im : image; var Buff : BuffType ); type IdynArray = array[1..1]of Integer; var Mrk : ^integer; Idyn : ^IdynArray; i : integer; begin mark(Mrk); New(Idyn); for i := 1 to BufEnd do Idyn^[i-1] := ord(Buff[i]); DrawFn(Line,Im,Idyn^[0]); Release(Mrk) end{PutLine}; (* ---------------------------------------------------- *) procedure InitF; begin SysInit; DefImage(Im,0,512,Full,8,8); DefImage(TxtIm,0,512,Full,0,1); DefWindow(Line,0,512,512,1); LinearIO(Tab,0,255); Live(Im,Tab,Tab); Photo; Display(Im,Tab); ClearIm(Im); OvLay(TxtIm,XSat+Yellow); YPosn := 511; EOI := TranState <> ImgFile end{InitF}; (* ---------------------------------------------------- *) procedure LoadIm; var Ok : boolean; begin if TranState = ImgFile then begin InitF; (*$I-*) Reset(F,concat(disk,name)); Ok := ioresult = 0; (*$I+*) write(chr(ff)); if Ok then begin writeln('LOADING THE IMAGE'); ImLd(Im,concat(disk,name)) end else begin writeln('FILE DOES NOT EXIST'); CursorOn; ScrollOn end end else writeln('Transfer type is not IMAGE') end{LoadIm}; (* ---------------------------------------------------- *) procedure EmptyBuff(var FileBuffer : BuffType; var Posn : integer ); { This procedure Empties the buffer } var i : integer; begin for i := 1 to BufEnd do FileBuffer[i] := chr(0); { set all to nulls } Posn := 1 { set the position at the begining } end{EmptyBuff}; (* ---------------------------------------------------- *) procedure FileInit; { This procedure initialises the unit, the disk is set up in the main program } begin EmptyBuff(FileBuf,BuffPosn); TranState := TxtFile; EOI := TranState <> ImgFile end{fInit}; (* ---------------------------------------------------- *) procedure CloseF; { This procedure closes the file, neatly. } var Blk,i : integer; s : string; Key : char; begin if Save then begin { we wish to save the file } case TranState of TxtFile : begin s := copy('',0,0); if (BuffPosn <= BufEnd) and (BuffPosn > 1) then begin for i := 1 to pred(BuffPosn) do begin s := concat(s,' '); s[Length(s)] := FileBuf[i] end; write(TF,s); end; Close(TF,Lock) end; ImgFile : begin if (BuffPosn > 1) and (YPosn >= 0) then begin Line.Origin.Y := YPosn; PutLine(Line,Im,FileBuf) end; EOI := True; write('DO YOU WISH TO SAVE THE IMAGE ? '); repeat read(KeyBoard,Key) until Key in ['Y','y','N','n']; if Key in ['Y','y'] then ImSve(Im,concat(disk,name)) end; CodeFile,BinFile : begin if BuffPosn > 1 then Blk := BlockWrite(F,FileBuf,1); Close(F,Lock); end end{case}; EmptyBuff(FileBuf,BuffPosn) end else begin { This makes sure the file will be closed } close(TF); close(F) end; CursorOn; ScrollON end{CloseF}; (* ---------------------------------------------------- *) function ReadOpenF; { This procedure opens the file for reading } var OK : boolean; Blk : integer; begin EmptyBuff(FileBuf,BuffPosn); EOI := TranState <> ImgFile; if TranState <> ImgFile then begin (*$I-*) reset(F,concat(disk,name)); OK := ioresult = 0; (*$I+*) if (State = TxtFile) then begin Blk := BlockRead(F,FileBuf,1); Blk := BlockRead(F,FileBuf,1) end end else begin{ this is an image file } OK := True; end; ReadOpenF := OK end{OpenF}; (* ---------------------------------------------------- *) function WriteOpenF; { This procedure opens the file for writing } var OK : boolean; Blk : integer; begin EmptyBuff(FileBuf,BuffPosn); (*$I-*) if TranState <> TxtFile then begin if TranState = ImgFile then begin write(chr(ff)); InitF; ClearIm(Im); OK := True end else begin rewrite(F,concat(disk,name)); OK := ioresult = 0 end end else begin ReWrite(TF,concat(disk,name)); OK := ioresult = 0 end; (*$I+*) WriteOpenF := OK end{OpenF}; (* ---------------------------------------------------- *) procedure SaveBuff; { This procedure empties the buffer into the current file } var Blk,i : integer; s : string; begin { If it is a text file then } if TranState = TxtFile then begin{ Insert a string ! } s := copy('',0,0); for i := 1 to pred(Posn) do begin s := concat(s,' '); s[Length(s)] := Buff[i] end; if NewLine then begin if Length(s) = 0 then writeln(TF) else writeln(TF,s) end else write(TF,s); EmptyBuff(Buff,Posn) end else{ insert the buffer as it is when full } if Posn > BufEnd then begin if TranState = ImgFile then begin if YPosn >= 0 then begin Line.Origin.Y := YPosn; PutLine(Line,Im,Buff); YPosn := YPosn -1 end else EOI := True; EmptyBuff(Buff,Posn) end else begin Blk := BlockWrite(F,Buff,1); EmptyBuff(Buff,Posn) end end end{SaveBuff}; (* ---------------------------------------------------- *) procedure ReadBuff; { This procedure fills the buffer from the file when necessary } var Blk : integer; begin if ((Posn <= 1) or (Posn > BufEnd)) and (not EOF(F)) and (TranState <> ImgFile) then begin Blk := BlockRead(F,Buff,1); Posn := 1 end else if ((Posn <=1) or (Posn > BufEnd)) and (TranState = ImgFile) then begin if YPosn >= 0 then begin Posn := 1; Line.Origin.Y := YPosn; GetLine(Line,Im,Buff); YPosn := YPosn - 1 end else EOI := True; end end{ReadBuff}; (* ---------------------------------------------------- *) end{FileHandle}. **** File BINUTILS.TEXT ******************************************************** { This contains the routines for eight bit quoting } (* ---------------------------------------------------- *) procedure Bbufemp(* var buffer : pakettype; Len : integer *); { procedure to empty the buffe into a file } var r : char; i : integer; begin i := 0; while i < Len do { while not at the end of packet do } begin r := buffer[i]; if (r = myquote) then { if myquote the a control char ? } begin{get quoted character} i := i + 1; r := buffer[i]; if (aand(ord(r),127) <> ord(myquote)) and (aand(ord(r),127) <> ord(mybquote)) then r := ctl(r) { controlify the character } end else if (r = myBquote) then { if mybquote then eight bit should be set } begin{get the binary character} i := i + 1; r := buffer[i]; if (aand(ord(r),127) = ord(myquote)) then { is a control char } begin i := i + 1; r := buffer[i]; if (aand(ord(r),127) <> ord(myquote)) and (aand(ord(r),127) <> ord(mybquote)) then r := ctl(chr(aand(ord(r),127))); end; r := chr(aand(ord(r),127) + 128) { add in eight bit } end else begin{get the normal character} r := chr(aand(ord(r),127)) end; i := i + 1; FileBuf[BuffPosn] := r; { put in the file buffer } BuffPosn := BuffPosn + 1; if BuffPosn > BufEnd then { if file buffer full then save it } SaveBuff(FileBuf,BuffPosn,False) end{while} end{Bbufemp}; (* ---------------------------------------------------- *) function Bbufill(*var buffer: packettype): integer*); { This fills a packet from the file } var i,j,k : integer; r : char; OK : boolean; begin OK := ((not eof(f)) and (TranState <> ImgFile)) or ((not EOI) and (TranState = ImgFile)); i := 0; (* while file has some data & packet has some room we'll keep going *) while ((buffposn <= bufend) or OK) and (i < spsiz-8) do begin ReadBuff(FileBuf,BuffPosn);(* while *) if (buffposn <= bufend) then (* if we're within buffer bounds *) begin r := filebuf[buffposn]; (* get a character *) buffposn := buffposn + 1; (* increase buffer pointer *) if ord(r) > 127 then begin{we have the eight bit set } buffer[i] := bquote; i := i + 1; r := chr(aand(ord(r),127));{ convert to 7 bit } if (r in ctlset) then begin buffer[i] := quote; i := i + 1; if (r <> quote) and (r <> bquote) then r := ctl(r); end end else if (r in ctlset) then (* if a control char *) begin buffer[i] := quote; (* put the quote in buffer *) i := i + 1; if (r <> quote) and (r <> bquote) then r := ctl(r); (* and un-controllify char *) end; buffer[i] := r; { update the buffer } i := i + 1; end; OK := ((not eof(f)) and (TranState <> ImgFile)) or ((not EOI) and (TranState = ImgFile)); end{while}; if (i = 0) then (* if we're at end of file, *) Bbufill := (at_eof) (* indicate it *) else (* else *) Bbufill := i (* return # of chars in packet *) end; (* Bbufill *) (* ---------------------------------------------------- *) **** File HANDLE.TEXT ********************************************************** .TITL HANDLER .PROC GETBUF < FUNCTION GETBUF( SOH, EOP, TIMEOUT : INTEGER; VAR S : STRING ):BOOLEAN; > ;-----------------------------------------------------------; ; ; ; written by H Balen March 1986 ; ; ; ; This is a microcode routine to receive a packet for the ; ; Magiscans KERMIT program. ; ; ; ; SOH = 'my_soh' start of packet ; ; EOP = 'my_eop' end of the packet ; ; TIMEOUT = number of loops before giving up ; ; S = the buffer in which to store the data ; ; ; ; ; ;-----------------------------------------------------------; .REG EOP .REG SOH .REG STRPTR .REG INDPSN .REG WPSN .REG CBYTE .REG VALUE .REG WRDPTR .REG TCOUNT .REG TIMOUT GETBUF: NOP :JSR DUMP2 ; Zero the count ZER TCOUNT :JSR ACPOP ; and the posn MOV AC,STRPTR :JSR ACPOP ; Set the string and word pointers MOV AC,TIMOUT :JSR ACPOP ; get wait MOV AC,EOP :JSR ACPOP ; get special characters MOV AC,SOH LAB1: ZER INDPSN MOV STRPTR,AC MOV AC,WRDPTR LOOP: INC TCOUNT ; check the time out MOV TIMOUT,AC SUB AC,COUNT,# MOV %0004,AC :JMP LEAVE ZR SUB AC,C16,RMSK ; check the status register MOV C255,AC :JSR STATSET AND IO(RS),C1,AC NOP :JMP LOOP NZ MOV %0038,IOA ; read the port MOV IO,AC AND AC,%7F,AC SUB AC,SOH,# ; check the special chars SUB AC,EOP,# :JMP LAB1 ZR MOV AC,CBYTE :JMP PEND ZR NOP :JSR STORUP ; store the byte NOP :JMP LOOP ; continue to loop PEND: MOV STRPTR,MAF ; routine to leave the microcode procedure MOV MM,AC ; store the length of the string AND AC,%FF00,AC MOV AC,VALUE MOV INDPSN,AC AND AC,%00FF,AC OR AC,VALUE,AC MOV AC,MM MOV C1,AC FEND: NOP :JSR ACPUSH NOP :JMP ENDIPC LEAVE: ZER AC :JMP FEND STORUP: INC INDPSN ; find the index MOV INDPSN,AC MOV WRDPTR,MAF AND AC,C1,# ; if the index is odd then store in high byte of word MOV MM,AC :JMP ODD NZ AND AC,%FF00,AC ; else store in the low byte MOV AC,VALUE MOV CBYTE,AC AND AC,%00FF,AC OR AC,VALUE,AC MOV AC,MM :RET ODD: AND AC,%00FF,AC ; store in high byte MOV AC,VALUE MOV CBYTE,AC AND AC(8L),%FF00,AC OR AC,VALUE,AC MOV AC,MM INC WRDPTR :RET **** File HELP.TEXT ************************************************************ segment procedure help; {UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U} { Adapted for the Magiscan 2 by H Balen, Lancaster U } procedure keypress; var ch: char; begin writeln; writeln('---------------Press any key to continue---------------'); repeat until readch(terminal,ch); writeln(chr(ff){clearscreen}) end; (* keypress *) procedure help1; var ch: char; begin write(chr(ff)); if (noun = nullsym) then begin writeln('KERMIT is a family of programs that do reliable file transfer'); writeln('between computers over TTY lines. KERMIT can also be used to '); writeln('make the microcomputer behave as a terminal for a mainframe. '); writeln('These are the commands for theUCSD p-system version, '); writeln('KERMIT-UCSD:'); writeln end; (* if *) if (noun = nullsym) or (noun = consym) then begin writeln(' CONNECT To make a "virutual terminal" connection to '); writeln(' a remote system. To break the connection and'); writeln(' "escape" back to the micro, type the escape '); writeln(' sequence (CTRL-] C, that is Control rightbracket'); writeln(' followed immediately by the letter C.)'); writeln; end; (* if *) if (noun = nullsym) or (noun = exitsym) then begin writeln(' EXIT To return back to main command level of the'); writeln(' p-system.'); writeln; end; (* if *) if (noun = nullsym) or (noun = helpsym) then begin writeln(' HELP To get a list of KERMIT commands.'); writeln; end; (* if *) if (noun = nullsym) or (noun = quitsym) then begin writeln(' QUIT Same as EXIT.'); writeln; end; (* if *) if (noun = nullsym) or (noun = recsym) then begin writeln(' RECEIVE To accept a file from the remote system.'); writeln; end; (* if *) end; (* help1 *) procedure help2; var ch : char; begin if (noun = nullsym) or (noun = loadsym) then begin writeln(' LOAD To load an image from the current disk.'); writeln; end; (* if *) if (noun = nullsym) or (noun = sendsym) then begin writeln(' SEND To send a file or group of files to the remote'); writeln(' system.'); writeln; end; (* if *) if (noun = nullsym) then keypress; end{help2}; procedure help3; var ch: char; begin if (noun = nullsym) or (noun = setsym) then begin writeln(' SET To establish system-dependent parameters. The '); writeln(' SET options are as follows: '); writeln; if (adj = nullsym) or (adj = baudsym) then begin writeln(' BAUD 75 to 9600, default is 1200. '); writeln(' This sets the baud rate for the'); writeln(' system, should be done before'); writeln(' a conect, and is a mutiple of'); writeln(' 75 by a power of two.'); writeln; end;{if} if (adj = nullsym) or (adj = debugsym) then begin writeln(' DEBUG To set debug mode ON or OFF '); writeln(' (default is OFF).'); writeln; end; (* if *) if (adj = nullsym) or (adj = dirsym) then begin writeln(' DISK 4/5/9/10, default is 5. This'); writeln(' sets the drive to be one of'); writeln(' the volumes/disks in existance'); writeln(' on the M2.'); writeln; end;{if} if (adj = nullsym) then keypress; end; (* if *) end; (* help3 *) procedure help4; begin if (noun = nullsym) or (noun = setsym) then begin if (adj = nullsym) or (adj = escsym) then begin writeln(' ESCAPE To change the escape sequence'); writeln(' that lets you return to the '); writeln(' PC Kermit from the remote host.'); writeln(' The default is CTRL-] c.'); writeln; end; (* if *) if (adj = nullsym) or (adj = filewarnsym) then begin writeln(' FILE-WARNING ON/OFF, default is OFF. If'); writeln(' ON, Kermit will warn you and'); writeln(' rename an incoming file so as'); writeln(' not to write over a file that'); writeln(' currently exists with the'); writeln(' same name'); writeln; end; (* if *) end; (* if *) end; (* help4 *) procedure help5; begin if (noun = setsym) or (noun = nullsym) then begin if (adj = nullsym) or (adj = ibmsym) then begin writeln(' IBM ON/OFF, default is OFF. This'); writeln(' flag should be ON only when '); writeln(' transfering files between the'); writeln(' micro and an IBM VM/CMS system.'); writeln(' It also causes the parity to be'); writeln(' set appropriately (mark) and '); writeln(' activates local echoing'); writeln; end; (* if *) if (adj = nullsym) then keypress; if (adj = nullsym) or (adj = localsym) then begin writeln(' LOCAL-ECHO ON/OFF, default is OFF. This'); writeln(' sets the duplex. It should be'); writeln(' ON when using the IBM and OFF '); writeln(' for the DEC-20.'); writeln; end; (* if *) end; (* if *) end; (* help5 *) procedure Help6; begin if (noun = setsym) or (noun = nullsym) then begin if (adj = nullsym) or (adj = paritysym) then begin writeln(' PARITY EVEN, ODD, MARK, SPACE, '); writeln(' or NONE. NONE is the default'); writeln(' but if the IBM flag is set, '); writeln(' parity is set to MARK. This '); writeln(' flag selects the parity for '); writeln(' outgoing and incoming '); writeln(' characters during CONNECT and'); writeln(' file transfer to match the'); writeln(' requirements of the host.'); writeln; end; (* if *) if (noun = paritysym) then KeyPress end{if}; if (noun = transym) or (noun = nullsym) then begin writeln(' TRANSFER To set the type of transfer, the types can '); writeln(' be TEXT, CODE, DATA, IMAGE. The format of the '); writeln(' command is TRANSFER TYPE '); writeln; if (noun = transym) then KeyPress; end; (* if *) end{help6}; procedure Help7; begin if (noun = nullsym) or (noun = showsym) then begin writeln(' SHOW To see the values of parameters that can be'); writeln(' modified via the SET command. Options are the'); writeln(' same as for SET, except that a SHOW ALL '); writeln(' command has been added.'); KeyPress; end; (* if *) end{Help7}; begin help1; help2; help3; help4; help5; help6; help7 end; (* help *) **** File KERMIT.TEXT ********************************************************** program kermit; {UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U} {Adapted to Pascal Microengine by Tim Shimeall, UCI} {Changes: - Added device declarations copied from Microengine hardware documentation - Replaced external assembly language routines with Pascal versions - Modified debug messages to be label values printed - Changed format of packetwrite display to show header fields - Implemented machine-dependent packet timeout - Added debug packetwrites in recsw - Added wrap-around debug info region - Added legality check in showparms - Removed lf elimination check in echo procedure - Unitwrite calls replaced by calls to device driving routines - Most uses of char_int_rec replaced by ord and chr - Removed queue (no interrupts) - Used sets for integer ops to getaround Microengine bug - Changed parser from a unit to a segment procedure to allow swapping - Split utility procs into separate files for editing and transfer convinience } {Adapted to Joyce Loebl's Magiscan 2 Image processing computer, by Henry Balen, Lancaster University } {Changes: - added ability for the parser to recognize digits, this enabled a Baudrate command to be implemented - added a command to set a work disk, set disk #. - The IO subroutines were put into an unit RS232 and changed to suit the Magiscan. - put the parser back into an unit since the Magiscan has 128K available. - modified the constants for the screen because the Magiscan only has 64 columns. - Added a unit SysUnit to enable the user to interogate the current work disk and delete files if so wishes. - Added a unit FileHandle which gives routines for accessing files for reading and writing, the old version of this didn't close a file if there was an unsuccessful receive/send this is now fixed. - Modified the Buffer empty and fill routines to use these. - Added the ability to do eight bit prefixing and the necessary routines for this. - Have added a new command called TRANSFER ( do a TRANSFER TYPE ), which enables transfers of image,data,code and text 'types'. - There is also image LOAD routine implemented, this allows the images to be loaded from disk and transfered to the Host straight from image memory. } { Futher changes by H Balen, now of Joyce Loebl, March 1986 } { - The receive packet routine has been put in the magiscan's microcode, data can now be succesfully received and transmitted at 9600 baud (except images ! max =4800 ), though the screen cannot scroll fast enough for incoming characters greater than 1200. - Two new options have been included - they are the MUX delay which tells the Magiscan how many cycles the wait when sending characters, and the option of using the winchester on #9. } (*$R-*) (* turn range checking off *) (*$S+*) (* turn swapping on *) (* $L PRINTER: *) (* no listing *) Uses M2Types,M2IpRoot,M2Sys, (*$U DISK.CODE*)DiskUnit, (*$U RS232.Code*)RS232, (*$U SysUnit.Code*)SysUnit, (*$U ParUnit.Code*)ParseUnit, (*$U FileUnit.Code*)FileHandle, (*$U HANDLE.CODE*)HANDLER; { the microcode } const blksize = 512; oport = 8; (* output port # *) (* clearscreen = 12; charcter which erases screen *) { bell = 7; } (* ASCII bell *) esc = 27; (* ASCII escape *) maxpack = 93; (* maximum packet size minus 1 *) soh = 1; (* start of header *) sp = 32; (* ASCII space *) cr = 13; (* ASCII CR *) lf = 10; (* ASCII line feed *) dle = 16; (* ASCII DLE (space compression prefix for psystem) *) del = 127; (* delete *) my_esc = 29; (* default esc char for connect (^]) *) maxtry = 5; (* number of times to retry sending packet *) my_quote = '#'; (* quote character I'll use *) my_bquote = '&'; { binary quate character I'll use } my_pad = 0; (* number of padding chars I need *) my_pchar = 0; (* padding character I need *) my_eol = 13; (* end of line character i need *) my_time = 5; (* seconds after which I should be timed out *) maxtim = 20; (* maximum timeout interval *) mintim = 2; (* minimum time out interval *) at_eof = -1; (* value to return if at eof *) eoln_sym = 13; (* pascal eoln sym *) back_space = 8; (* pascal backspace sym *) (* screen control information *) (* console line on which to put specified info *) title_line = 1; statusline = 2; packet_line = 3; retry_line = 4; file_line = 5; error_line = 6; prompt_line = 7; debug_line = 9; debug_max = 12; (* Max lines of debug to show at once *) (* position on line to put info *) statuspos = 54; packet_pos = 19; retry_pos = 17; file_pos = 11; Intsize = 15; type packettype = packed array[0..maxpack] of char; parity_type = (evenpar, oddpar, markpar, spacepar, nopar); char_int_rec = record (* allows character to be treated as integer... *) (* is system dependent *) case boolean of true: (i: integer); false: (ch: char) end; (* record *) int_bool_rec = record (* allows integer to be treated as boolean... *) (* used for numeric AND,OR,XOR...system dependent *) (* replaced by set version to escape microengine bug *) case boolean of true: (i: integer); false: (b: set of 0..intsize); end; (* record *) Port = (Terminal,Modem); var state: char; (* current state *) s: string; eol, bquote, quote, esc_char: char; fwarn, ibm, half_duplex, debug: boolean; delay, i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer; recpkt, packet: packettype; padchar, ch: char; debf: text; (* file for debug output *) debnext:0..7; (* offset for next debug message *) parity: parity_type; xon: char; vol, Baud: integer; parity_array: packed array[char] of char; ctlset: set of char; rec_ok, send_ok: boolean; function read_ch(p: port; var ch: char): boolean; forward; function aand(x,y: integer): integer; forward; function aor(x,y: integer): integer; forward; function xor(x,y: integer): integer; forward; procedure error(p: packettype; len: integer); forward; procedure ino_error(i: integer); forward; procedure debugwrite(s: string); forward; procedure debugint(s: string; i: integer); forward; procedure writescreen(s: string); forward; procedure refresh_screen(numtry, num: integer); forward; function min(x,y: integer): integer; forward; function tochar(ch: char): char; forward; function unchar(ch: char): char; forward; function ctl(ch: char): char; forward; function getfil(filename: string): boolean; forward; procedure Bbufemp(buffer: packettype; len: integer); forward; function Bbufill(var buffer: packettype): integer; forward; procedure bufemp(buffer: packettype; var f: text; len: integer); forward; function bufill(var buffer: packettype): integer; forward; procedure spar(var packet: packettype); forward; procedure rpar(var packet: packettype); forward; procedure spack(ptype: char; num:integer; len: integer; data: packettype); forward; function getch(var r: char; p: port): boolean; forward; function getsoh(p: port): boolean; forward; function rpack(var len, num: integer; var data: packettype): char; forward; procedure read_str(p: port; var s: string); forward; procedure packetwrite(p: packettype; len: integer); forward; procedure show_parms; forward; (*$I HELP.TEXT*) (* Segment Procedure Help *) (*$I SENDSW.TEXT*) (* Segment Procedure Sendsw *) (*$I RECSW.TEXT*) (* Segment Procedure Recsw *) (*$I UTILS.TEXT *) (* General Utility procedures *) (*$I BINUTILS.TEXT*) { Routines for Binary transfer } (*$I RSUTILS.TEXT *) (* Utility procedures for send and receive *) procedure connect; (* connect to remote host (terminal emulation *) var ch: char; close: boolean; procedure read_esc; (* read charcter after esc char and interpret it *) begin repeat until read_ch(terminal,ch); (* wait until they've typed something in *) if (ch in ['a'..'z']) then (* uppercase it *) ch := chr(ord(ch) - ord('a') + ord('A')); if ch in [{'B',}'C','S','D','?'] then begin writeln; case ch of (*'B': sendbrk; B: send a break to the IBM *) 'C': close := true; (* C: end connection *) 'S': begin (* S: show status *) noun := allsym; showparms end; (* S *) 'D':begin vol := ord(disk[2]) - ord('0'); if vol in [9,10] then writeln('Cannot DIR a Winchester') else PrintNames(vol,value) end; (* D *) '?': begin (* ?: show options *) (* writeln('B Send a BREAK signal.'); *) writeln('C Close Connection, return to '); writeln(' KERMIT-UCSD command level.'); writeln('S Show Status of connection'); writeln('D displays the current directory'); writeln('? Print this list'); write('^',ctl(esc_char),' send the escape '); writeln('character itself to the'); writeln(' remote host.'); end; (* ? *) end (* case *) end else if ch = esc_char then (* ESC-char: send it out *) begin if half_duplex then begin echo(ch); while not istbtr do; sndbbt(ch); end (* if *) end (* else if *) else (* anything else: ignore *) write(chr(bell)) end; (* read_esc *) begin (* connect *) writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit'); close := false; repeat if read_ch(modem,ch) then (* if char from host then *) echo(ch); (* echo it *) if read_ch(terminal,ch) then (* if char from keyboard then *) if ch <> esc_char then (* if not ESC-char then *) begin if half_duplex then (* echo it if half-duplex *) echo(ch); while not istbtr do; sndbbt(ch) (* send it out the port *) end (* if *) else (* ch = esc_char *) (* else is ESC-char so *) read_esc; (* interpret next char *) until close; (* if still connected, get more *) writeln('Disconnected') end; (* connect *) procedure fill_parity_array; (* parity value table for even parity...not(entry) = odd parity *) const min = 0; max = 126; var i, shifter, counter: integer; minch, maxch, ch: char; r: char_int_rec; begin minch := chr(min); maxch := chr(max); case parity of evenpar: begin for ch := minch to maxch do begin r.ch := ch; (* put char into variant record *) shifter := aand(r.i,255); (* mask off parity bit *) counter := 0; for i := 1 to 7 do (* count the 1's *) begin if odd(shifter) then counter := counter + 1; shifter := shifter div 2 end; (* for i *) if odd(counter) then (* stick a 1 on if necessary *) parity_array[ch] := chr(aor(ord(ch),128)) else parity_array[ch] := chr(aand(ord(ch),127)) end; (* for ch *) end; (* case even *) oddpar: begin for ch := minch to maxch do begin r.ch := ch; (* put char into variant record *) shifter := aand(r.i,255); (* mask off parity bit *) counter := 0; for i := 1 to 7 do (* count the 1's *) begin if odd(shifter) then counter := counter + 1; shifter := shifter div 2 end; (* for i *) if odd(counter) then (* stick a 1 on if necessary *) parity_array[ch] := chr(aand(ord(ch),127)) else parity_array[ch] := chr(aor(ord(ch),128)) end; (* for ch *) end; (* case odd *) markpar: for ch := minch to maxch do (* stick a 1 on all chars *) parity_array[ch] := chr(aor(ord(ch),128)); spacepar: for ch := minch to maxch do (* mask off parity on all chars *) parity_array[ch] := chr(aand(ord(ch),127)); nopar: for ch := minch to maxch do (* don't mess w/parity bit at all *) parity_array[ch] := ch; end; (* case *) end; (* fill_parity_array *) procedure write_bool(s: string; b: boolean); (* writes message & 'on' if b, 'off' if not b *) begin write(s); case b of true: writeln('on'); false: writeln('off'); end; (* case *) end; (* write_bool *) procedure writeTrans; { writes the transfer state } begin write('Transfer Type : '); case TranState of CodeFile : writeln('BINARY'); ImgFile : writeln('IMAGE'); TxtFile : writeln('TEXT'); "BinFile : writeln('DATA') end end{writeTrans}; procedure show_parms; (* shows the various settable parameters *) begin writeln; if noun in [allsym, debugsym, ibmsym, escsym, filewarnsym, muxsym, transym, disksym, localsym, baudsym, paritysym] then case noun of allsym: begin write_bool('Debugging is ',debug); writeln('Escape character is ^',ctl(esc_char)); write_bool('File warning is ',fwarn); write_bool('IBM is ',ibm); write_bool('Local echo is ',halfduplex); case parity of evenpar: write('Even'); markpar: write('Mark'); nopar: write('No'); oddpar: write('Odd'); spacepar: write('Space'); end; (* case *) writeln(' parity'); writeln('Baudrate is ',Baud); writeln('Drive is ',disk); writeln('MUX is ',MUXDelay); writetrans end; (* allsym *) debugsym: write_bool('Debugging is ',debug); escsym: writeln('Escape character is ^',ctl(esc_char)); filewarnsym: write_bool('File warning is ',fwarn); ibmsym: write_bool('IBM is ',ibm); localsym: write_bool('Local echo is ',halfduplex); baudsym : writeln('Baudrate is ',Baud); disksym : writeln('Drive is ',disk); transym : writetrans; muxsym : writeln('MUX is ',MUXDelay); paritysym: begin case parity of evenpar: write('Even'); markpar: write('Mark'); nopar: write('No'); oddpar: write('Odd'); end; writeln(' parity'); end; (* paritysym *) typesym : writetrans end (* case *) else write(chr(bell)); end; (* show_sym *) procedure set_parms; (* sets the parameters *) begin case noun of debugsym: case adj of onsym: begin debug := true; (*$I-*) rewrite(debf,'CONSOLE:') (*I+*) end; (* onsym *) offsym: debug := false end; (* case adj *) escsym: escchar := newescchar; filewarnsym: fwarn := (adj = onsym); ibmsym: case adj of onsym: begin ibm := true; parity := markpar; half_duplex := true; fillparityarray end; (* onsym *) offsym: begin ibm := false; parity := nopar; half_duplex := false; fillparityarray end; (* onsym *) end; (* case adj *) localsym: halfduplex := (adj = onsym); paritysym: begin case adj of evensym: parity := evenpar; marksym: parity := markpar; nonesym: parity := nopar; oddsym: parity := oddpar; spacesym: parity := spacepar; end; (* case *) fill_parity_array; end; (* paritysym *) MUXsym : begin MUXDelay := value end (* baudsym *); baudsym : begin Baud := value; BaudRate(Baud) end (* baudsym *); disksym : begin if value in [4,5,9] then begin disk := ' '; disk[1] := chr(ord('0')+value); disk := concat('#',disk); disk := concat(disk,':') end else writeln('Drive does not exist ') end (* disksym *) end; (* case *) end; (* set_parms *) procedure initialize; var ch: char; begin pad := mypad; padchar := chr(mypchar); eol := chr(my_eol); esc_char := chr(my_esc); quote := my_quote; bquote := my_bquote; ctlset := [chr(1)..chr(31),chr(del),quote,bquote]; TranState := TxtFile; TimInt := My_Time; half_duplex := false; debug := false; debnext:=0; fwarn := false; spsiz := max_pack; rpsiz := max_pack; n := 0; parity := nopar; initvocab; fill_parity_array; ibm := false; xon := chr(17); {bufpos := 1;} initM; Baud := 1200; FileInit; value := 0; disk := '#5:' end; (* initialize *) procedure closeup; begin writeln(chr(ff){clearscreen}); end; (* closeup *) begin (* kermit *) initialize; { Load in the microcode } OVLYLOAD('HANDLE'); repeat write('Kermit-UCSD> '); readstr(terminal,line); case parse of unconfirmed: writeln('Unconfirmed'); parm_expected: writeln('Parameter expected'); ambiguous: writeln('Ambiguous'); unrec: writeln('Unrecognized command'); fn_expected: writeln('File name expected'); ch_expected: writeln('Single character expected'); null: case verb of consym: connect; helpsym: help; Loadsym: begin uppercase(filename); LoadIm(filename) end; recsym: begin recsw(rec_ok); gotoxy(0,debugline); write(chr(bell)); if rec_ok then writeln('successful receive') else writeln('unsuccessful receive'); gotoxy(0,promptline); end; (* recsym *) sendsym: begin uppercase(filename); sendsw(send_ok); gotoxy(0,debugline); write(chr(bell)); if send_ok then writeln('successful send') else writeln('unsuccessful send'); (*$I-*) (* set i/o checking off *) closeF(filename,False); (*$I+*) (* set i/o checking back on *) gotoxy(0,promptline); end; (* sendsym *) delsym: begin uppercase(filename); vol := ord(disk[2]) - ord('0'); Delfile(filename,vol) end; (* delsym *) setsym: set_parms; transym: begin if noun = Typesym then case adj of binsym : TranState := CodeFile; datasym : TranState := BinFile; textsym : TranState := TxtFile; imagesym : TranState := ImgFile; end else write(Bell) end; show_sym: show_parms; dirsym : begin vol := ord(disk[2]) - ord('0'); if vol in [9,10] then writeln('Cannot DIR a Winchester') else PrintNames(vol,value) end (* dirsym *) end; (* case verb *) end; (* case parse *) { unitclear(1); }(* clear any trash in input *) { unitclear(2); } (* Don't clear the screen ! *) until (verb = exitsym) or (verb = quitsym); closeup end.(* kermit *) **** File PARUNIT.TEXT ********************************************************* (*$R-*) (* turn range checking off *) (*$S+*) (* turn swapping on *) (* $L+*) (* no listing *) Unit ParseUnit; { This is a unit because the magiscan does have enough memory to hold it without swapping } Interface Uses M2Types,M2IpRoot,M2Sys; (* Parser Types *) type statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous, unrec, fn_expected, ch_expected); vocab = (nullsym, zerosym, onesym, twosym, threesym, foursym, fivesym, sixsym, sevensym, eightsym, ninesym, allsym, baudsym, binsym, consym, datasym, debugsym, delsym, dirsym, disksym, escsym, evensym, exitsym, filewarnsym, helpsym, ibmsym, imagesym, loadsym, localsym, marksym, muxsym, nonesym, oddsym, offsym, onsym, paritysym, quitsym, recsym, sendsym, setsym, showsym, spacesym, textsym, transym, typesym ); (* Parser vars *) var noun, verb, adj : vocab; status : statustype; vocablist : array[vocab] of string[13]; value : integer; filename, line : string; newescchar : char; expected : set of vocab; procedure uppercase(var s: string); procedure initvocab; function parse: statustype; Implementation (* ---------------------------------------------------- *) procedure uppercase; var i: integer; begin for i := 1 to length(s) do if s[i] in ['a'..'z'] then s[i] := chr(ord(s[i]) - ord('a') + ord('A')) end; (* uppercase *) (* ---------------------------------------------------- *) function parse; type states = (start, fin, get_filename, get_set_parm, get_parity, get_on_off, get_char, get_show_parm, get_help_show, get_help_parm, get_value, exitstate, get_trans, get_type); var status: statustype; word: vocab; state: states; procedure eatspaces(var s: string); var done: boolean; i: integer; begin done := (length(s) = 0); while not done do begin if s[1] = ' ' then begin i := length(s) - 1; s := copy(s,2,i); done := length(s) = 0 end (* if *) else done := true end (* while *) end; (* eatspaces *) procedure isolate_word(var line, s: string); var i: integer; done: boolean; begin done := false; i := 1; s := copy(' ',0,0); while (i <= length(line)) and not done do begin if line[i] = ' ' then done := true else s := concat(s,copy(line,i,1)); i := i + 1; end; (* while *) line := copy(line,i,length(line)-i+1); end; (* isolate_word *) function get_fn(var line, fn: string): boolean; var i, l: integer; begin get_fn := true; isolate_word(line, fn); l := length(fn); if (l < 1) then get_fn := false end; (* get_fn *) function getch(var ch: char): boolean; var s: string; begin isolate_word(line,s); if length(s) <> 1 then getch := false else begin ch := s[1]; get_ch := true end (* else *) end; (* getch *) function get_sym(var word: vocab): statustype; var i: vocab; s: string; stat: statustype; done: boolean; matches: integer; begin eat_spaces(line); if length(line) = 0 then getsym := ateol else begin stat := null; done := false; isolate_word(line,s); i := allsym; matches := 0; repeat if (pos(s,vocablist[i]) = 1) and (i in expected) then begin matches := matches + 1; word := i end else if (s[1] < vocablist[i,1]) then done := true; if (i = typesym) then done := true else i := succ(i) until (matches > 1) or done; if matches > 1 then stat := ambiguous else if (matches = 0) then stat := unrec; getsym := stat end (* else *) end; (* getsym *) function get_val(var value : integer): statustype; var i: vocab; s: string; stat: statustype; gotval,done: boolean; function NewVal(Value : integer; S : vocab ) : integer; begin case S of zerosym : NewVal := Value * 10 + 0; onesym : NewVal := Value * 10 + 1; twosym : NewVal := Value * 10 + 2; threesym : NewVal := Value * 10 + 3; foursym : NewVal := Value * 10 + 4; fivesym : NewVal := Value * 10 + 5; sixsym : NewVal := Value * 10 + 6; sevensym : NewVal := Value * 10 + 7; eightsym : NewVal := Value * 10 + 8; ninesym : NewVal := Value * 10 + 9 end{case} end{NewVal}; function NextDigit : boolean; var i : integer; begin if length(s) <= 1 then NextDigit := False else begin i := length(s) - 1; s := copy(s,2,i); NextDigit := True end end{NextDigit}; begin eat_spaces(line); if length(line) = 0 then getval := ateol else begin stat := null; done := false; isolate_word(line,s); value := 0; repeat GotVal := False; for i := zerosym to ninesym do if (s[1] = vocablist[i][1]) then begin Value := NewVal(value,i); GotVal := True end; if not GotVal then begin stat := unrec; done := True end else done := not NextDigit until done; getval := stat end (* else *) end; (* getval *) begin state := start; parse := null; noun := nullsym; verb := nullsym; adj := nullsym; uppercase(line); repeat case state of start: begin expected := [consym, exitsym, helpsym, quitsym, recsym, delsym, dirsym, sendsym, setsym, showsym, transym, loadsym]; status := getsym(verb); if status = ateol then begin parse := null; exit(parse) end (* if *) else if (status <> unrec) and (status <> ambiguous) then case verb of dirsym, consym: state := fin; exitsym, quitsym: state := fin; helpsym: state := get_help_parm; recsym: state := fin; loadsym, delsym, sendsym: state := getfilename; setsym: state := get_set_parm; showsym: state := get_show_parm; transym: state := get_trans; end (* case *); end; (* case start *) fin: begin expected := []; status := getsym(verb); if status = ateol then begin parse := null; exit(parse) end (* if status *) else status := unconfirmed end; (* case fin *) getfilename: begin expected := []; if getfn(line,filename) then begin status := null; state := fin end (* if *) else status := fnexpected end; (* case get file name *) get_trans: begin expected := [typesym]; status := getsym(noun); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then case noun of typesym: state := get_type; end (* case *) end; (* case get_set_parm *) get_set_parm: begin expected := [paritysym, localsym, ibmsym, escsym, muxsym, disksym, debugsym, filewarnsym, baudsym]; status := getsym(noun); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then case noun of paritysym: state := get_parity; localsym: state := get_on_off; ibmsym: state := get_on_off; escsym: state := getchar; debugsym: state := getonoff; filewarnsym: state := getonoff; muxsym, baudsym : state := getvalue; disksym : state := getvalue; transym : state := get_on_off; end (* case *) end; (* case get_set_parm *) get_type: begin expected := [binsym, datasym, imagesym, textsym]; status := getsym(adj); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then state := fin end; (* case get_parity *) get_parity: begin expected := [marksym, spacesym, nonesym, evensym, oddsym]; status := getsym(adj); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then state := fin end; (* case get_parity *) get_value: begin expected := [zerosym, onesym, twosym, threesym, foursym, fivesym, sixsym, sevensym, eightsym, ninesym]; status := getval(value); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then state := fin end; (* get_speed *) get_on_off: begin expected := [onsym, offsym]; status := getsym(adj); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then state := fin end; (* get_on_off *) get_char: if getch(newescchar) then state := fin else status := ch_expected; get_show_parm: begin expected := [allsym, paritysym, localsym, ibmsym, escsym, muxsym, transym, disksym, baudsym, debugsym, filewarnsym]; status := getsym(noun); if status = ateol then status := parm_expected else if (status <> unrec) and (status <> ambiguous) then state := fin end; (* case get_show_parm *) get_help_show: begin expected := [paritysym, localsym, ibmsym, escsym, debugsym, filewarnsym]; status := getsym(adj); if (status = at_eol) then begin status := null; state := fin end else if (status <> unrec) and (status <> ambiguous) then state := fin end; (* case get_help_show *) get_help_parm: begin expected := [consym, delsym, exitsym, helpsym, quitsym, recsym, dirsym, transym, sendsym, setsym, showsym]; status := getsym(noun); if status = ateol then begin parse := null; exit(parse) end; if (status <> unrec) and (status <> ambiguous) then case noun of consym: state := fin; sendsym: state := fin; recsym: state := fin; setsym: state := get_help_show; showsym: state := fin; helpsym: state := fin; exitsym, quitsym: state := fin; end (* case *) end; (* case get_help_show *) end (* case *) until (status <> null); parse := status end; (* parse *) (* ---------------------------------------------------- *) procedure initvocab; var i: integer; begin vocablist[zerosym] := '0'; vocablist[onesym] := '1'; vocablist[twosym] := '2'; vocablist[threesym] := '3'; vocablist[foursym] := '4'; vocablist[fivesym] := '5'; vocablist[sixsym] := '6'; vocablist[sevensym] := '7'; vocablist[eightsym] := '8'; vocablist[ninesym] := '9'; vocablist[allsym] := 'ALL'; vocablist[baudsym] := 'BAUDRATE'; vocablist[binsym] := 'BINARY'; vocablist[consym] := 'CONNECT'; vocablist[datasym] := 'DATA'; vocablist[debugsym] := 'DEBUG'; vocablist[delsym] := 'DELETE'; vocablist[dirsym] := 'DIRECTORY'; vocablist[disksym] := 'DISK'; vocablist[escsym] := 'ESCAPE'; vocablist[evensym] := 'EVEN'; vocablist[exitsym] := 'EXIT'; vocablist[filewarnsym] := 'FILE-WARNING'; vocablist[helpsym] := 'HELP'; vocablist[ibmsym] := 'IBM'; vocablist[imagesym] := 'IMAGE'; vocablist[loadsym] := 'LOAD'; vocablist[localsym] := 'LOCAL-ECHO'; vocablist[marksym] := 'MARK'; vocablist[muxsym] := 'MUX'; vocablist[nonesym] := 'NONE'; vocablist[oddsym] := 'ODD'; vocablist[offsym] := 'OFF'; vocablist[onsym] := 'ON'; vocablist[paritysym] := 'PARITY'; vocablist[quitsym] := 'QUIT'; vocablist[recsym] := 'RECEIVE'; vocablist[sendsym] := 'SEND'; vocablist[setsym] := 'SET'; vocablist[showsym] := 'SHOW'; vocablist[spacesym] := 'SPACE'; vocablist[transym] := 'TRANSFER'; vocablist[textsym] := 'TEXT'; vocablist[typesym] := 'TYPE'; end; (* initvocab *) (* ---------------------------------------------------- *) end{Parse}. **** File RECSW.TEXT *********************************************************** (* RECEIVE SECTION *) {UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U} {Modified for the Magiscan 2 by H Balen, Lancaster U } segment procedure recsw(var rec_ok: boolean); function rdata: char; (* send file data *) var Blk, num, len: integer; ch: char; begin repeat if numtry > maxtry then begin debugwrite('too many intial retries in rdata'); state := 'a'; exit(rdata) end; num_try := num_try + 1; ch := rpack(len,num,recpkt); (* receive a packet *) if debug and (ch<>chr(0)) then packetwrite(recpkt,len); refresh_screen(numtry,n); if (ch = 'D') then (* got data packet *) begin if (num <> (n mod 64)) then (* wrong packet *) begin if (oldtry > maxtry) then begin debugwrite('too many data retries in rdata'); rdata := 'a'; (* too many tries, abort *) exit(rdata) end; (* if *) n := n - 1; if (num = (n mod 64)) then (* previous packet again *) begin (* so re-ACK it *) debugint('re-acking ',num); spack('Y',num,6,packet); numtry := 0; (* reset try counter *) (* stay in same state *) end (* if *) else begin (* wrong number *) debugwrite('wrong data sequence no. in rdata'); state := 'a' (* so abort *) end end (* if *) else (* right packet *) begin if TranState = TxtFile then bufemp(recpkt,f,len) (* write data to file *) else Bbufemp(recpkt,len); spack('Y',(n mod 64),0,packet); (* ACK packet *) oldtry := numtry; (* reset try counters *) if numtry > 1 then if istbrr then (* clear buffer *) begin ch:=rcvbbt; ch:='D'; end; numtry := 0; n := n + 1 (* bump packet number *) (* stay in data send state *) end (* else *) end (* if 'D' *) else if (ch = 'F') then (* file header *) begin if (oldtry > maxtry) then begin debugwrite('too many file head tries in rdata'); rdata := 'a'; (* too many tries, abort *) exit(rdata) end; (* if *) n := n - 1; if (num = (n mod 64)) then (* previous packet again *) begin (* so re-ACK it *) debugint('re-acking file header ',num); spack('Y',num,0,packet); if istbrr then begin ch:=rcvbbt; (* and empty out buffer *) ch:='F'; end; numtry := 0; (* reset try counter *) state := state; (* stay in same state *) end (* if *) else begin debugwrite('file info not previous packet in rdata'); state := 'a' (* not previous packet, abort *) end end (* if 'F' *) else if (ch = 'Z') then (* end of file *) begin if (num <> (n mod 64)) then(* wrong packet, abort *) begin debugwrite('wrong eof packet in rdata'); rdata := 'a'; exit(rdata) end; (* if *) spack('Y',n mod 64,0,packet); (* ok, ACK it *) { CloseF(filename,True); } n := n + 1; (* bump packet counter *) state := 'b'; (* go to break state *) oldtry := numtry; numtry := 0; end (* else if 'Z' *) else if (ch = 'E') then (* error packet *) begin error(recpkt,len); (* display error *) state := 'a' (* and abort *) end (* if 'E' *) else if (ch <> chr(0)) then begin (* some other packet type, *) state := 'a'; (* abort *) debugwrite('wierd rdata packet'); end until (state <> 'd'); rdata := state end; (* rdata *) function rfile: char; (* receive file header *) var num, len: integer; ch: char; oldfn: string; i: integer; procedure makename(recpkt: packettype; var fn: string; l: integer); function exist(fn: string): boolean; (* returns true if file named fn exists *) var f: file; OK : boolean; begin (*$I-*) (* turn off i/o checking *) reset(f,concat(disk,fn)); OK := (ioresult = 0); if OK then close(f); Exist := OK (*$I+*) end; (* exist *) procedure checkname(var fn: string); (* if file fn exists, makes a new name which doesn't *) (* does this by changing letters in file name until it *) (* finds some combination which doesn't exitst *) var ch: char; i: integer; begin i := 1; while (i <= length(fn)) and exist(fn) do begin ch := 'A'; while (ch in ['A'..'Z']) and exist(fn) do begin fn[i] := ch; ch := succ(ch); end; (* while *) i := i + 1 end; (* while *) end; (* checkname *) begin (* makename *) fn := copy(' ',1,15); (* stretch length *) moveleft(recpkt[0],fn[1],l); (* get filename from packet *) oldfn := copy(fn, 1,l); (* save fn sent to show user *) fn := copy(fn,1,min(15,l)); (* set length of filename *) (* and make sure <= 15 *) uppercase(fn); { if length(fn) > 10 then fn := copy(fn,1,10); (* can only be 15 long in all *) } if TranState = TxtFile then begin if pos('.TEXT',fn) <> (length(fn)-4) then begin if length(fn) > 10 then fn := copy(fn,1,10); (* can only be 15 long in all *) fn := concat(fn,'.TEXT'); (* and we'll add .TEXT *) end; (* if *) end else if TranState = CodeFile then begin{ Same as above except this is a code file } if pos('.CODE',fn) <> (length(fn)-4) then begin if length(fn) > 10 then fn := copy(fn,1,10); fn := concat(fn,'.CODE') end end else begin { Same as last two but this is a data file } if pos('.DATA',fn) <> (length(fn)-4) then begin if length(fn) > 10 then fn := copy(fn,1,10); fn := concat(fn,'.DATA') end; end; if fwarn then (* if file warning is on *) checkname(fn); (* must check that name unique *) end; (* makename *) begin (* rfile *) if debug then debugwrite('rfile'); if (numtry > maxtry) then (* if too many tries, give up *) begin rfile := 'a'; exit(rfile) end; numtry := numtry + 1; ch := rpack(len,num,recpkt); (* receive a packet *) if debug and (ch<>chr(0)) then packetwrite(recpkt,len); refresh_screen(numtry,n); if ch = 'S' then (* send init, maybe our ACK lost *) begin if (oldtry > maxtry) then (* too many tries, abort *) begin debugwrite('too many tries in rfile init'); rfile := 'a'; exit(rfile) end; (* if *) n := n - 1; if num = (n mod 64) then (* previous packet mod 64? *) begin (* yes, ACK it again *) debugint('re-acking init ',num); spar(packet); (* with our send init params *) spack('Y',num,7,packet); numtry := 0; (* reset try counter *) rfile := state; (* stay in same state *) end (* if *) else (* not previous packet, abort *) state := 'a' end (* if 'S' *) else if (ch = 'Z') then (* end of file *) begin if (oldtry > maxtry) then (* too many tries, abort *) begin debugwrite('too many tries in filehead eof'); rfile := 'a'; exit(rfile) end; (* if *) n := n - 1; if num = (n mod 64) then (* previous packet mod 64? *) begin (* yes, ACK it again *) debugint('re-acking eof ',num); spack('Y',num,0,packet); numtry := 0; rfile := state (* stay in same state *) end (* if *) else rfile := 'a' (* no, abort *) end (* else if *) else if (ch = 'F') then (* file header *) begin (* which is what we really want *) if (num <> (n mod 64)) then (* if wrong packet, abort *) begin debugwrite('wrong seq. of file header'); rfile := 'a'; exit(rfile) end; makename(recpkt,filename,len); (* get filename, make unique if filew *) gotoxy(filepos,fileline); write(oldfn,' ==> ',filename); if not getfil(filename) then (* try to open new file *) begin inoerror(ioresult); (* if unsuccessful, tell them *) rfile := 'a'; (* and abort *) exit(rfile) end; (* if *) spack('Y',n mod 64,0,packet); (* ACK file header *) oldtry := numtry; (* reset try counters *) numtry := 0; n := n + 1; (* bump packet number *) rfile := 'd'; (* switch to data state *) end (* else if *) else if ch = 'B' then (* break transmission *) begin if (num <> (n mod 64)) then (* wrong packet, abort *) begin debugwrite('wrong sequence in break packet'); rfile := 'a'; exit(rfile) end; spack('Y',n mod 64,0,packet); (* say ok *) rfile := 'c' (* go to complete state *) end (* else if *) else if (ch = 'E') then begin error(recpkt,len); rfile := 'a' end else if (ch = chr(0)) then (* returned false *) rfile := state (* so stay in same state *) else begin (* some weird state, so abort *) rfile := 'a'; debugwrite('wierd rfile packet'); end end; (* rfile *) function rbreak: char; (* receive file header *) var num, len: integer; ch: char; i: integer; begin (* rbreak *) if debug then debugwrite('rbreak'); if (numtry > maxtry) then (* if too many tries, give up *) begin rbreak := 'a'; exit(rbreak) end; numtry := numtry + 1; ch := rpack(len,num,recpkt); (* receive a packet *) if debug and (ch<>chr(0)) then packetwrite(recpkt,len); refresh_screen(numtry,n); if (ch = 'Z') then begin{ is previous eof packet } n := n -1; if (num = (n mod 64)) then (* previous packet again *) begin (* so re-ACK it *) debugint('re-acking ',num); spack('Y',num,6,packet); numtry := 0; (* reset try counter *) (* stay in same state *) end (* if *) else begin (* wrong number *) debugwrite('wrong data sequence no. in rbreak'); state := 'a' (* so abort *) end end else if ch = 'B' then (* break transmission *) begin if (num <> (n mod 64)) then (* wrong packet, abort *) begin debugwrite('wrong sequence in break packet'); rbreak := 'a'; exit(rbreak) end; spack('Y',n mod 64,0,packet); (* say ok *) rbreak := 'c' (* go to complete state *) end (* else if *) else if (ch = 'E') then begin error(recpkt,len); rbreak := 'a' end else if (ch = chr(0)) then (* returned false *) rbreak := state (* so stay in same state *) else begin (* some weird state, so abort *) rbreak := 'a'; debugwrite('wierd break packet'); end end; (* rbreak *) function rinit: char; (* receive initialization *) var num, len: integer; (* packet number and length *) ch: char; begin if debug then debugwrite('rinit'); numtry := numtry + 1; ch := rpack(len,num,recpkt); (* receive a packet *) if debug and (ch<>chr(0)) then packetwrite(recpkt,len); refresh_screen(num_try,n); if (ch = 'S') then (* send init packet *) begin rpar(recpkt); (* get other side's init data *) spar(packet); (* fill packet with my init data *) if TranState <> TxtFile then ctl_set := [chr(1)..chr(31),chr(del),quote,bquote] else ctl_set := [chr(1)..chr(31),chr(del),quote]; spack('Y',n mod 64,7,packet); (* ACK with my params *) oldtry := numtry; (* save old try count *) numtry := 0; (* start a new counter *) n := n + 1; (* bump packet number *) rinit := 'f'; (* enter file send state *) end (* if 'S' *) else if (ch = 'E') then begin rinit := 'a'; error(recpkt,len) end (* if 'E' *) else if (ch = chr(0)) then rinit := 'r' (* stay in same state *) else begin rinit := 'a'; (* abort *) debugwrite('wierd rinit packet'); end end; (* rinit *) (* state table switcher for receiving packets *) begin (* recswok *) writescreen('Receiving'); state := 'r'; (* initial state is send *) n := 0; (* set packet # *) numtry := 0; (* no tries yet *) while true do if state in ['d', 'f', 'r', 'c', 'a', 'b'] then case state of 'd': state := rdata; 'f': state := rfile; 'r': state := rinit; 'b': state := rbreak; 'c': begin rec_ok := true; CloseF(filename,true); exit(recsw) end; (* case c *) 'a': begin rec_ok := false; CloseF(filename,false); exit(recsw) end (* case a *) end (* case *) else (* state not in legal states *) begin rec_ok := false; CloseF(filename,False); exit(recsw) end (* else *) end; (* recsw *) **** File RS232.TEXT *********************************************************** (*$S+*) { This unit contains the subroutines necessary for accessing/using the RS232 interface of the Magiscan } Unit RS232; { Written by H Balen 1-Aug-85 } { Modified by H Balen 23-Sep-85 } Interface Uses M2Types,M2IpRoot,M2Sys; var MuxDelay : integer; procedure InitM; function ISTATR : boolean; function ISTBRR : boolean; function ISTBOR : boolean; function ISTBFE : boolean; function ISTBTR : boolean; procedure SNDBBT( BT : char ); procedure SNDABT( BT : char ); function RCVBBT : Char; Implementation { All the routines below have the same function as those in the text file WDPROCS for the UCM version of kermit } const RxBit = 4; TxBit = 5; Uart = 56; Control = 57; Status = 57; { RS232 dependant constants for the status registar } OverError = 4; FrameError = 5; type RegByte = record case Boolean of True : ( Value : integer ); (* ---------------------------------------------------- *) function ISTBOR; { Is it true that data OverRun occurred ?,} var Byte : RegByte; begin Byte.Value := IORead(Status); ISTBOR := Byte.B[OverError] end{ISTBOR}; (* ---------------------------------------------------- *) function ISTBFE; { Is it true that Framing-Error occured? } var Byte : RegByte; begin Byte.Value := IORead(Status); ISTBFE := Byte.B[FrameError] end{ISTBFE}; (* ---------------------------------------------------- *) function ISTBTR; { Is it true that transmit is ready ? } begin ISTBTR := not IOStatus(TxBit) end{ISTBR}; (* ---------------------------------------------------- *) procedure InitM; { This initialises the RS232 port } begin IOWrite(64,Control); { Internal Reset } IOWrite(78,Control); { Set the mode } IOWrite(55,Control); { Error Reset } BaudRate(1200); MuxDelay := 0; end{RSInit}; (* ---------------------------------------------------- *) procedure SNDBBT; { After getting back a TRUE result from isttr, this function SNDBBT is used to actually send the byte of data from the CPU to the device. Note that any attempt to call SNDBBT before getting TRUE from isttr can result in clobering the previous data } var i : integer; begin for i := 0 to (10 * MuxDelay) do; {[UnitWrite(8,i,1);} IOWrite(ord(BT),Uart); end{SendToUART}; (* ---------------------------------------------------- *) procedure SNDABT; { Same as the SNDBBT except this is for the keyboard } const Ret = 13; LF = 10; begin if ord(BT) <> Ret then if ord(BT) = LF then{ If we have a LF then } write(chr(Ret)) { send a CR instead } else write(BT) { else send the character itself } end{SNABT}; (* ---------------------------------------------------- *) function RCVBBT; var Ch : char; begin RCVBBT := chr( IORead(Uart) ) {UnitRead(7,Ch,1); RCVBBT := Ch} end{RxUART}; (* ---------------------------------------------------- *) end{RS232}. **** File RSUTILS.TEXT ********************************************************* (*$S+*) { This unit contains the subroutines necessary for accessing/using the RS232 interface of the Magiscan } Unit RS232; { Written by H Balen 1-Aug-85 } { Modified by H Balen 23-Sep-85 } Interface Uses M2Types,M2IpRoot,M2Sys; var MuxDelay : integer; procedure InitM; function ISTATR : boolean; function ISTBRR : boolean; function ISTBOR : boolean; function ISTBFE : boolean; function ISTBTR : boolean; procedure SNDBBT( BT : char ); procedure SNDABT( BT : char ); function RCVBBT : Char; Implementation { All the routines below have the same function as those in the text file WDPROCS for the UCM version of kermit } const RxBit = 4; TxBit = 5; Uart = 56; Control = 57; Status = 57; { RS232 dependant constants for the status registar } OverError = 4; FrameError = 5; type RegByte = record case Boolean of True : ( Value : integer ); (* ---------------------------------------------------- *) function ISTBOR; { Is it true that data OverRun occurred ?,} var Byte : RegByte; begin Byte.Value := IORead(Status); ISTBOR := Byte.B[OverError] end{ISTBOR}; (* ---------------------------------------------------- *) function ISTBFE; { Is it true that Framing-Error occured? } var Byte : RegByte; begin Byte.Value := IORead(Status); ISTBFE := Byte.B[FrameError] end{ISTBFE}; (* ---------------------------------------------------- *) function ISTBTR; { Is it true that transmit is ready ? } begin ISTBTR := not IOStatus(TxBit) end{ISTBR}; (* ---------------------------------------------------- *) procedure InitM; { This initialises the RS232 port } begin IOWrite(64,Control); { Internal Reset } IOWrite(78,Control); { Set the mode } IOWrite(55,Control); { Error Reset } BaudRate(1200); MuxDelay := 0; end{RSInit}; (* ---------------------------------------------------- *) procedure SNDBBT; { After getting back a TRUE result from isttr, this function SNDBBT is used to actually send the byte of data from the CPU to the device. Note that any attempt to call SNDBBT before getting TRUE from isttr can result in clobering the previous data } var i : integer; begin for i := 0 to (10 * MuxDelay) do; {[UnitWrite(8,i,1);} IOWrite(ord(BT),Uart); end{SendToUART}; (* ---------------------------------------------------- *) procedure SNDABT; { Same as the SNDBBT except this is for the keyboard } const Ret = 13; LF = 10; begin if ord(BT) <> Ret then if ord(BT) = LF then{ If we have a LF then } write(chr(Ret)) { send a CR instead } else write(BT) { else send the character itself } end{SNABT}; (* ---------------------------------------------------- *) function RCVBBT; var Ch : char; begin RCVBBT := chr( IORead(Uart) ) {UnitRead(7,Ch,1); RCVBBT := Ch} end{RxUART}; (* ---------------------------------------------------- *) end{RS232}. **** File SENDSW.TEXT ********************************************************** (* Send Section *) {UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U} { adapted by H Balen for the Magiscan 2, Lancaster U } segment procedure sendsw(var send_ok: boolean); var io_status: integer; procedure openfile; (* resets file & gets past first 2 blocks *) var OK : boolean; begin OK := ReadOpenF(filename,TranState); io_status := io_result; end; (* openfile *) function sinit: char; (* send init packet & receive other side's *) var num, len, i: integer; (* packet number and length *) ch: char; begin if debug then debugwrite('sinit'); if numtry > maxtry then begin sinit := 'a'; exit(sinit) end; num_try := num_try + 1; spar(packet); if istbrr then ch:=rcvbbt; (* clear modem buffer *) refresh_screen(numtry,n); spack('S',n mod 64,7,packet); ch := rpack(len,num,recpkt); if (ch = 'N') then begin sinit := 's'; exit(sinit) end (* if 'N' *) else if (ch = 'Y') then begin if ((n mod 64) <> num) then (* not the right ack *) begin sinit := state; exit(sinit) end; rpar(recpkt); if (eol = chr(0)) then (* if they didn't spec eol *) eol := chr(my_eol); (* use mine *) if (quote = chr(0)) then (* if they didn't spec quote *) quote := my_quote; (* use mine *) ctl_set := [chr(1)..chr(31),chr(del),quote]; if TranState <> TxtFile then begin if (bquote = 'Y') then bquote := my_bquote; ctl_set := [chr(1)..chr(31),chr(del),quote,bquote]; end; numtry := 0; n := n + 1; (* increase packet number *) sinit := 'f'; exit(sinit) end (* else if 'Y' *) else if (ch = 'E') then begin error(recpkt,len); sinit := 'a' end (* if 'E' *) else if (ch = chr(0)) then sinit := state else if (ch <> 'N') then sinit := 'a' end; (* sinit *) function sdata: char; (* send file data *) var num, len: integer; ch: char; packarray: array[false..true] of packettype; sizearray: array[false..true] of integer; current: boolean; b: boolean; function other(b: boolean): boolean; (* complements a boolean which is used as array index *) begin if b then other := false else other := true end; (* other *) begin current := true; packarray[current] := packet; sizearray[current] := size; while (state = 'd') do begin if (numtry > maxtry) then (* if too many tries, give up *) state := 'a'; b := other(current); numtry := numtry + 1; refresh_screen(numtry,n); (* send a data packet *) spack('D',n mod 64,sizearray[current],packarray[current]); ch := rpack(len,num,recpkt); (* receive a packet *) (* set up next packet *) if TranState = TxtFile then sizearray[b] := bufill(packarray[b]) else sizearray[b] := Bbufill(packarray[b]); if ch = 'N' then (* NAK, so just stay in this state *) if ((n+1) mod 64 <> num) then (* unless NAK for next, which *) sdata := state else (* is just like ACK for this packet *) begin if num > 0 then num := (num - 1) (* in which case, decrement num *) else num := 63; ch := 'Y'; (* and indicate an ACK *) end; (* else *) if (ch = 'Y') then begin if ((n mod 64) <> num) then (* if wrong ACK *) begin sdata := state; (* stay in same state *) exit(sdata); (* get out of here *) end; (* if *) if numtry > 1 then (* if anything in buffer, flush it *) if istbrr then begin ch:=rcvbbt; ch:='Y'; end; numtry := 0; n := n + 1; current := b; if sizearray[current] = ateof then state := 'z' (* set state to eof *) else state := 'd' (* else stay in data state *) end (* if *) else if (ch = 'E') then begin error(recpkt,len); state := 'a' end (* if 'E' *) else if (ch = chr(0)) then (* receive failure, so stay in d *) begin end else if (ch <> 'N') then eger; begin for i := 1 to length(s) do if s[i] in ['a'..'z'] then s[i] := chr(ord('A') + ord(s[i]) - ord('a')) end; (* uppercase *) begin count := 0; l := length(fn); for i := 1 to l do (* count '.'s in fn *) if fn[i] = '.' then count := count + 1; for i := 1 to count-1 do (* remove all but 1 *) begin j := 1; while (j < l) and (fn[j] <> '.') do j := j + 1; delete(fn,j,1);l := l - 1 end; (* for i *) l := length(fn); i := pos(':',fn); if (i <> 0) then begin fn := copy(fn,i,l-i); l := length(fn) end; i := 1; while (i <= length(fn)) do if not(fn[i] in ['a'..'z','A'..'Z','.','0'..'9']) then delete(fn,i,1) else i := i + 1; uppercase(fn) end; (* legalize *) begin if debug then debugwrite('sfile'); if (numtry > maxtry) then (* if too many tries, give up *) begin sfile := 'a'; exit(sfile) end; numtry := numtry + 1; oldfn := filename; legalize(filename); (* make filename acceptable to remote *) len := length(filename); moveleft(filename[1],fn[0],len); (* move filename into a packettype *) gotoxy(filepos,fileline); write(oldfn,' ==> ',filename); refresh_screen(numtry,n); spack('F',n mod 64,len,fn); (* send file header packet *) ch := rpack(len,num,recpkt); if ch = 'N' then (* NAK, so just stay in this state *) if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *) begin sfile := 'f'; exit(sfile) (* is just like ACK for this packet *) end else begin if (num > 0) then num := (num - 1) (* in which case, decrement num *) else num := 63; ch := 'Y'; (* and indicate an ACK *) end; (* else *) if (ch = 'Y') then begin if ((n mod 64) <> num) then (* if wrong ACK, stay in F state *) begin sfile := 'f'; exit(sfile) end; if TranState = TxtFile then size := bufill(packet) (* get first data from file *) else size := Bbufill(packet); numtry := 0; n := n + 1; sfile := 'd'; end (* if *) else if (ch = 'E') then begin error(recpkt,len); sfile := 'a' end (* if 'E' *) else if (ch <> chr(0)) and (ch <> 'N') then (* don't recognize it *) sfile := 'a' end; (* sfile *) function seof: char; (* send end of file *) var num, len: integer; ch: char; begin if debug then debugwrite('seof'); if (numtry > maxtry) then (* if too many tries, give up *) begin seof := 'a'; exit(seof) end; numtry := numtry + 1; refresh_screen(numtry,n); spack('Z',(n mod 64),0,packet); (* send end of file packet *) if debug then debugwrite('seof1'); ch := rpack(len,num,recpkt); if ch = 'N' then (* NAK, so just stay in this state *) if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *) exit(seof) (* is just like ACK for this packet *) else begin if num > 0 then num := (num - 1) (* in which case, decrement num *) else num := 63; ch := 'Y'; (* and indicate an ACK *) end; (* else *) if (ch = 'Y') then begin if debug then debugwrite('seof2'); if ((n mod 64) <> num) then (* if wrong ACK, stay in F state *) exit(seof); numtry := 0; n := n + 1; if debug then debugwrite(concat('closing ',s)); CloseF(filename,False); seof := 'b' end (* if *) else if (ch = 'E') then begin error(recpkt,len); seof := 'a' end (* if 'E' *) else if (ch = chr(0)) then (* receive failed, so stay in z state *) begin end else if (ch <> 'N') then (* other error, just abort *) seof := 'a' end; (* seof *) function sbreak: char; var num, len: integer; ch: char; (* send break (end of transmission) *) begin if debug then debugwrite('sbreak'); if (numtry > maxtry) then (* if too many tries, give up *) begin sbreak := 'a'; exit(sbreak) end; numtry := numtry + 1; refresh_screen(numtry,n); spack('B',(n mod 64),0,packet); (* send end of file packet *) ch := rpack(len,num,recpkt); if ch = 'N' then (* NAK, so just stay in this state *) if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *) exit(sbreak) (* is just like ACK for this packet *) else begin if num > 0 then num := (num - 1) (* in which case, decrement num *) else num := 63; ch := 'Y'; (* and indicate an ACK *) end; (* else *) if (ch = 'Y') then begin if ((n mod 64) <> num) then (* if wrong ACK, stay in B state *) exit(sbreak); numtry := 0; n := n + 1; sbreak := 'c' (* else, switch state to complete *) end (* if *) else if (ch = 'E') then begin error(recpkt,len); sbreak := 'a' end (* if 'E' *) else if (ch = chr(0)) then (* receive failed, so stay in z state *) begin end else if (ch <> 'N') then (* other error, just abort *) sbreak := 'a' end; (* sbreak *) (* state table switcher for sending *) begin (* sendsw *) if debug then debugwrite(concat('Opening ',filename)); openfile; if io_status <> 0 then begin writeln(chr(ff){clear_screen}); ino_error(io_status); send_ok := false; exit(sendsw) end; write_screen('Sending'); state := 's'; n := 0; (* set packet # *) numtry := 0; while true do if state in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then case state of 'd': state := sdata; 'f': state := sfile; 'z': state := seof; 's': state := sinit; 'b': state := sbreak; 'c': begin send_ok := true; exit(sendsw) end; (* case c *) 'a': begin send_ok := false; exit(sendsw) end (* case a *) end (* case *) else (* state not in legal states *) begin send_ok := false; CloseF(filename,send_ok); exit(sendsw) end (* else *) end; (* sendsw *) **** File SYSUNIT.TEXT ********************************************************* (*$S+*) { This unit allows the users to access the directory information held on each disk } Unit SysUnit; Interface Uses M2Types,M2IpRoot,M2Sys; type FileType = String[15]; Volume = 4..12; var D : File; procedure DelFile( G : FileType; Vol : Volume ); procedure PrintNames( Vol : Volume; var NbrOfFiles : integer ); Implementation { These are the declerations that we don't really want the user to see, as they may do silly things } const FirstBlk = 8; LastBlk = 839; type FileArray = Packed array[0..77] of FileType; Daterec = packed record Month : 0..12; Day : 0..31; Year : 0..100 end; FileKind = (UnTyped,XDsk,Code,Text,Info,Data,Graf,Foto, SecureDir); DirEntry = Packed Record DFirstBlk : integer; DLastBlk : integer; case DFKind : FileKind of SecureDir,UnTyped : (Filler1 : 0..2048; Dvid : String[7]; DevoBlk : integer; DNumFiles: 0..77; DLoadTime: integer; DLastBoot: DateRec ); XDsk,Code,Text,Info,Data,Graf,Foto : (Filler : 0..1024; Status : Boolean; Dtid : String[15]; DLastByte: 1..512; DAccess : DateRec ) end; Directory = array[0..77] of DirEntry; (* ---------------------------------------------------- *) function IsFile(Name : FileType; Vol : Volume ) : Boolean; { This checks if the file, name, exists on the disk, vol } var G : String; i : integer; begin if (Not ( Vol in [4,5,11,12] )) or (Length(Name) < 1) then begin IsFile := False; Exit(IsFile) end; case Vol of 4 : G := Concat('#4:',Name); 5 : G := Concat('#5:',Name); 11 : G := Concat('#11:',Name); 12 : G := Concat('#12:',Name); end; (*$I-*) Reset(D,g); i := IOResult; if i = 0 then Close(D,lock); (*$I+*) IsFile := i = 0 end{IsFile}; (* ---------------------------------------------------- *) procedure DelFile; { This procedure deletes a file from disk } var i,j,NbrOfFiles : Integer; DD : Directory; Dummy : DirEntry; Found : Boolean; Key : char; begin { Tell the user what we are doing } write('#',vol,':',G,' =====> '); { Check that the name is valid and exists } if (Not (Vol in [4,5,11,12])) or (Length(G)<1) or Not (IsFile(G,Vol)) then begin writeln('Does not exist'); Exit(DelFile); end; { Inform that it has been deleted ! } writeln('Deleted'); { Ask if the user wishes to update the directory, this will do the actual delete ! } write('Update Directory (Y/N) ?'); repeat read(keyboard,Key) until Key in ['Y','y','N','n']; writeln(Key); { If we do update the directory then we have to delete } if Key in ['Y','y'] then begin { Get the directory info } UnitRead(Vol,DD,SizeOf(DD),4); NbrOfFiles := DD[0].DNumFiles; i := 0; Found := False; { Find the file } while not Found do begin with DD[i] do if (Not (DFKind in [SecureDir,UnTyped])) and (DTid = G) then Found := True else i := i + 1; if i > NbrOfFiles then Exit(DelFile) end; { delete from the directory info } Dummy := DD[i]; For j:= i To pred(NbrOfFiles) do DD[j] := DD[j+1]; DD[NbrOfFiles] := Dummy; DD[0].DNumFiles := NbrOfFiles -1; { Update the actual directory on the disk } UnitWrite(Vol,DD,SizeOf(DD),4) end; end{DelFile}; (* ---------------------------------------------------- *) procedure PrintNames; { This procedure displays a directory on the screen for the user to view } const StrtPos = 20; FinisPos = 26; DatePos = 32; TyPos = 42; var i,k : integer; DD : Directory; (* -------------------------------------------------- *) procedure PrintDAcc(var DAccess : DateRec ); begin GotoXY(DatePos,k); with DAccess do begin write(Day,'-'); case Month of 1 : write('Jan'); 2 : write('Feb'); 3 : write('Mar'); 4 : write('Apr'); 5 : write('May'); 6 : write('Jun'); 7 : write('Jul'); 8 : write('Aug'); 9 : write('Sep'); 10 : write('Oct'); 11 : write('Nov'); 12 : write('Dec') end{case}; write('-',Year) end{with}; end{PrintDAcc}; (* -------------------------------------------------- *) procedure PrintTy( DFKind : FileKind ); begin GotoXY(TyPos,k); case DFKind of SecureDir : write(' SecureDir '); UnTyped : write(' UnTyped '); XDsk : write(' XDsk '); Code : write(' Code '); Text : write(' Text '); Info : write(' Info '); Data : write(' Data '); Graf : write(' Graf '); Foto : write(' Foto '); end; end{PrintTy}; (* -------------------------------------------------- *) begin { Get the directory information } UnitRead(Vol,DD,SizeOf(DD),4); NbrOfFiles := DD[0].DNumFiles; { write which disk ths info is from } writeln(chr(ff),'DIRECTORY OF #',Vol,':'); k := 1; { Take care of the first entry } with DD[1] do begin if DFirstBlk > FirstBlk then begin write(''); GotoXY(StrtPos,k); write(FirstBlk); GotoXY(FinisPos,k);write(pred(DFirstBlk)); k := k + 1; writeln end end; { For each entry display on the screen } for i := 1 to NbrOfFiles do with DD[i] do begin write(Dtid); GotoXY(StrtPos,k); write(DFirstBlk); GotoXY(FinisPos,k);write(DLastBlk); PrintDAcc(DAccess); PrintTy(DFKind); writeln; k := succ(k); if i < NbrofFiles then if (DLastBlk < DD[succ(i)].DFirstBlk) then begin write(''); GotoXY(StrtPos,k); write(DLastBlk); GotoXY(FinisPos,k);write(pred(DD[succ(i)].DFirstBlk)); k := k + 1; writeln end; { if we have reached the bottom of the screen and still have more to do... wrap around } if (k mod 31) = 0 then begin Pause; writeln(chr(ff),' DIRECTORY CONTD'); k := 1 end; end; { Take care of the last entry, if blank etc } with DD[NbrOfFiles] do begin if DlastBlk < LastBlk then begin write(''); GotoXY(StrtPos,k); write(succ(DLastBlk)); GotoXY(FinisPos,k);write(LastBlk); k := k + 1; writeln end end end{PrintNames}; (* ---------------------------------------------------- *) end{SysUnit}. **** File UTILS.TXT ************************************************************ function ready(p:port):boolean; begin ready:= ((p=terminal) and (not IoStatus(2))) or ((p=modem) and istbrr); end; function pget(p:port):char; begin if p=terminal then pget := chr( aand(IORead(80),127) ) { get from the keyboard } else pget :=rcvbbt; end; procedure read_str(*var p: port; var s: string*); (* acts like readln(s) but takes input from specified port *) var i: integer; begin i := 0; s := copy('',0,0); repeat repeat (* get a character *) until ready(p); ch:=pget(p); if (ord(ch) = backspace) then (* if it's a backspace then *) begin if (i > 0) then (* if not at beginning of line *) begin write(ch); (* go back a space on screen *) write(' '); (* erase char on screen *) write(ch); (* go back a space again *) i := i - 1; (* adjust string counter *) s := copy(s,1,i) (* adjust string *) end (* if *) end (* if *) else if (ord(ch) <> eoln_sym) then (* otherwise if not at eoln then *) begin write(ch); (* echo char on screen *) i := i + 1; (* inc string counter *) s := concat(s,' '); s[i] := ch; (* put char in string *) end; (* if *) until (ord(ch) = eoln_sym); (* if not eoln, get another char *) s := copy(s,1,i); (* correct string length *) writeln (* write a line on the screen *) end; (* read_str *) function read_ch(*p: port; var ch: char): boolean*); (* read a character from an input port *) begin if ready(p) then (* if a char there *) begin ch := pget(p); (* get the char *) read_ch := true; (* and return true *) end (* if *) else (* otherwise *) read_ch := false; (* return false *) end; (* read_ch *) function getch(*var r: char; p: port): boolean*); (* gets a character, strips parity, returns true if it got a char which *) (* isn't Kermit SOH, false if it gets SOH or nothing after maxtry *) const maxtry = 10000; var count: integer; begin count := 0; getch := false; repeat count := count + 1; until ready(p) or (count > maxtry); (* wait for a character *) if (count > maxtry) then (* if wait too long then *) begin getch := false; { act as if SOH ! } exit(getch) (* get out of here *) end; r:=pget(p); (* get the character *) r := chr(aand(ord(r),127)); (* strip parity from char *) getch := (r <> chr(soh)); (* return true if not SOH *) end; (* getch *) function aand(*x,y: integer): integer*); (* arithmetic and--takes 2 integers and ands them, yeilding an integer *) var xrec, yrec, temp: int_bool_rec; begin xrec.i := x; (* put the two numbers in variant record *) yrec.i := y; temp.b := xrec.b * yrec.b; (* use as sets to 'and' them *) aand := temp.i (* return integer result *) end; (* aand *) function aor(*x,y: integer): integer*); (* arithmetic or *) var xrec, yrec, temp: int_bool_rec; begin xrec.i := x; (* put two numbers in variant record *) yrec.i := y; temp.b := xrec.b + yrec.b; (* use as sets to 'or' them *) aor := temp.i (* return integer result *) end; (* aor *) function xor(*x,y: integer): integer*); (* exclisive or *) var xrec, yrec, temp: int_bool_rec; begin xrec.i := x; (* put two numbers in variant record *) yrec.i := y; (* use as sets to 'xor' them *) temp.b := (xrec.b - yrec.b) + (yrec.b - xrec.b); xor := temp.i (* return integer result *) end; (* xor *) procedure error(*p: packettype; len: integer*); (* writes error message sent by remote host *) var i: integer; begin gotoxy(0,errorline); for i := 0 to len-1 do write(p[i]); gotoxy(0,promptline); end; (* error *) procedure ino_error(*i: integer*); begin gotoxy(0,errorline); writeln; (* erase to end of line *) gotoxy(0,errorline); case i of 0: writeln('No error'); 1: writeln('Bad Block, Parity error (CRC)'); 2: writeln('Bad Unit Number'); 3: writeln('Bad Mode, Illegal operation'); 4: writeln('Undefined hardware error'); 5: writeln('Lost unit, Unit is no longer on-line'); 6: writeln('Lost file, File is no longer in directory'); 7: writeln('Bad Title, Illegal file name'); 8: writeln('No room, insufficient space'); 9: writeln('No unit, No such volume on line'); 10: writeln('No file, No such file on volume'); 11: writeln('Duplicate file'); 12: writeln('Not closed, attempt to open an open file'); 13: writeln('Not open, attempt to close a closed file'); 14: writeln('Bad format, error in reading real or integer'); 15: writeln('Ring buffer overflow') end; (* case *) gotoxy(0,promptline) end; (* ino_error *) procedure debugwrite(*s: string*); (* writes a debugging message *) var i: integer; begin if debug then begin gotoxy(0,debugline+debnext); writeln; gotoxy(0,debugline+debnext); debnext:=(debnext+1) mod debug_max; write(s); (* write debugging message *) end (* if debug *) end; (* debugwrite *) procedure debugint(*s: string; i: integer*); (* write a debugging message and an integer *) begin if debug then begin debugwrite(s); write(i) end (* if debug *) end; (* debugint *) procedure writescreen(*s: string*); (* sets up the screen for receiving or sending files *) begin write(chr(ff){clearscreen}); gotoxy(0,titleline); write(' Kermit UCSD p-system'); gotoxy(statuspos,statusline); write(s); gotoxy(0,packetline); write('Number of Packets: '); gotoxy(0,retryline); write('Number of Tries: '); gotoxy(0,fileline); write('File Name: '); end; (* writescreen *) procedure refresh_screen(*numtry, num: integer*); (* keeps track of packet count on screen *) begin gotoxy(retrypos,retryline); write(numtry: 5); gotoxy(packetpos,packetline); write(num: 5) end; (* refresh_screen *) function min(*x,y: integer): integer*); (* returns smaller of two integers *) begin if x < y then min := x else min := y end; (* min *) function tochar(*ch: char): char*); (* tochar converts a control character to a printable one by adding space *) begin tochar := chr(ord(ch) + ord(' ')) end; (* tochar *) function unchar(*ch: char): char*); (* unchar undoes tochar *) begin unchar := chr(ord(ch) - ord(' ')) end; (* unchar *) function ctl(*ch: char): char*); (* ctl toggles control bit: ^A becomes A, A becomes ^A *) begin ctl := chr(xor(ord(ch),64)) end; (* ctl *) procedure echo(ch: char); (* echos a character on the screen *) begin ch := chr(aand(ord(ch),127)); (* mask off parity bit *) repeat until ISTATR; sndabt(ch) end; (* echo *) **** End of concatenated source files ******************************************