>>>> UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U >>>> >>>> All files are concatenated together into this single file, separated by >>>> lines beginning like this one does, followed by the name of the file. >>>> >>>> HELP.TEXT segment procedure help; procedure keypress; const clearscreen = 12; var ch: char; begin writeln('---------------Press any key to continue---------------'); repeat until readch(kq,ch); writeln(chr(clearscreen)) end; (* keypress *) procedure help1; var ch: char; begin if (noun = nullsym) then begin writeln('KERMIT is a family of programs that do reliable file transfer'); write('between computers over TTY lines. KERMIT can also be '); writeln('used to make the '); writeln('microcomputer behave as a terminal for a mainframe. These are the '); writeln('commands for theUCSD p-system version, KERMIT-UCSD:'); writeln end; (* if *) if (noun = nullsym) or (noun = consym) then begin writeln(' CONNECT To make a "virutual terminal" connection to a remote'); writeln(' system.'); writeln; write(' To break the connection and "escape" back to the micro,'); writeln; writeln(' type the escape sequence (CTRL-] C, that is Control '); writeln(' rightbracket 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 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 = sendsym) then begin writeln(' SEND To send a file or group of files to the remote system.'); writeln; end; (* if *) if (noun = nullsym) then keypress; 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 = debugsym) then begin writeln(' DEBUG To set debug mode ON or OFF '); writeln(' (default is OFF).'); writeln; end; (* if *) if (adj = nullsym) or (adj = escsym) then begin writeln(' ESCAPE To change the escape sequence that '); writeln(' lets you return to the PC Kermit from'); write(' 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 ON, '); writeln(' Kermit will warn you and rename an '); writeln(' incoming file so as not to write over'); writeln(' a file that currently exists with the'); writeln(' same name'); writeln; end; (* if *) if (adj = nullsym) then keypress; end; (* if *) end; (* help2 *) procedure help3; begin if (noun = nullsym) or (noun = setsym) then begin if (adj = nullsym) or (adj = ibmsym) then begin writeln(' IBM ON/OFF, default is OFF. This flag '); write(' should be ON only when '); writeln('transfering files'); writeln(' between the micro and an IBM VM/CMS'); writeln(' system. It also causes the parity to'); write(' be set appropriately '); writeln('(mark) and activates'); writeln(' local echoing'); writeln; end; (* if *) if (adj = nullsym) or (adj = localsym) then begin write(' LOCAL-ECHO ON/OFF, default is OFF. This sets the'); writeln; writeln(' duplex. It should be ON when using '); writeln(' the IBM and OFF for the DEC-20.'); writeln; end; (* if *) end; (* if *) end; (* help3 *) procedure help4; begin if (noun = setsym) or (noun = nullsym) then begin if (adj = nullsym) or (adj = paritysym) then begin writeln(' PARITY EVEN, ODD, MARK, SPACE, or NONE.'); writeln(' NONE is the default but if the IBM '); writeln(' flag is set, parity is set to MARK. '); writeln(' This flag selects the parity for '); write(' outgoing and incoming characters during'); writeln; write(' CONNECT and file transfer to match the'); writeln; writeln(' requirements of the host.'); writeln; end; (* if *) end; (* if *) if (noun = nullsym) or (noun = showsym) then begin writeln(' SHOW To see the values of parameters that can be modified'); writeln(' via the SET command. Options are the same as for SET,'); writeln(' except that a SHOW ALL command has been added.'); end; (* if *) end; (* help4 *) begin help1; help2; help3; help4 end; (* help *) >>>> KBDHANDLR.TEXT ; ---------------------------- ; KBDHNDLR TTY Receive Handler ; ---------------------------- ; ; Two routines are provided that maintain an interrupt-driven ; TTY-receive queue. Appropriate PASCAL declarations are: ; ; CONST KQSIZE = maximum number of queued characters ; ; TYPE QUEUE = RECORD (* These are order-dependent !!! *) ; QSIZE: INTEGER; ; INP: INTEGER; ; OUTP: INTEGER; ; MAXCHAR: INTEGER; ; DATA: PACKED ARRAY [0..RCVQSIZE] OF CHAR; ; END; ; VAR KQ: QUEUE; (* must be declared in outermost block *) ; ; PROCEDURE KBDINIT (VAR Q: QUEUE; SIZE:INTEGER); EXTERNAL; ; PROCEDURE KBDFINIT; EXTERNAL; ; ; KBDINIT (KQ,KQSIZE); (* initialize the queue handler *) ; ; WHILE TRUE DO ; WITH KQ DO ; IF INP <> OUTP THEN (* characters available *) ; BEGIN ; CH := DATA[OUTP]; ; OUTP := OUTP+1; IF OUTP > QSIZE THEN OUTP := 0; ; ... ; END; ; ; KBDFINIT; (* terminate the queue handler *) ; ; The RECORD declaration for the queue must appear exactly as it ; does above except that you can of course use any names you like. ; Do NOT attempt to lump the first four integer variables together ; into a single group of the form list:INTEGER. In that case, ; the compiler allocates them in reverse order, so that your code ; and the interrupt handler will not agree about which words have ; what meaning. ; ; The queue handler runs continuously as an interrupt-driven task ; at high priority. As characters come in, it advances the queue ; INP pointer and keeps track of the maximum number of characters in ; the queue in the MAXCHAR variable. Queue overflow is indicated ; by MAXCHAR > QSIZE. You must terminate by calling KBDFINIT, or ; the TTY receive interrupts will be left enabled and you will end ; up crashing the system by executing garbage code when the next ; character is received. (KBDFINIT also repairs the interrupt ; vectors for breakpoints and the clock, so failing to call it will ; quite likely crash the system even in the absence of incoming ; TTY characters.) ; ; The manipulation of the clock and BPT interrupt vectors is borrowed ; from UCSD's old communications program. The purpose is to allow ; the clock handler to be interrupted by incoming TTY characters. ; KDB .EQU 177562 ; Receive Data Buffer absolute address KSR .EQU 177560 ; Receive Status Register absolute address KINTV .EQU 60 ; Receiver Interrupt Vector address CLKINTV .EQU 100 ; Clock interrupt vector address BPTINTV .EQU 14 ; BPT interrupt vector address QXCINTV .EQU 250 ; QX controller interrupt vector ; .PROC KBDINIT,2 ; (VAR Q:QUEUE, SIZE:INTEGER) ; .DEF KBDLOC ; holds vector address .DEF KBDPR ; holds old priority Q .EQU 4 ; stack offset for Q address SIZE .EQU 2 ; stack offset for QSIZE value ; MOV Q(SP),R0 ; obtain the Q record address MOV R0,KQADRS ; remember Q address MOV SIZE(SP),(R0)+ ; store size in QSIZE word MOV #0,(R0)+ ; clear INP, OUTP, and MAXCHAR MOV #0,(R0)+ MOV #0,(R0) ; ; MOV @#KINTV,KBDLOC ; save old interrupt vector MOV @#KINTV+2,KBDPR ; and old priority MOV #KHNDLR,@#KINTV ; store interrupt handler address MOV #200,@#KINTV+2 ; set interrupt priority 4 for TTY input ;MOV #100,@#KSR ; enable interrupts for TTY input ; MOV (SP)+,R0 ; pop return address from stack ADD #4,SP ; discard 2 parameters (4 bytes) JMP @R0 ; and return to PASCAL interpreter ; KQADRS .WORD 0 ; holds Q address for handler KBDLOC .WORD 0 ; holds old interrupt vector KBDPR .WORD 0 ; holds old interrupt priority ; QSIZE .EQU 0 ; offset from Q INP .EQU 2 ; likewise OUTP .EQU 4 MAXCHAR .EQU 6 DATA .EQU 10 ; KHNDLR: MOV R0,-(SP) ; free registers R0, R1, R2 for use MOV R1,-(SP) MOV R2,-(SP) MOV KQADRS,R2 ; fetch Q address saved by KBDINIT MOV INP(R2),R0 ; fetch INP value MOV R0,R1 ; make a working copy ADD R2,R1 ; R1 = address (Q) + value (INP) MOVB @#KDB,DATA(R1) ; DATA[INP] := input character BICB #200,DATA(R1) ; clear bit 8 (parity) BEQ EXIT ; ignore nulls (do not bump INP) INC R0 ; INP := INP+1 CMP QSIZE(R2),R0 BPL NOWRAP ; if QSIZE >= INP then no wraparound CLR R0 ; else INP := 0 NOWRAP MOV R0,INP(R2) ; restore INP ; SUB OUTP(R2),R0 BMI INOUT BEQ INOUT BR OUTIN ; if INP > OUTP, # char = INP - OUTP INOUT ADD QSIZE(R2),R0 ; otherwise, # char = QSIZE+1 + INP - OUTP ADD #1,R0 OUTIN CMP MAXCHAR(R2),R0 BPL EXIT ; if MAXCHAR >= # char, exit MOV R0,MAXCHAR(R2) ; otherwise, store new MAXCHAR ; EXIT MOV (SP)+,R2 ; restore registers for caller MOV (SP)+,R1 MOV (SP)+,R0 RTT ; return from interrupt ; CLKHNDLR: COM CLKFLG ; do not reexecute BPT if BPT handler BEQ CLKEXIT ; takes so long that clock ticks again BPT ; let breakpoint transfer to old clock CLKEXIT COM CLKFLG ; reset flag RTI ; and exit ; CLKFLG .WORD 0 ; flags reentry before BPT exit ; .PROC KBDFINIT .REF KBDLOC ; old interrupt vector saved by KBDINIT .REF KBDPR ; old kbd priority saved by KBDINIT ; MOV @#KBDPR,@#KINTV+2 ; restore interrupt priority MOV @#KBDLOC,@#KINTV ; and interrupt vector RTS PC ; and return ; .END >>>> KERMIT.TEXT program kermit; (* $R-*) (* turn range checking off *) (*$S+*) (* turn swapping on *) (* $L+*) (*$U PARSELIB.CODE*) USES PARSER; const blksize = 512; oport = 8; (* output port # *) clearscreen = 12; (* charcter which erases screen *) bell = 7; (* ASCII bell *) 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_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 *) rqsize = 5000; (* input queue size *) qsize1 = 5001; (* qsize + 1 *) 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; debug_line = 7; prompt_line = 8; (* position on line to put info *) statuspos = 70; packet_pos = 19; retry_pos = 17; file_pos = 11; type queue = record (* input queue *) qsize: integer; inp: integer; outp: integer; maxchar: integer; data: packed array[0..rqsize] of char; end; (* queue *) 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 *) case boolean of true: (i: integer); false: (b: boolean) end; (* record *) var kq, rq: queue; state: char; (* current state *) f: file of char; (* file to be received *) oldf: file; (* file to be sent *) s: string; eol, quote, esc_char: char; fwarn, ibm, half_duplex, debug: boolean; i, size, rpsiz, spsiz, pad, n, num_try, oldtry, timint: integer; recpkt, packet: packettype; padchar, ch: char; debf: text; (* file for debug output *) parity: parity_type; xon: char; filebuf: packed array[1..1024] of char; bufpos, bufend: integer; parity_array: packed array[char] of char; ctlset: set of char; rec_ok, send_ok: boolean; function read_ch(var q: queue; var ch: char): boolean; forward; procedure clear_buf(var q: queue); 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 io_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 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_int_rec; var q: queue): boolean; forward; function getsoh(var q: queue): boolean; forward; function rpack(var len, num: integer; var data: packettype): char; forward; procedure read_str(var q: queue; var s: string); forward; procedure show_parms; forward; (*$I HELP.TEXT*) (*$I SENDSW.TEXT*) (*$I RECSW.TEXT*) procedure rcvinit(var q: queue; size: integer); external; procedure rcvfinit; external; procedure kbdinit(var q: queue; size: integer); external; procedure kbdfinit; external; procedure sendbrk; external; procedure read_str(*var q: queue; var s: string*); (* acts like readln(s) but takes input from input queue *) var i: integer; begin i := 0; s := copy('',0,0); repeat repeat (* get a character *) until read_ch(kq,ch); 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 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 and yrec.b; (* use as booleans 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 or yrec.b; (* use as booleans 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 booleans to 'xor' them *) temp.b := (xrec.b or yrec.b) and (not(xrec.b and yrec.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 io_error(*i: integer*); begin gotoxy(0,errorline); write(chr(27),'K'); (* erase to end of line *) 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; (* io_error *) procedure debugwrite(*s: string*); (* writes a debugging message *) var i: integer; begin if debug then begin gotoxy(0,debugline); write(chr(27),'K'); (* erase to end of line *) write(s); for i := 1 to 2000 do ; (* 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(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 *) if ch <> chr(lf) then begin unitwrite(1,ch,1) end (* if *) end; (* echo *) procedure clear_buf(*var q: queue*); (* empties the buffer input buffer *) begin q.outp := q.inp end; (* clear_buf *) function getfil(*filename: string): boolean*); (* opens a file for writing *) begin (*$I-*) (* turn i/o checking off *) rewrite(f,filename); (*$I-*) (* turn i/o checking on *) getfil := (ioresult = 0) end; (* getfil *) procedure bufemp(*buffer: packettype; var f: text; len: integer*); (* empties a packet into a file *) var i,ls: integer; r: char_int_rec; s: string; begin s := copy('',0,0); ls := 0; i := 0; while i < len do begin r.ch := buffer[i]; (* get a character *) if (r.ch = myquote) then (* if character is control quote *) begin i := i + 1; (* skip over quote and *) r.ch := buffer[i]; (* get quoted character *) if (aand(r.i,127) <> ord(myquote)) then r.ch := ctl(r.ch); (* controllify it *) end; (* if *) if (r.i = cr) then (* else if a carriage return then *) begin i := i + 3; (* skip over that and line feed *) (*$I-*) (* turn i/o checking off *) writeln(f,s); (* and write out line to file *) s := copy('',0,0); (* empty the string var *) ls := 0; if (io_result <> 0) then (* if io_error *) begin io_error(ioresult); (* tell them and *) state := 'a'; (* abort *) end (* if *) end (*$I+*) (* turn i/o checking back on *) else (* else, is a regular char, so *) begin r.i := aand(r.i,127); (* mask off parity bit *) s := concat(s,' '); (* and add character to out string *) ls := ls + 1; s[ls] := r.ch; i := i + 1 (* increase buffer pointer *) end; (* else *) end; (* while *) (* and get another char *) (*$I-*) (* turn i/o checking off *) write(f,s); (* and write out line to file *) if (io_result <> 0) then (* if io_error *) begin io_error(ioresult); (* tell them and *) state := 'a'; (* abort *) end (* if *) (*$I+*) (* turn i/o checking back on *) end; (* bufemp *) function bufill(*var buffer: packettype): integer*); (* fill a packet with data from a file...manages a 2 block buffer *) var i, j, k, t7, count: integer; r: char_int_rec; begin i := 0; (* while file has some data & packet has some room we'll keep going *) while ((bufpos <= bufend) or (not eof(oldf))) and (i < spsiz-9) do begin (* if we need more data from disk then *) if (bufpos > bufend) and (not eof(oldf)) then begin (* read a couple of blocks *) bufend := blockread(oldf,filebuf[1],2) * blksize; (* and adjust buffer pointer *) bufpos := 1 end; (* if *) if (bufpos <= bufend) then (* if we're within buffer bounds *) begin r.ch := filebuf[bufpos]; (* get a character *) bufpos := bufpos + 1; (* increase buffer pointer *) if (r.i = dle) then (* if it's space compression char, *) begin count := ord(unchar(filebuf[bufpos])); (* get # of spaces *) bufpos := bufpos + 1; (* read past # *) r.ch := ' '; (* and make current char a space *) end (* else if *) else (* otherwise, it's just a char *) count := 1; (* so only 1 copy of it *) if (r.ch in ctlset) then (* if a control char *) begin if (r.i = cr) then (* if a carriage return *) begin buffer[i] := quote; (* put (quoted) CR in buffer *) i := i + 1; buffer[i] := ctl(chr(cr)); i := i + 1; r.i := lf; (* and we'll stick a LF after *) end; (* if *) if r.i <> 0 then (* if not a NUL then *) begin buffer[i] := quote; (* put the quote in buffer *) i := i + 1; if r.ch <> quote then r.ch := ctl(r.ch); (* and un-controllify char *) end (* if *) end; (* if *) end; (* if *) j := 1; while (j <= count) and (i <= spsiz - 5) do begin (* put all the chars in buffer *) if (r.i <> 0) then (* so long as not a NUL *) begin buffer[i] := r.ch; i := i + 1; end (* if *) else (* is a NUL so *) if (bufpos > blksize) then (* skip to end of block *) bufpos := bufend + 1 (* since rest will be NULs *) else bufpos := blksize + 1; j := j + 1 end; (* while *) end; (* while *) if (i = 0) then (* if we're at end of file, *) bufill := (at_eof) (* indicate it *) else (* else *) begin if (j <= count) then (* if didn't all fit in packet *) begin bufpos := bufpos - 2; (* put buf pointer at DLE *) (* and update compress count *) filebuf[bufpos + 1] := tochar(chr(count-j+1)); end; (* if *) bufill := i (* return # of chars in packet *) end; (* else *) end; (* bufill *) procedure spar(*var packet: packettype*); (* fills data array with my send-init parameters *) begin packet[0] := tochar(chr(maxpack)); (* biggest packet i can receive *) packet[1] := tochar(chr(mytime)); (* when i want to be timed out *) packet[2] := tochar(chr(mypad)); (* how much padding i need *) packet[3] := ctl(chr(mypchar)); (* padding char i want *) packet[4] := tochar(chr(myeol)); (* end of line character i want *) packet[5] := myquote; (* control-quote char i want *) packet[6] := 'N'; (* I won't do 8-bit quoting *) end; (* spar *) procedure rpar(*var packet: packettype*); (* gets their init params *) begin spsiz := ord(unchar(packet[0])); (* max send packet size *) timint := ord(unchar(packet[1])); (* when i should time out *) pad := ord(unchar(packet[2])); (* number of pads to send *) padchar := ctl(packet[3]); (* padding char to send *) eol := unchar(packet[4]); (* eol char i must send *) quote := packet[5]; (* incoming data quote char *) end; (* rpar *) procedure packetwrite(p: packettype; len: integer); (* writes out all of a packet for debugging purposes *) var i: integer; begin gotoxy(0,debugline); for i := 0 to len+3 do begin if i = 80 then begin gotoxy(0,debugline+1); write(chr(27),'K'); end; (* if *) write(p[i]) end; (* for *) for i := 1 to 2000 do ; end; (* packetwrite *) procedure spack(*ptype: char; num: integer; len: integer; data: packettype*); (* send a packet *) const maxtry = 10000; var bufp, i, count: integer; chksum: char; buffer: packettype; ch: char; begin if ibm and (state <> 's') then (* if ibm and not SINIT then *) begin count := 0; repeat (* wait for an xon *) repeat count := count + 1 until (readch(rq,ch)) or (count > maxtry ); until (ch = xon) or (count > maxtry); if count > maxtry then (* if wait too long then *) begin exit(spack) (* get out *) end; (* if *) end; (* if *) bufp := 0; for i := 1 to pad do unitwrite(oport,padchar,1); (* write out any padding chars *) buffer[bufp] := chr(soh); (* packet sync character *) bufp := bufp + 1; chksum := tochar(chr(len + 3)); (* init chksum *) buffer[bufp] := tochar(chr(len + 3)); (* character count *) bufp := bufp + 1; chksum := chr(ord(chksum) + ord(tochar(chr(num)))); buffer[bufp] := tochar(chr(num)); bufp := bufp + 1; chksum := chr(ord(chksum) + ord(ptype)); buffer[bufp] := ptype; (* packet type *) bufp := bufp + 1; for i := 0 to len - 1 do (* loop through data chars *) begin buffer[bufp] := data[i]; (* store char *) bufp := bufp + 1; chksum := chr(ord(chksum) + ord(data[i])) end; (* for i *) (* compute final chksum *) chksum := chr(aand(ord(chksum) + (aand(ord(chksum),192) div 64), 63)); buffer[bufp] := tochar(chksum); bufp := bufp + 1; buffer[bufp] := eol; if (parity <> nopar) then for i := 0 to bufp do (* set correct parity on buffer *) buffer[i] := parity_array[buffer[i]]; unitwrite(oport,buffer[0],bufp+1); (* send the packet out *) if debug then packetwrite(buffer,len); end; (* spack *) function read_ch(*var q: queue; var ch: char): boolean*); (* read a character from an input queue *) begin with q do begin if (inp <> outp) then (* if a char there *) begin ch := data[outp]; (* get the char *) outp := (outp + 1) mod qsize1; (* increment buffer pointer *) read_ch := true; (* and return true *) end (* if *) else (* otherwise *) read_ch := false; (* return false *) end (* with *) end; (* read_ch *) function getch(*var r: char_int_rec; var q: queue): 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; with q do begin repeat count := count + 1; until (inp <> outp) or (count > maxtry); (* wait for a character *) if (count > maxtry) then (* if wait too long then *) exit(getch); (* get out of here *) r.ch := data[outp]; (* get the character *) outp := (outp + 1) mod qsize1; (* increment pointer *) r.i := aand(r.i,127); (* strip parity from char *) getch := (r.ch <> chr(soh)); (* return true if not SOH *) end (* with *) end; (* getch *) function getsoh(*var q: queue): boolean*); (* reads characters until it finds an SOH; returns false if has to read more *) (* than maxtry chars *) const maxtry = 10000; var ch: char; count: integer; begin count := 0; get_soh := true; with q do begin repeat repeat count := count + 1 until (inp <> outp) or (count > maxtry); (* wait for a character *) if (count > maxtry) then begin get_soh := false; exit(get_soh) end; (* if *) ch := data[outp]; (* get the character *) outp := (outp + 1) mod qsize1; (* increment pointer *) ch := chr(aand(ord(ch),127)); (* strip parity of char *) until (ch = chr(SOH)) (* if not SOH, get more *) end (* with q *) end; (* getsoh *) (*$G+*) (* turn on goto option...need it for next routine *) function rpack(*var len, num: integer; var data: packettype): char*); (* read a packet *) label 1; (* used to emulate C's CONTINUE statement *) const maxtry = 10000; var count, i, ichksum: integer; chksum, ptype: char; r: char_int_rec; begin count := 0; if not getsoh(rq) and (state<>'r') then (*if don't get synch char then *) begin rpack := 'N'; (* treat as a NAK *) num := n mod 64; exit(rpack) (* and get out of here *) end; 1: count := count + 1; if (count>maxtry)and(state<>'r') then (* if we've tried too many times *) begin (* and aren't waiting for init *) rpack := 'N'; (* treat as NAK *) exit(rpack) (* and get out of here *) end; (* if *) if not getch(r,rq) then (* get a char and *) goto 1; (* resynch if soh *) ichksum := r.i; (* start checksum *) len := ord(unchar(r.ch)) - 3; (* character count *) if not getch(r,rq) then (* get a char and *) goto 1; (* resynch if soh *) ichksum := ichksum + r.i; num := ord(unchar(r.ch)); (* packet number *) if not getch(r,rq) then (* get a char and *) goto 1; (* resynch if soh *) ichksum := ichksum + r.i; ptype := r.ch; (* packet type *) for i := 0 to len-1 do (* get any data *) begin if not getch(r,rq) then (* get a char and *) goto 1; (* resynch if soh *) ichksum := ichksum + r.i; data[i] := r.ch; end; (* for i *) data[len] := chr(0); (* mark end of data *) if not getch(r,rq) then (* get a char and *) goto 1; (* resynch if soh *) (* compute final checksum *) chksum := chr(aand(ichksum + (aand(ichksum,192) div 64), 63)); if (chksum <> unchar(r.ch)) then (* if checksum bad *) rpack := chr(0) (* return 'false' indicator *) else (* else *) rpack := ptype; (* return packet type *) if debug then begin gotoxy(0,debugline); write(len,num,ptype); for i := 1 to 1000 do ; end; (* if *) end; (* rpack *) (*$G-*) (* turn off goto option...don't need it anymore *) 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(kq,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','?'] then 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 *) '?': begin (* ?: show options *) writeln('B Send a BREAK signal.'); write('C Close Connection, return to '); writeln('KERMIT-UCSD command level.'); writeln('S Show Status of connection'); writeln('? Print this list'); write('^',esc_char,' send the escape '); writeln('character itself to the'); writeln(' remote host.') end; (* ? *) end (* case *) else if ch = esc_char then (* ESC-char: send it out *) begin if half_duplex then begin echo(ch); unitwrite(oport,ch,1) end (* if *) end (* else if *) else (* anything else: ignore *) write(chr(bell)) end; (* read_esc *) begin (* connect *) clear_buf(kq); (* empty keyboard buffer *) clear_buf(rq); (* empty remote input buffer *) writeln('Connecting to host...type CTRL-',ctl(esc_char),' C to exit'); close := false; repeat if read_ch(rq,ch) then (* if char from host then *) echo(ch); (* echo it *) if read_ch(kq,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); unitwrite(oport,ch,1) (* 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 show_parms; (* shows the various settable parameters *) begin 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'); 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); paritysym: begin case parity of evenpar: write('Even'); markpar: write('Mark'); nopar: write('No'); oddpar: write('Odd'); spacepar: write('Space'); end; (* case *) writeln(' parity'); end; (* paritysym *) end; (* case *) 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 *) 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; ctlset := [chr(1)..chr(31),chr(del),quote]; half_duplex := false; debug := false; fwarn := false; spsiz := max_pack; rpsiz := max_pack; n := 0; parity := nopar; initvocab; fill_parity_array; ibm := false; xon := chr(17); bufpos := 1; bufend := 0; rcvinit(rq,rqsize); kbdinit(kq,rqsize); end; (* initialize *) procedure closeup; begin kbdfinit; rcvfinit; writeln(chr(clear_screen)) end; (* closeup *) begin (* kermit *) initialize; repeat write('Kermit-UCSD> '); readstr(kq,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; recsym: begin recsw(rec_ok); gotoxy(0,debugline); write(chr(bell)); if rec_ok then writeln('successful receive') else writeln('unsuccessful receive'); (*$I-*) (* set i/o checking off *) close(oldf); (*$I+*) (* set i/o checking back on *) 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 *) close(oldf); (*$I+*) (* set i/o checking back on *) gotoxy(0,promptline); end; (* sendsym *) setsym: set_parms; show_sym: show_parms; end; (* case verb *) end; (* case parse *) until (verb = exitsym) or (verb = quitsym); closeup end. (* kermit *) >>>> PARSER.TEXT (*$S+*) unit parser; INTERFACE type statustype = (null, at_eol, unconfirmed, parm_expected, ambiguous, unrec, fn_expected, ch_expected); vocab = (nullsym, allsym, consym, debugsym, escsym, evensym, exitsym, filewarnsym,helpsym, ibmsym, localsym, marksym, nonesym, oddsym, offsym, onsym, paritysym, quitsym, recsym, sendsym, setsym, showsym, spacesym); var noun, verb, adj: vocab; status: statustype; vocablist: array[vocab] of string; filename, line: string; newescchar: char; expected: set of vocab; procedure uppercase(var s: string); function parse: statustype; procedure initvocab; IMPLEMENTATION procedure uppercase(*var s: string*); 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 *) 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 parse(*: statustype*); 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, exitstate); var status: statustype; word: vocab; state: states; 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 = spacesym) 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 *) 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, sendsym, setsym, showsym]; 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 consym: state := fin; exitsym, quitsym: state := fin; helpsym: state := get_help_parm; recsym: state := fin; sendsym: state := getfilename; setsym: state := get_set_parm; showsym: state := get_show_parm; 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_set_parm: begin expected := [paritysym, localsym, ibmsym, escsym, debugsym, filewarnsym]; 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; end (* case *) end; (* case get_set_parm *) 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_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, 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, exitsym, helpsym, quitsym, recsym, 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[allsym] := 'ALL'; vocablist[consym] := 'CONNECT'; vocablist[debugsym] := 'DEBUG'; vocablist[escsym] := 'ESCAPE'; vocablist[evensym] := 'EVEN'; vocablist[exitsym] := 'EXIT'; vocablist[filewarnsym] := 'FILE-WARNING'; vocablist[helpsym] := 'HELP'; vocablist[ibmsym] := 'IBM'; vocablist[localsym] := 'LOCAL-ECHO'; vocablist[marksym] := 'MARK'; 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'; end; (* initvocab *) end. (* end of unit *) >>>> RCVHANDLR.TEXT ; ---------------------------- ; RCVHNDLR TTY Receive Handler ; ---------------------------- ; ; Two routines are provided that maintain an interrupt-driven ; TTY-receive queue. Appropriate PASCAL declarations are: ; ; CONST RCVQSIZE = maximum number of queued characters ; ; TYPE QUEUE = RECORD (* These are order-dependent !!! *) ; QSIZE: INTEGER; ; INP: INTEGER; ; OUTP: INTEGER; ; MAXCHAR: INTEGER; ; DATA: PACKED ARRAY [0..RCVQSIZE] OF CHAR; ; END; ; VAR RCVQ: QUEUE; (* must be declared in outermost block *) ; ; PROCEDURE RCVINIT (VAR Q: QUEUE; SIZE:INTEGER); EXTERNAL; ; PROCEDURE RCVFINIT; EXTERNAL; ; ; RCVINIT (RCVQ,RCVQSIZE); (* initialize the queue handler *) ; ; WHILE TRUE DO ; WITH RCVQ DO ; IF INP <> OUTP THEN (* characters available *) ; BEGIN ; CH := DATA[OUTP]; ; OUTP := OUTP+1; IF OUTP > QSIZE THEN OUTP := 0; ; ... ; END; ; ; RCVFINIT; (* terminate the queue handler *) ; ; The RECORD declaration for the queue must appear exactly as it ; does above except that you can of course use any names you like. ; Do NOT attempt to lump the first four integer variables together ; into a single group of the form list:INTEGER. In that case, ; the compiler allocates them in reverse order, so that your code ; and the interrupt handler will not agree about which words have ; what meaning. ; ; The queue handler runs continuously as an interrupt-driven task ; at high priority. As characters come in, it advances the queue ; INP pointer and keeps track of the maximum number of characters in ; the queue in the MAXCHAR variable. Queue overflow is indicated ; by MAXCHAR > QSIZE. You must terminate by calling RCVFINIT, or ; the TTY receive interrupts will be left enabled and you will end ; up crashing the system by executing garbage code when the next ; character is received. (RCVFINIT also repairs the interrupt ; vectors for breakpoints and the clock, so failing to call it will ; quite likely crash the system even in the absence of incoming ; TTY characters.) ; ; The manipulation of the clock and BPT interrupt vectors is borrowed ; from UCSD's old communications program. The purpose is to allow ; the clock handler to be interrupted by incoming TTY characters. ; RDB .EQU 177522 ; Receive Data Buffer absolute address RSR .EQU 177520 ; Receive Status Register absolute address RCVINTV .EQU 120 ; Receiver Interrupt Vector address CLKINTV .EQU 100 ; Clock interrupt vector address BPTINTV .EQU 14 ; BPT interrupt vector address QXCINTV .EQU 250 ; QX controller interrupt vector ; .PROC RCVINIT,2 ; (VAR Q:QUEUE, SIZE:INTEGER) ; .DEF BPTLOC ; used to save BPT interrupt handler adrs .DEF BPTPR ; used to save BPT handler priority Q .EQU 4 ; stack offset for Q address SIZE .EQU 2 ; stack offset for QSIZE value ; MOV Q(SP),R0 ; obtain the Q record address MOV R0,RCVQADRS ; remember Q address MOV SIZE(SP),(R0)+ ; store size in QSIZE word MOV #0,(R0)+ ; clear INP, OUTP, and MAXCHAR MOV #0,(R0)+ MOV #0,(R0) ; MOV @#BPTINTV,BPTLOC ; save old BPT handler address MOV @#BPTINTV+2,BPTPR ; and old BPT handler priority MOV @#CLKINTV,@#BPTINTV ; make BPT vector point to old clock MOV #0,@#BPTINTV+2 ; and let it run at low priority MOV #CLKHNDLR,@#CLKINTV ; and replace clock handler with ours MOV #0,@#QXCINTV+2 ; make floppy interruptable ; MOV #RCVHNDLR,@#RCVINTV ; store interrupt handler address MOV #200,@#RCVINTV+2 ; set interrupt priority 4 for TTY input MOV #100,@#RSR ; enable interrupts for TTY input ; MOV (SP)+,R0 ; pop return address from stack ADD #4,SP ; discard 2 parameters (4 bytes) JMP @R0 ; and return to PASCAL interpreter ; RCVQADRS .WORD 0 ; holds Q address for handler BPTLOC .WORD 0 ; saves old BPT handler location BPTPR .WORD 0 ; saves old BPT handler priority ; QSIZE .EQU 0 ; offset from Q INP .EQU 2 ; likewise OUTP .EQU 4 MAXCHAR .EQU 6 DATA .EQU 10 ; RCVHNDLR: MOV R0,-(SP) ; free registers R0, R1, R2 for use MOV R1,-(SP) MOV R2,-(SP) MOV RCVQADRS,R2 ; fetch Q address saved by RCVINIT MOV INP(R2),R0 ; fetch INP value MOV R0,R1 ; make a working copy ADD R2,R1 ; R1 = address (Q) + value (INP) MOVB @#RDB,DATA(R1) ; DATA[INP] := input character BICB #200,DATA(R1) ; clear bit 8 (parity) BEQ EXIT ; ignore nulls (do not bump INP) INC R0 ; INP := INP+1 CMP QSIZE(R2),R0 BPL NOWRAP ; if QSIZE >= INP then no wraparound CLR R0 ; else INP := 0 NOWRAP MOV R0,INP(R2) ; restore INP ; SUB OUTP(R2),R0 BMI INOUT BEQ INOUT BR OUTIN ; if INP > OUTP, # char = INP - OUTP INOUT ADD QSIZE(R2),R0 ; otherwise, # char = QSIZE+1 + INP - OUTP ADD #1,R0 OUTIN CMP MAXCHAR(R2),R0 BPL EXIT ; if MAXCHAR >= # char, exit MOV R0,MAXCHAR(R2) ; otherwise, store new MAXCHAR ; EXIT MOV (SP)+,R2 ; restore registers for caller MOV (SP)+,R1 MOV (SP)+,R0 RTT ; return from interrupt ; CLKHNDLR: COM CLKFLG ; do not reexecute BPT if BPT handler BEQ CLKEXIT ; takes so long that clock ticks again BPT ; let breakpoint transfer to old clock CLKEXIT COM CLKFLG ; reset flag RTI ; and exit ; CLKFLG .WORD 0 ; flags reentry before BPT exit ; .PROC RCVFINIT .REF BPTLOC ; old BPT handler loc, saved by RCVINIT .REF BPTPR ; old BPT handler priority, likewise ; MOV #0,@#RSR ; disable receive interrupt MOV @#BPTINTV,@#CLKINTV ; repair clock interrupt vector MOV @#BPTPR,@#BPTINTV+2 ; reestablish BPT handler priority MOV @#BPTLOC,@#BPTINTV ; repair BPT handler address MOV #340,@#QXCINTV+2 ; repair QX controller vector RTS PC ; and return ; .END >>>> RECSW.TEXT (* RECEIVE SECTION *) segment procedure recsw(var rec_ok: boolean); function rdata: char; (* send file data *) var num, len: integer; ch: char; begin repeat if numtry > maxtry then begin state := 'a'; exit(rdata) end; num_try := num_try + 1; ch := rpack(len,num,recpkt); (* receive a packet *) 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 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 *) spack('Y',num,6,packet); numtry := 0; (* reset try counter *) (* stay in same state *) end (* if *) else (* wrong number *) state := 'a' (* so abort *) end (* if *) else (* right packet *) begin bufemp(recpkt,f,len); (* write data to file *) spack('Y',(n mod 64),0,packet); (* ACK packet *) oldtry := numtry; (* reset try counters *) if numtry > 1 then clearbuf(rq); (* clear buffer *) 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 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 *) spack('Y',num,0,packet); clear_buf(rq); (* and empty out buffer *) numtry := 0; (* reset try counter *) state := state; (* stay in same state *) end (* if *) else state := 'a' (* not previous packet, abort *) end (* if 'F' *) else if (ch = 'Z') then (* end of file *) begin if (num <> (n mod 64)) then(* wrong packet, abort *) begin rdata := 'a'; exit(rdata) end; (* if *) spack('Y',n mod 64,0,packet); (* ok, ACK it *) close(f,lock); (* close up the file *) n := n + 1; (* bump packet counter *) state := 'f'; (* go to complete state *) 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 (* some other packet type, *) state := 'a' (* abort *) 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; begin (*$I-*) (* turn off i/o checking *) reset(f,fn); exist := (ioresult = 0) (*$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 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 *) 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 *) refresh_screen(numtry,n); if ch = 'S' then (* send init, maybe our ACK lost *) begin if (oldtry > maxtry) then (* too many tries, abort *) begin rfile := 'a'; exit(rfile) end; (* if *) n := n - 1; if num = (n mod 64) then (* previous packet mod 64? *) begin (* yes, ACK it again *) spar(packet); (* with our send init params *) spack('Y',num,6,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 rfile := 'a'; exit(rfile) end; (* if *) n := n - 1; if num = (n mod 64) then (* previous packet mod 64? *) begin (* yes, ACK it again *) 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 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 ioerror(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 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 (* some weird state, so abort *) rfile := 'a' end; (* rfile *) 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 *) 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 *) ctl_set := [chr(1)..chr(31),chr(del),quote]; spack('Y',n mod 64,6,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 rinit := 'a' (* abort *) 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'] then case state of 'd': state := rdata; 'f': state := rfile; 'r': state := rinit; 'c': begin rec_ok := true; exit(recsw) end; (* case c *) 'a': begin rec_ok := false; exit(recsw) end (* case a *) end (* case *) else (* state not in legal states *) begin rec_ok := false; exit(recsw) end (* else *) end; (* recsw *) >>>> SENDB.TEXT ; ------------------------------ ; . SENDS TTY Output Routine . ; ------------------------------ ; ; SENDBRK is a routine to send a continuous break to an IBM mainframe. ; The appropriate PASCAL declaration is: ; ; PROCEDURE SENDBRK; EXTERNAL; (*to send a break*) ; ; XDB .EQU 177526 ; absolute address, transmit data buffer XSR .EQU 177524 ; absolute address, transmit status register ; ; .PROC SENDBRK ; SNDB1: BIT #200,@#XSR ; wait for previous char to complete BEQ SNDB1 ; MOV #1,@#XSR ; transmit continuous break MOV #310,R1 ; wait 200 (=310 octal) milliseconds SNDB2: MOV #124,R0 SNDB3: SUB #1,R0 BNE SNDB3 SUB #1,R1 BNE SNDB2 MOV #0,@#XSR ; clear continuous break ; RTS PC ; and return ; .END >>>> SENDSW.TEXT (* Send Section *) segment procedure sendsw(var send_ok: boolean); var io_status: integer; procedure openfile; (* resets file & gets past first 2 blocks *) begin (*$I-*) (* turn off compiler i/o checking temporarily *) reset(oldf,filename); (*$I+*) (* turn compiler i/o checking back on *) io_status := io_result; if (iostatus = 0) then if (pos('.TEXT',filename) = length(filename) - 4) then (* is a text file, so *) i := blockread(oldf,filebuf,2); (* skip past 2 block header *) 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); clear_buf(rq); refresh_screen(numtry,n); spack('S',n mod 64,6,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]; 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; (* send a data packet *) spack('D',n mod 64,sizearray[current],packarray[current]); refresh_screen(numtry,n); (* set up next packet *) sizearray[b] := bufill(packarray[b]); ch := rpack(len,num,recpkt); (* receive a packet *) 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 clear_buf(rq); (* if anything in buffer, flush it *) 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 state := 'a' (* on any other goto abort state *) end; (* while *) size := sizearray[current]; packet := packarray[current]; sdata := state end; (* sdata *) function sfile: char; (* send file header *) var num, len, i: integer; ch: char; fn: packettype; oldfn: string; procedure legalize(var fn: string); (* make sure file name will be legal to other computer *) var count, i, j, l: integer; procedure uppercase(var s: string); var i: integer; 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 *) size := bufill(packet); (* get first data from file *) (* while waiting for response *) 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(sfile) (* 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 F state *) exit(sfile); 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)); close(oldf); 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(clear_screen)); io_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; exit(sendsw) end (* else *) end; (* sendsw *)