IMD 1.17: 14/03/2012 8:43:17 PRGS: B3466A 3.5" DS      PRGS  M''MAKE_PRGSTK $0#/CONVERTC__2$0SEDITORT___K#$1'FILERT____K"Ô$2’MATCHSTRT_K/$29.YLIBRARIANTK$3' ************************************************ * * * LIBRARIAN * * * ************************************************ cLIBRARIAN n lh1 oLIBRARIAN ldx Copyright Hewlett-Packard Co.,1982,1994 All rights reserved. iLIBRARIAN alkq ************************************************ * * * EDITOR * *  * ************************************************ cEDITOR n lh1 oEDITOR ldx Copyright Hewlett-Packard Co.,1982,1994 All rights reserved. iEDITOR alkq ************************************************ *  * * FILER * * * ************************************************ aMATCHSTR n cFILER n lh1 oFILER ldx Copyright Hewlett-Packard Co.,1982,199     Z$>>4ǜ>9J083T@@(@Y̞ϝ\?ϛd?]>ƅ̞ƴ@V_BASE/@*0>?? ??TƏ,ƎlO?>?THz?<?p-nlln.-@t nz .tr 0f nz .t  .tRh nz /N, .Ѯ`/. <xHn~N/N np4 All rights reserved. iFILER aiMATCHSTR alkq uftype; var T: text); END; (Ct[1Vg/Nb n h<Hhp(R@HC"HQ?/////<a?p-nlln.-@t nz .tr 0f nz .t  .tRh nz /N, .Ѯ`/. <xHn~N/N np"n"iHi/<Nھ n h(VDJf(f/<. B/N n h<HhHz>N n hC-IC-IJ. f*?<"n)?/.N n/(N nVDr??/.N nVDJg "n"i<HiHz hK fBpr.~-Alln.-@t .tA~r 0f .tA~  .tRhHn n .Hpp.~/Np.~ѮU/. N_y/N|J.yg$ n . R/. N/NR`Ol . n-@ n .B0 .RhN^ _PONNV/-/Hzd+OBN` n h<HhHzN` n h<HhHzhN/<. B n/(NJ. g n h<HhHz0N`z n h<Hhp(R@HC"HQ?/////Hz?<?\ϴCF>l >CONVERT_TEXT__BASERCONVERT_TEXT_ANY_TO_UCSDR,CONVERT_TEXT_1_1RCONVERT_TEXT_UCSD_TO_ANY/RCONVERT_TEXT_CONVERT_TEXTRt CONVERT_TEXTN׀?/////Hz0?<?p-nlln.-@t nz .tr 0f nz .t  .tRh nz /N, .Ѯ`/. <xHn~N/N np ERRORTYPE = (FATAL,NONFATAL); {pagebuftype = packed array[0..pagesize-1] of char; } PAGE = 0..MAXPAGE; NAME = PACKED ARRAY [1..8] OF CHAR; PTYPE = PACKED ARRAY [0..MAXSTRING] OF CHAR; COMMANDS = ( hK fBpr.~-Alln.-@t .tA~r 0f .tA~  .tRhHn n .Hpp.~/Np.~ѮU/. N_y/N|J.yg$ n . R/. N/NR`Ol . n-@ n .B0 .RhN^ _PONNV/-/Hzd+OBILLEGAL,ADJUSTC,COPYC,DELETEC,FINDC,INSERTC,JUMPC,LISTC,MACRODEFC, PARAC,QUITC,REPLACEC,SETC,VERIFYC,XECUTEC,ZAPC,REVERSEC,FORWARDC,UP, DOWN,LEFT,RIGHT,TABB,DIGIT,DUMPC,ADVANCE,SPACE,EQUALC,SLASHC); CTYPE = (FSS,GOHOME,ET (* (c) Copyright Hewlett-Packard Company, 1985,1991. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of HewOEOL,ETOEOS,USS); SCREENCOMMAND =(WHOME,ERASEEOS,ERASEEOL,CLEARLNE,CLEARSCN,UPCURSOR, DOWNCURSOR,LEFTCURSOR,RIGHTCURSOR); KEYCOMMAND = (BACKSPACEKEY,DC1KEY,EOFKEY,ETXKEY,ESCAPEKEY,DELKEY,UPKEY, DOWNKEY,LEFTKEY,lett-Packard Company. RESTRICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a).RIGHTKEY,NOTLEGAL); HEADER = (* Page Zero layout changed 22-JUN-78 *) RECORD CASE BOOLEAN OF TRUE: (BUF: pagebuftype); FALSE:(dummy1: char; {needed to get alignment compatibility} DEFINED: BOOLEAN; (* New file HEWLETT-PACKARD COMPANY Fort Collins, Colorado *) $copyright 'COPYRIGHT (C) 1985,1991 BY HEWLETT-PACKARD CO.'$ $debug off$ $heap_dispose off$ $ovflcheck off$ $iocheck off$ $range off$ $REF 50$ $MODCAL$ $UCSD$ PROGRAM EDTR(input nulls => false *) COUNT: shortint; (* The count of valid markers *) NAME: ARRAY [0..9] OF NAME; POFFSET: PACKED ARRAY [0..29] OF byte; dummy2: char; AUTOINDENT: BOOLEAN; (* En, output, keyboard); module edit1; $SEARCH 'CONVERT'$ import sysglobals, sysdevs, ci, misc, fs, convert_text; export CONST (* Unless otherwise noted all constants are upper bounds from zero. *) editversion = '[3.25]'; editdate vironment stuff follows *) dummy3: char; FILLING: BOOLEAN; dummy4: char; TOKDEF: BOOLEAN; LMARGIN: 0..MAXSW; RMARGIN: 0..MAXSW; PARAMARGIN: 0..MAXSW; = '28-Oct-91'; MAXBUFSIZE = 8388607; (* 2^23-1 *) MAXSW = 132; (* Maximum allowable SCREENWIDTH *) MAXSTRING = 127; MAXCHAR = pagesize-1; MAXPAGE = mmaxint; {pagesize = 1024; } (* The following ASCII character dummy5:char; RUNOFFCH: CHAR; CREATED: DATEREC; LASTUSED: DATEREC; newmarkers: boolean; ignorecase: boolean; FILLER: PACKED ARRAY [0..887] OF CHAR) END;      dated : boolean; (* WAH to decide if need update 4/14/80 *) bufovflw : boolean; { used if buffer overflow on reading input} inreaderror : boolean; { used if error on reading input } out CKED ARRAY [SCREENCOMMAND] OF CHAR END; KEYBRD : PACKED RECORD (* Keyboard Control Record *) PREFIX: CHAR; HASPREFIX: PACKED ARRAY [KEYCOMMAND] OF BOOLEAN; CH: : boolean; { result of procedure do_out } ETXX : INTEGER; BSS : INTEGER; DELL : INTEGER; ESCC : INTEGER; BSPCE : INTEGER; (* Moved from CONST 30-Jan-78 BSPCE: 11/2/78*) ADJU PACKED ARRAY [KEYCOMMAND] OF CHAR END; screenm : scrptr; tscreenwidth : integer; tscreenheight : integer; tscreensize : integer; vstr : vid; pstr : fid; nstr : tid; entkey  {crtword=packed record defined in KBD upperbyte,character:char; end; } scrtype=packed array[0..0] of crtword; scrptr=^scrtype; VAR tempior : integer; generrmsg : string80;STPROMPT : STRING80; { MCh } INSERTPROMPT : STRING80; { MCh } DELETEPROMPT : STRING80; { MCh } COMPROMPT : STRING80; { MCh } prompt2 : STRING80; {Promptline 11/2/78 M. Bernar efilename : fid; (* 'No file present' filename dst 01/80 *) efilekind : filekind; (* file type of last file read in *) CURSOR : 0..MAXBUFSIZE; BUFCOUNT : 0..MAXBUFSIZE; (* Number of valid chd} TRASH : INTEGER; (* Totally without redeeming social value *) TARGET : PTYPE; SUBSTRING : PTYPE; SLENGTH : INTEGER; (* Length of target and substring *) TLENGTH : INTEGER; SDEFINED aracters in the EBUF *) STUFFSTART : 0..MAXBUFSIZE; (* GETLEADING *) LINESTART : EPTRTYPE; (* sets *) BYTES : INTEGER; (* these *) BLANKS : INTEGER;  : BOOLEAN; (* Whether the strings are valid *) TDEFINED : BOOLEAN; COPYLENGTH : EPTRTYPE; (* For Copyc *) COPYSTART : EPTRTYPE; (* For Copyc *) COPYLINE : BOOLEAN; (* " W (* these *) CH : CHAR; DIRECTION : CHAR; (* '>' or '<' *) REPEATFACTOR : INTEGER; BUFSIZE : INTEGER; SCREENWID : INTEGER; (* Moved to var 26-Jan *) SCREENHITE AH 1/18/80*) COPYOK : BOOLEAN; (* " WAH 1/18/80*) iflag : BOOLEAN; (* " WAH 1/18/80*) INFINITY : BOOLEAN; (* for slashc *) TRANSLATE : ARRAY [CHAR] OF COMMANDS; PAGE : INTEGER; (* " " " " *) ECOMMAND : COMMANDS; LASTPAT : 0..MAXBUFSIZE; EBUF : ^BUFRTYPE; KIND : ARRAY [CHAR] OF INTEGER; (* for token find *) LINE1PTR : 0..MAXBUFSIZE; MIDDLE ZERO : HEADER; MSG : STRING80; PROMPTLINE : STRING80; BLANKAREA : ARRAY [0..MAXSW] OF CHAR; SAVETOP : STRING80; (* Dumb terminal patch - for BLANKCRT(1) *) SCREENN : PACKED RECORD (* Screen Co : INTEGER; (* Middle line on the screen *) NEEDPROMPT : boolean; prompt2flag : boolean; { 7 Apr 80 - MCh: second prompt line } recovering : boolean; { 19 May 80 - MCh: recover text after error } upntrol Record *) PREFIX: CHAR; HEIGHT,WIDTH: byte; CANUPSCROLL,CANDOWNSCROLL,SLOW: BOOLEAN; HASPREFIX: PACKED ARRAY [SCREENCOMMAND] OF BOOLEAN; CH: PA     : string[6]; { 3.0 ITF fixes 4/6/84} exckey : string[6]; { 3.0 ITF fixes 4/6/84} esckey : string[6]; { 3.0 ITF fixes 4/6/84} function fatalifstreaming : errortype; function oktostop : boolean; procedure i to Return to Editor'); repeat ch := uclc(getch); until ch in ['Y','N']; oktostop := ch = 'Y'; end; procedure dodownscroll; begin moveright(screenm^[tscreenwidth{1,0}], screenm^[tscreenwidth*2{2,0}], (tscreensize-2*tscrnitialize; procedure do_out; PROCEDURE ERROR(S:STRING80;HOWBAD:ERRORTYPE); PROCEDURE ERASETOEOL(X,LINE:INTEGER); FUNCTION GETCH:CHAR; PROCEDURE ECLEARSCREEN; PROCEDURE EERASEOS(X,LINE:INTEGER); PROCEDURE ECLEARLINE(Y:INTEGER); FUNCTION MAPTOCOMMAND(CH:CHeenwidth)*2); end; procedure doupscroll; var i:integer; begin moveleft(screenm^[tscreenwidth*2{2,0}], screenm^[tscreenwidth{1,0}], (tscreensize-2*tscreenwidth)*2); for i:=0 to tscreenwidth-1 do screenm^[(tscreenheight-1)*tsAR): COMMANDS; FUNCTION UCLC(CH:CHAR): CHAR; PROCEDURE EPROMPT; PROCEDURE REDISPLAY; FUNCTION MIN(A,B:INTEGER): INTEGER; FUNCTION MAX(A,B:INTEGER): INTEGER; FUNCTION SCREENHAS(WHAT: SCREENCOMMAND): BOOLEAN; PROCEDURE CONTROL(WHAT: SCREENCOMMAND); PROCEcreenwidth+i].wholeword := ord(' '); end; PROCEDURE INITIALIZE; LABEL 1; VAR BLOCK: ^BLOCKTYPE; CH: CHAR; I,QUIT,GAP,BLKS: INTEGER; workopenfailed: boolean; THEFILE: text; PROCEDURE MAP(CH:CHAR; C:COMMANDS); BEGIN TRANSLATE[CH]:=C; IF CH INDURE PUTMSG; PROCEDURE HOME; PROCEDURE ERRWAIT; PROCEDURE BLANKCRT(Y: INTEGER); FUNCTION LEADBLANKS(PTR:EPTRTYPE;VAR BYTES: INTEGER): INTEGER; PROCEDURE CENTERCURSOR(VAR LINE: INTEGER; LINESUP: INTEGER; NEWSCREEN:BOOLEAN); PROCEDURE FINDXY(VAR INDENT,LIN ['A'..'Z'] THEN TRANSLATE[CHR(32+ORD(CH))] := C; (* LC TOO *) END; PROCEDURE DEFPROMPTS; (* DEFINES VARIABLE PROMPTLINES MAB 11/2/78*) BEGIN { 7 Apr 80 - MCh: added 'prompt2' for second prompt line } COMPROMPT:= ' Edit: Adjst Cpy Dlete Find IE: INTEGER); PROCEDURE actualXY(VAR INDENT,LINE: INTEGER); { NEW FOR 3.0 bug #7 } PROCEDURE SHOWCURSOR; FUNCTION GETNUM: INTEGER; PROCEDURE GETLEADING; FUNCTION OKTODEL(CURSOR,ANCHOR:EPTRTYPE):BOOLEAN; PROCEDURE LINEOUT(VAR PTR:EPTRTYPE; BYTES,BLANKS,LInsrt Jmp Rplace Quit Xchng Zap ?'; prompt2 := ' Edit: Margin Page Set environment Verify ? '; prompt2:=prompt2+editversion; INSERTPROMPT:= ' Insert: Text , [<'+exckey+'> accepts, <' +esckey+'> esNE: INTEGER); PROCEDURE UPSCREEN(FIRSTLINE,WHOLESCREEN:BOOLEAN; LINE: INTEGER); PROCEDURE READJUST(CURSOR: EPTRTYPE; DELTA: INTEGER); PROCEDURE THEFIXER(PARAPTR: EPTRTYPE;RFAC: INTEGER;WHOLE: BOOLEAN); PROCEDURE GETNAME(MSG:STRING80; VAR M:NAME); PROCEDUREcapes]'; { 3.0 ITF fix } DELETEPROMPT:= ' Delete: < > [<'+exckey+'> deletes, <' +esckey+'> aborts]'; { 3.0 ITF fix } ADJUSTPROMPT:= ' Adjust: Ljust Rjust Center [<'+exckey+'> to leave]'; { 3.0 ITF fix } IF (SCREENWID+1) accepts,<' +esckey+'> aborts'; ming := nonfatal; end; function oktostop : boolean; begin eclearscreen; writeln(output); fgotoxy(output,0,9); writeln('Are you sure you want to STOP without updating?'); writeln(' Type Yes to STOP Without Update'); writeln(' Type No  { 3.0 ITF fix } DELETEPROMPT:=' Del: <'+exckey+'> deletes,<' +esckey+'> aborts'; { 3.0 ITF fix } ADJUSTPROMPT:=' Adjst: Lft Rt Ctr <'+exckey+'> leaves';       if not done then begin pages:=pages+1; WRITE(output,'.'); IF pages*2 = ERRBLK THEN CURSOR:=BUFCOUNT+ERRSYM; (* errblk > 0 only *) NOTNULS:=SCAN(-pagesize,<>CHR(0),pagebuffer[maxchar])+pagesiz CH[CLEARSCN] := CLEARSCREEN; HASPREFIX[CLEARSCN] := PREFIXED[6]; CH[UPCURSOR] := RLF; HASPREFIX[UPCURSOR] := PREFIXED[0]; CH[DOWNCURSOR] e; OVFLW := NOTNULS+BUFCOUNT>=BUFSIZE-10; IF NOT OVFLW THEN BEGIN moveleft(pagebuffer, EBUF^[BUFCOUNT], NOTNULS); BUFCOUNT:=BUFCOUNT+NOTNULS; END; end; until:= CHR(LF); HASPREFIX[DOWNCURSOR] := FALSE; CH[LEFTCURSOR] := BACKSPACE; HASPREFIX[LEFTCURSOR] := PREFIXED[1]; CH[RIGHTCURSOR] := NDFS; HASPREFIX[RIGHTCURSOR]  { 3.0 ITF fix } COMPROMPT:= ' Edit: Adj Cpy Del Find Insrt Jmp Rpl Quit Xch ?'; prompt2:= ' Edit: Mrgn Page Set Vrfy Zap ? '; prompt2:=prompt2+editversion; END; END; PROCEDURE READFILE; var pages,  done or ovflw or readerror; end; if readerror then begin getioerrmsg(generrmsg,tempior); error(generrmsg,fatalifstreaming); end else IF ovflw THEN ERROR('Buffer overflow.',fatalifstreaming); bufovflw:=ovflw; { set global  NOTNULS: integer; pagebuffer: pagebuftype; OVFLW, DONE: BOOLEAN; readerror : BOOLEAN; BEGIN readerror := false; ECLEARSCREEN; (* Dumb terminal patch *) WRITE(output,'Reading'); WITH USERINFO^, fibp(addr(THEFILE))^ do boverflow flag } inreaderror := readerror; close (thefile) { no need to keep it open } END; { readfile } PROCEDURE LOADFROMSYSCOM; (* A rather perverted procedure that takes the syscom^.crtcntrl record and loads it into the Screen Control Recordegin if fkind = textfile then begin am := amtable^[untypedfile]; {FORCE NO INTERPRETATION OF BITS} fleof := fleof + (-fleof) mod pagesize; {to allow reading 1.0 text files} freadbytes(THEFILE, PAGEZERO, p and the syscom^.crtinfo record and loads it into the Keyboard Control Record *) BEGIN WITH SYSCOM^ DO BEGIN (* Miscellaneous stuff *) WITH SCREENN DO BEGIN PREFIX:=CRTCTRL.ESCAPE; HEIGHT:=CRTINFO.HEIGHT-agesize); if ioresult <> ord(inoerror) then begin tempior := ioresult; readerror := true; fillchar(PAGEZERO, pagesize, chr(0)); end else WRITE(output,'.'); end2;{WAH 4/17/80} WIDTH:=CRTINFO.WIDTH-1; { jws 11/25/80 kluge for chipmunk screen } CANUPSCROLL:=TRUE; CANDOWNSCROLL:=syscom^.miscinfo.candownscroll; END; KEYBRD.PREFIX := CRTINFO.PREFIX; (* The screen ... *)  else fillchar(PAGEZERO, pagesize, chr(0)); pages := 0; ovflw := false; done := false; if not readerror then repeat if fkind = textfile then if fpos >= fleof then done := true else freadbytes (THEFILE, pag SCREENN.CH[ERASEEOS] := CRTCTRL.ERASEEOS; SCREENN.HASPREFIX[ERASEEOS] := CRTCTRL.PREFIXED[3]; SCREENN.CH[ERASEEOL] := CRTCTRL.ERASEEOL; SCREENN.HASPREFIX[ERASEEOL] := CRTCTRL.PREFIXED[2]; wiebuffer, pagesize) else if eof(THEFILE) then done := true else any_to_UCSD(THEFILE, pagebuffer); if ioresult <> ord(inoerror) then begin tempior := ioresult; readerror := true; end else th screenn, crtctrl do begin CH[WHOME] := HOME; HASPREFIX[WHOME] := PREFIXED[4]; CH[CLEARLNE] := CLEARLINE; HASPREFIX[CLEARLNE] := PREFIXED[7];       := PREFIXED[8]; end; (* ... and the keyboard *) with keybrd, crtinfo do begin CH[BACKSPACEKEY] := BACKSPACE; HASPREFIX[BACKSPACEKEY] := PREFIXED[12]; CH[DC1KEY] key:='sel'; { 3.0 ITF fix 4/6/84 } esckey:='esc'; { 3.0 ITF fix 4/6/84 } end { 3.0 ITF fix 4/6/84 } else begin  := CHR(DC1); (* Not in record *) HASPREFIX[DC1KEY] := FALSE; CH[EOFKEY] := EOF; HASPREFIX[EOFKEY] := PREFIXED[9]; CH[ETXKEY] := ETX;  { 3.0 ITF fix 4/6/84 } entkey:='ent'; { 3.0 ITF fix 4/6/84 } exckey:='exc'; { 3.0 ITF fix 4/6/84 } esckey:='sh-exc'; { 3.0 ITF fix 4/6/84 } end;  HASPREFIX[ETXKEY] := PREFIXED[13]; CH[ESCAPEKEY] := ALTMODE; HASPREFIX[ESCAPEKEY] := PREFIXED[10]; CH[DELKEY] := LINEDEL; HASPREFIX[DELKEY] := P { 3.0 ITF fix 4/6/84 } WITH PAGEZERO DO BEGIN (* Load Screen and Keyboard Control Records from SYSCOM *) LOADFROMSYSCOM; (* Init the translate table *) for ch:= chr(0) to chr(255) do REFIXED[11]; CH[UPKEY] := UP; HASPREFIX[UPKEY] := PREFIXED[3]; CH[DOWNKEY] := DOWN; HASPREFIX[DOWNKEY] := PREFIXED[2]; CH[LEFTKEY]  translate[ch]:=illegal; MAP('A',ADJUSTC); MAP('C',COPYC); MAP('D',DELETEC); MAP('F',FINDC); MAP('I',INSERTC); MAP('J',JUMPC); MAP('L',LISTC); MAP('M',MACRODEFC); MAP('P',PARAC); MAP('Q',QUITC); MAP('R',REP := LEFT; HASPREFIX[LEFTKEY] := PREFIXED[1]; CH[RIGHTKEY] := RIGHT; HASPREFIX[RIGHTKEY] := PREFIXED[0]; end; BSPCE:=ORD(CRTINFO.BACKSPACE); {Went soft 11/2/78 M. BeLACEC); MAP('S',SETC); MAP('V',VERIFYC); MAP('X',XECUTEC); MAP('Z',ZAPC); MAP(',',REVERSEC); MAP('>',FORWARDC); MAP('.',FORWARDC); MAP('+',FORWARDC); MAP('-',REVERSEC); MAP('?',DUMPC); MAP('/',SLASHC); MAP('=',EQUALC); rnard} {Now test to see that the essential keys have been given a value other than null. If not then assign them a default value. Hopefully, this will end up an INTERP change--M. Bernard} IF BSPCE = 0 THEN BSPCE := 8;  MAP('<',REVERSEC); (* Arrows *) (* NEXTCOMMAND and GETNUM handle VT-52 style vector keys *) if syscom^.crtctrl.escape=chr(0) then WITH syscom^ DO BEGIN MAP(crtinfo.up,UP); MAP(crtinfo.DOWN,DOWN); MAPIF KEYBRD.CH[ETXKEY]=CHR(0) THEN KEYBRD.CH[ETXKEY]:=CHR(3); END; END; PROCEDURE MAPSPECIAL(K:KEYCOMMAND;C:COMMANDS); BEGIN IF NOT KEYBRD.HASPREFIX[K] THEN MAP(KEYBRD.CH[K],C); END; BEGIN { MAIN BODY OF INITIALIZE } bufovflw := false; (crtinfo.LEFT,LEFT); MAP(crtinfo.RIGHT,RIGHT); END; map(syscom^.crtinfo.chardel, left); MAP(EOL,ADVANCE); (* CR IS ADVANCE *) MAP(CHR(HT),TABB); MAP(CHR(SP),SPACE); (* Digits *) FOR CH:='0' TO '9' DO MAP(CH,DIinreaderror := false; out := false; updated := false; {no file updates yet WAH 4/14/80} if kbdtype=itfkbd then begin { 3.0 ITF fix 4/6/84} entkey:='ret'; { 3.0 ITF fix 4/6/84 } excGIT); (* Variable buffer sizing... added 17-Jan-78 *) blks:=(memavail div pagesize)-5; {the 5 pages is a guess for stack size} newwords(ebuf, blks*(pagesize div 2)); bufsize:=blks*pagesize-1; (* Open the workfile *)      workopenfailed then BEGIN if not((USERINFO^.GOTSYM) or (userinfo^.errnum<>0)) then begin writeln(output,'No workfile found.'); MSG:='File? (<'+entkey+'> for new file, exits) '; ufcount then ebuf^[i]:=chr(32); end; (* Initialize everything else! *) LASTPAT:=1; (* Init to the beginning of the buffer (for equalc) *) COPYOK:=FALSE; LINE1PTR:=1; (* These do not yet go through the Screen and Key {3.0 ITF fix } end; REPEAT WRITELN(output,MSG); WRITE(output,': '); READLN(INPUT,EFILENAME); if strlen(efilename) > 0 then for i :=board control records *) WITH SYSCOM^.CRTINFO DO BEGIN ESCC:=ORD(ALTMODE); BSS:=ORD(CHARDEL); DELL:=ORD(LINEDEL); SCREENWID:=WIDTH-2;{ changed to 2 11/25/80 jws -- chipmunk kluge} SCR setstrlen(efilename,0); EBUF^[0]:=EOL; BUFCOUNT:=1; CURSOR:=1; ECLEARSCREEN; DIRECTION:='>'; {must be initialized now for display in ERROR} writeln; WRITELN(output,'Editor [Rev. ', str(edi 1 to strlen(efilename) do {RAM 15JAN82} IF EFILENAME[i]=SYSCOM^.CRTINFO.ALTMODE THEN escape(101); fixname(efilename,textfile); IF STRLEN(EFILENAME)=0 THEN BEGIN fillchar(PAGEZERO, SIZEtversion,2,strlen(editversion)-2), ' ',editdate,']'); writeln; writeln('Copyright Hewlett-Packard Company, 1982, 1991.'); writeln(' All rights reserved.'); writeln; workopenfailed:=false; IOF(PAGEZERO), chr(0)); GOTO 1; END; reset(THEFILE,EFILENAME,'shared');{WAH 4/17/80} tempior := ioresult; if tempior <> ord(inoerror) then begin writeln('File: 'F (USERINFO^.GOTSYM) or (userinfo^.errnum<>0) THEN BEGIN if userinfo^.errnum = 0 then RESET(THEFILE,USERINFO^.SYMFID,'shared') else begin RESET(THEFILE,USERINFO^.ERRFID,'shared'); ,efilename); getioerrmsg(generrmsg,tempior); MSG:='Error: '+ generrmsg + '. File? '; if streaming then begin writeln(output,msg); escape(-1);  with userinfo^ do if not(gotsym and (errfid=symfid)) then efilename:=errfid; end; IF IORESULT<>ord(inoerror) THEN begin tempior := ioresult; getioerrmsg(generrmsg,tempior);  end; end; UNTIL tempior=ord(inoerror); END; fstripname(efilename,vstr,pstr,nstr); if ioresult = ord(inoerror) then efilekind := fibp(addr(THEFILE))^.fkind else begin set writeln(output,'Error: ',generrmsg); if streaming then ERROR('Workfile lost.',FATAL) else begin workopenfailed:=true; writeln(output,'Failed to open workfile.'); strlen(efilename,0); setstrlen(vstr,0); setstrlen(pstr,0); setstrlen(nstr,0); end; READFILE; (* Read in the file *) 1: IF (EBUF^[BUFCOUNT-1]<>EOL) OR (BUFCOUNT=1) THEN msg:='File? (<'+entkey+'> for new file, exits)'; { 3.0 ITF fix } end; end; END; if not((USERINFO^.GOTSYM) or (userinfo^.errnum<>0)) or  BEGIN EBUF^[BUFCOUNT]:=EOL; BUFCOUNT:=BUFCOUNT+1; END; i:=1; { remove form feeds.. mod 12/21/81 jws } while i 10) {pagezero looks like garbage} or (count < 0) or (lmargin > rmargin) or (created.year > lastused.year) THEN gin opt1 := 'exclusive'; if ch = 'S' then begin opt2 := '.' + suffixtable^[efilekind]; addfilesize; fmaketype(thefile, fn, opt1, opt2); end else if ch = 'O' then begin opt2 := '.' + suffixtable^ BEGIN fillchar(BUF,pagesize, chr(0)); SYSDATE(CREATED); LASTUSED:=CREATED; TOKDEF:=TRUE; (* Default mode is T(oken *) FILLING:=FALSE; AUTOINDENT:=TRUE; RUNOFFCH:='^'; LMARGIN:=0; PARAMARG[overkind]; addfilesize; foverfile(thefile, fn, opt1, opt2); end else begin opt2 := '.' + suffixtable^[suffix(fn)]; addfilesize; rewrite (thefile, fn, 'exclusive'); end; if newefile then IN:=5; RMARGIN:=MIN(78,SCREENWID); DEFINED:=TRUE; newmarkers:=true; ignorecase:=false; END else if not newmarkers then begin count:=0; newmarkers:=true; nam begin newefile := false; fstripname(efilename,vstr,pstr,nstr); if ioresult = ord(inoerror) then efilekind := fibp(addr(thefile))^.fkind else begin setstrlen(efilename,0); setse[0]:=' '; end; END(* WITH *); (* Initialize the KIND array for token find *) FOR CH:=CHR(0) TO CHR(255) DO KIND[CH]:=ORD(CH); (* Make them all unique *) FOR CH:='A' TO 'Z' DO KIND[CH]:=ORD('A'); FOR CH:='a' TO 'z' DO KIND[Ctrlen(vstr,0); setstrlen(pstr,0); setstrlen(nstr,0); end; end; if (ioresult <> ord(inoerror)) then if (ch = 'W') or (ch = 'O') then begin tempior := ioresult; home; eclH]:=ORD('A'); FOR CH:='0' TO '9' DO KIND[CH]:=ORD('A'); KIND[EOL]:=ORD(' '); KIND[CHR(HT)] :=ORD(' '); FILLCHAR(BLANKAREA,SIZEOF(BLANKAREA),' '); setstrlen(savetop,0); END(* INITIALIZE *); procedure do_out; LABEL 1,2,3; VAR SAVE: EPTRTYPE; earline(0); getioerrmsg(generrmsg,tempior); write(output,direction,'ERROR: ',generrmsg); efilename := holdfilename; ch := 'W'; goto 3 { get another file name } end else goto 1; end; proc includeflag: boolean; I,blocks: INTEGER; BUF: pagebuftype; FN: FID; holdfilename: FID; THEFILE: text; overkind : filekind; oktosave : boolean; newefile : boolean; {if it is of type TEXTFILE then ...} { 17 Jul 80 - MCh: compute the file siedure breakout(write_em: boolean); var i: integer; begin blocks := 0; { count the number of blocks } CURSOR:=1; WHILE CURSOR < BUFCOUNT-maxchar DO BEGIN I:=SCAN(-maxchar+1,=EOL,EBUF^[CURSOR+maxchar-1]); if write_em then begin      editor without updating'); WRITELN (' Write to a file name and return'); if oktosave then begin writeln(' Save as file new file ',vstr,':',pstr,nstr); writeln(' Overwrite as file ',vstr,':',pstr,nstr); 'O' then overkind := efilekind; if not recovering then BLANKCRT(1); { 20 May 80 - MCh } SYSDATE(PAGEZERO.LASTUSED); breakout(false); if (ch = 'W') and (not streaming) then begin reset(thefile,fn,'shared'); if ioresult = or end; REPEAT CH:=UCLC(GETCH); UNTIL (CH IN ['E','R','W']) or ((ch='U') and not includeflag) or (oktosave and ((ch = 'S') or (ch = 'O')) ) or streaming; writeln(ch); end; if streaming then id(inoerror) then if not unitable^[fibp(addr(thefile))^.funit].uisblkd then begin {PRINTER:, CONSOLE:, #6, etc...} close(thefile); if efilename = fn then begin setstrlen(efile MOVELEFT(EBUF^[CURSOR],BUF,maxchar+I); FILLCHAR(BUF[maxchar+I],ABS(I)+1,CHR(0)); if fibp(addr(THEFILE))^.fkind = textfile then fwritebytes(THEFILE,BUF,pagesize) else UCSD_to_any(BUF, THEFILE); if ioresult <>f not((CH IN ['E','R','W']) or ((ch='U') and not includeflag) or (oktosave and ((ch = 'S') or (ch = 'O')))) then begin writeln(output,'Illegal Quit option.'); escape(-1); end; IF CH='R' THEN GOTO 2; if(ch='E') then  ord(inoerror) THEN GOTO 1; WRITE(output,'.') end; blocks := blocks + 2; CURSOR:=CURSOR+maxchar+I; END; IF CURSOR ord(inoerror) THEN GOTO 1; WRnt to exit without updating?'); writeln(' Type Yes to Exit Without Update'); writeln(' Type No to Return to Editor'); repeat ch := uclc(getch); until ch in ['Y','N']; if ch <> 'ITE(output,'.') end; blocks := blocks + 2 END; end; BEGIN oktosave := (strlen(efilename) <> 0) and (not bufovflw) and (not inreaderror); newefile := false; holdfilename := efilename; OUT := FALSE; with usY' then goto 2; end; OUT:=TRUE; ECLEARSCREEN; GOTO 2; END; SAVE:=CURSOR;{WAH to save cursor for 'W' and 'S' both 4/14/80} 3: { return here after bad file name } IF (CH='W') THEN BEGIN BLANKCerinfo^ do begin includeflag := (errnum<>0) and gotsym and (errfid<>symfid); if includeflag then efilename := errfid; end; if recovering then ch := 'U' { 19 May 80 - MCh: force update } else begin ECLEARSCREENRT(1); WRITE(output,'Name of output file (<'+entkey+'> to return) -->'); { 3.0 ITF fix } READLN(input,FN); fixname(fn,textfile); IF STRLEN(FN)=0 THEN GOTO 2; if str; (* Dumb terminal patch *) SAVETOP:='>Quit:'; WRITELN(output,SAVETOP); if not includeflag then WRITELN(' Update the workfile and leave'); WRITELN (' Exit without updating'); WRITELN (' Return to the len(efilename) = 0 then begin efilename := fn; {dst 01/80} newefile := true; end; END ELSE if (ch='S') or (ch='O') then fn := efilename {dst 01/80} else FN:='*WORK.TEXT'; if ch =      name,0); newefile := false; end; end else begin writeln(fn, ' exists ...'); writeln(' Rewrite then purge old'); writeln(' Overwrite'); writeln('); escape(-1); end; UNTIL CH IN ['E','R']; OUT:= CH='E'; if ch='E' then userinfo^.errnum := 0; CURSOR:=SAVE; (* QW returns to the editor *) END; GOTO 2; (* SORRY ABOUT THAT EDSGER *) 1: if ioresu' Purge old then rewrite'); writeln(' None of the above'); repeat ch := uclc(getch); until ch in ['R','O','P','N']; writeln(ch); if ch = 'O' then overkind := fibplt = ord(inoerror) then ERROR('Writing the file.',fatalifstreaming) else begin tempior := ioresult; getioerrmsg(generrmsg,tempior); error(generrmsg,fatalifstreaming) end; 2:END; PROCEDURE COPYFILE; VAR STARTOFFSET(addr(thefile))^.fkind; if ch = 'P' then close(thefile,'purge') else close(thefile); if ch in ['R','P'] then ch := 'W'; if ch = 'N' then begin { avoid S options } { 3.0 bug #,STOPOFFSET, LEFTPART,PAGE,NOTNULLS,THEREST,LMOVE: INTEGER; DONE,OVFLW: BOOLEAN; BUFR: pagebuftype; STARTMARK,STOPMARK: NAME; FN: STRING80; F: text; PROCEDURE ERRMARKER; BEGIN ERROR('Improper marker specification.',fatalifstreaming); 4 } if newefile then efilename:=''; { 3.0 bug #4 } goto 2; { 3.0 bug #4 } end; { 3.0 bug #4 } end; end escape(102); END; PROCEDURE UNSPLITBUFF; (* Stich the buffer back together again. *) var i: integer; BEGIN MOVELEFT(EBUF^[THEREST],EBUF^[CURSOR],LMOVE); READJUST(LEFTPART+1,CURSOR-(LEFTPART+1)); BUFCOUNT:=BUFCOUNT+(CURSOR-(LEFTPART+1)); {WAH 4/7; openout; WRITE(output,'Writing'); with fibp(addr(THEFILE))^ do if fkind = textfile then begin am := amtable^[untypedfile]; fwritebytes(THEFILE,PAGEZERO,pagesize); if ioresult <> ord(inoerror) THEN GOTO 1;/80 int. ovfl fix} i:=leftpart+1; { remove form feeds in copied file 12/21/81 jws } while i ord(inoerror) then goto 1; WRITELN; WRITELN('Your file is ',BUFCOUNT:1,' bytes long.'); if (ch = 'S') or (ch = 'O') then updated := false; Ithe beginning of the file *) COPYOK:=FALSE; END; PROCEDURE exitcopy(msg: string80; center: boolean); BEGIN ERROR(Msg,fatalifstreaming); UNSPLITBUFF; if center then CENTERCURSOR(TRASH,MIDDLE,TRUE); close (f); escape(102); END; PROCEDURE SPLITBF CH='U' THEN WITH USERINFO^ DO BEGIN SYMFID:='*WORK.TEXT'; GOTSYM:=TRUE; reset(THEFILE,'*WORK.CODE','exclusive'); CLOSE(THEFILE,'PURGE'); GOTCODE:=FALSE; setstrlen(codefid,0); OUT:=TRUE; UF; (* Split the buffer at the Cursor. Therest points to the right part, Lmove is the length of the right part, Leftpart points to the end of the 'left part', and Cursor remains unchanged. *) BEGIN THEREST:=BUFSIZE-(BUFCOUNT-CURSOR); LMOVE:=BUFC userinfo^.errnum := 0; END ELSE BEGIN WRITE(output,'Exit from or Return to the editor? '); REPEAT CH:=UCLC(GETCH); if streaming and not(ch in ['E','R']) then begin writeln('''E'' or ''R'' expectedOUNT-CURSOR+1; LEFTPART:=CURSOR-1; MOVERIGHT(EBUF^[CURSOR],EBUF^[THEREST],LMOVE) END; PROCEDURE PARSEFN; VAR I,LPTR,RPTR,COMMA: INTEGER; MARK: STRING80; BEGIN LPTR:=STRPOS('[',FN); IF LPTR=0 THEN BEGIN (* whole file *) STARTMARK:='      g(generrmsg,tempior); exitcopy (generrmsg,true); end; WRITE(output,'.'); END; end; IF NOT DONE THEN NOTNULLS:=SCAN(-pagesize,<>CHR(0),BUFR[maxchar])+pagesize ELSE NOTNULLS:=0; PAGE:=PAGE+1; END; PROCEDTNULLS) AND NOT DONE DO BEGIN IF (STOPOFFSET>=NOTNULLS) THEN STOPOFFSET:=STOPOFFSET-NOTNULLS; STARTOFFSET:=STARTOFFSET-NOTNULLS; GETNEXT; END; IF (STOPOFFSETPZ.NAME[I]) DO I:=I+1; IF MNAME<>P) ELSE STUFFIT(max(STARTOFFSET-1,0),NOTNULLS-1); WHILE (STOPOFFSET>NOTNULLS) AND NOT DONE DO BEGIN STOPOFFSET:=STOPOFFSET-NOTNULLS; GETNEXT; IF (STOPOFFSETSTRLEN(FN)) THEN ERRMARKER; MARK:=STR(FN,LPTR+1,RPTR-LPTR-1); (* stuff between the brackets *) FN:=STR(FN,1,LPTZ.NAME[I] THEN exitcopy ('Marker not there.',false); OFF:=pz.poffset[3*i]*65536+pz.poffset[3*I+1]*256 + pz.poffset[3*i+2]; END; BEGIN(* findmarkers *) STARTOFFSET:=0; (* default values *) STOPOFFSET:=8388608; (* 2^23 *) with fibp(addr(F))^ dR-1); COMMA:=STRPOS(',',MARK); IF COMMA=0 THEN ERRMARKER; I:=STRLEN(MARK)-COMMA; (* second marker ptr *) MOVELEFT(MARK[1],STARTMARK,MIN(8,COMMA-1)); FILLCHAR(STARTMARK[COMMA],MAX(0,8-(COMMA-1)),' '); MOVELEFT(MARK[COMMA+o if fkind = textfile then begin am := amtable^[untypedfile]; freadbytes(F, PZ, pagesize); if ioresult <> ord(inoerror) then begin tempior := ioresult; getioerrmsg(generrmsg,tempior); 1],STOPMARK,MIN(I,8)); FILLCHAR(STOPMARK[I+1],MAX(0,8-I),' ') END; FOR I:=1 TO 8 DO STARTMARK[I]:=UCLC(STARTMARK[I]); FOR I:=1 TO 8 DO STOPMARK [I]:=UCLC(STOPMARK[I]); fixname(fn,textfile); END; PROCEDURE STUFFIT(START,STOP:INTEGER); (* Pu exitcopy (generrmsg,true); end; end else fillchar(PZ, pagesize, chr(0)); IF (STARTMARK<>' ') OR (STOPMARK<>' ') THEN if pz.newmarkers then begin IF STARTMARK <> ' ' THEN SEARCH(STARTMARK,St the contents of BUFR into EBUF. OVFLW is set to true when there is no more room in the buffer. *) VAR AMOUNT: INTEGER; BEGIN IF START<=STOP THEN BEGIN AMOUNT:=STOP-START+1; IF CURSOR+AMOUNT+250(*slop*)>=THEREST THEN exitcopyTARTOFFSET); IF STOPMARK <> ' ' THEN SEARCH(STOPMARK,STOPOFFSET) end else begin pz.count:=0; pz.name[0]:=' '; end; stopoffset := stopoffset - 1; END; BEGIN try PROMPTLINE:=' Copy: File[marker,marke ('Buffer overflow.',true) ELSE BEGIN MOVELEFT(BUFR[START],EBUF^[CURSOR],AMOUNT); CURSOR:=CURSOR+AMOUNT END END END; PROCEDURE GETNEXT; BEGIN with fibp(addr(F))^ do begin DONE:= fpos >= fleof; r] ? '; REPEAT EPROMPT; READLN(input,FN); IF STRLEN(FN)=0 THEN escape(102); PARSEFN; RESET(F,FN,'shared'); tempior := ioresult; if tempior <> ord(inoerror) then begin getioerrmsg(generrmsg,tempior); if streamin IF NOT DONE THEN BEGIN if fkind = textfile then freadbytes(F, BUFR, pagesize) else any_to_UCSD(F, BUFR); if ioresult <> ord(inoerror) then begin tempior := ioresult; getioerrmsg then error(generrmsg,fatal); PROMPTLINE:=' Copy: ' + generrmsg + '. File? '; end; UNTIL tempior=ord(inoerror); updated := true; PROMPTLINE:=' Copy'; EPROMPT; SPLITBUF; FINDMARKERS; PAGE:=1; GETNEXT; WHILE (STARTOFFSET>NO     FIT(0,NOTNULLS-1) END; IF IORESULT<>ord(inoerror) THEN begin tempior := ioresult; getioerrmsg(generrmsg,tempior); ERROR(generrmsg,fatalifstreaming) end; UNSPLITBUFF; if (ord(ebuf^[cursor])=16) and (ord(ebuf^[cursor-1])<>edure showenviron; VAR I: INTEGER; begin WITH PAGEZERO DO BEGIN ECLEARSCREEN; PROMPTLINE:= ' Environment: {options} <'+exckey+'> or leaves'; { 3.0 ITF fix } EPROMPT; NE13) then begin moveleft(ebuf^[cursor+2],ebuf^[cursor], bufcount-cursor-1); readjust(leftpart+1,-2); bufcount:=bufcount-2; end; CENTERCURSOR(TRASH,MIDDLE,TRUE); CLOSE(F); recover if escapecode<>102 then escape(escapecode); ENEDPROMPT:=TRUE; WRITELN(output); WRITE(output,' Auto indent '); BOOL(AUTOINDENT); WRITE(output,' Filling '); BOOL(FILLING); WRITE(output,' Left margin '); WRITELN(output,LMARGIN:1); WRITE(output,' Right mD; PROCEDURE ENVIRONMENT; var maybeupdated : boolean; PROCEDURE ERASE10; VAR I: INTEGER; BEGIN WRITE(output,' ':10); FOR I:=1 TO 10 DO WRITE(output,CHR(BSS)); END; PROCEDURE BOOL(B:BOOLEAN); BEGIN IF B THEN WRITE(output,'True'argin '); WRITELN(output,RMARGIN:1); WRITE(output,' Para margin '); WRITELN(output,PARAMARGIN:1); WRITE(output,' Command ch '); WRITELN(output,RUNOFFCH); WRITE(output,' Token def '); BOOL(TOKDEF); WRITE(output,' ) ELSE WRITE(output,'False'); WRITELN(output); END; FUNCTION GETBOOL: BOOLEAN; VAR CH: CHAR; TRASH: SHORTINT; BEGIN ERASE10; CH:=UCLC(GETCH); WHILE NOT (CH IN ['T','F']) DO BEGIN WRITE(output,'T or F');  Ignore case '); BOOL(ignorecase); WRITE(output,' Zap markers '); WRITELN(output); WRITELN( output,' ',BUFCOUNT:1,' bytes used, ',(BUFSIZE-BUFCOUNT+1):1 ,' available.'); WRITELN(output); IF FOR TRASH:=0 TO 5 DO WRITE(output,CHR(BSS)); CH:=UCLC(GETCH) END; IF CH='T' THEN BEGIN WRITE(output,'True '); GETBOOL:=TRUE END ELSE BEGIN WRITE(output,'False '); GETBOOL:=FALSE SDEFINED OR TDEFINED THEN BEGIN WRITELN(output,' Patterns:'); IF TDEFINED THEN WRITE(output,' = ''',TARGET:TLENGTH,''''); IF SDEFINED THEN WRITE(output,', = ''',SUBSTRING:SLENGTH,''''); WRITEL END; END; FUNCTION GETINT: INTEGER; VAR CH:CHAR; N: INTEGER; digitswritten : shortint; BEGIN ERASE10; digitswritten := 0; N:=0; REPEAT REPEAT CH:=GETCH; IF (NOT (CH IN ['0'..'9',CHR(SP),CHR(CR)]))N(output); WRITELN(output); END; IF COUNT>0 THEN WRITELN(output,' Markers:'); WRITE(output,' '); FOR I:=0 TO COUNT-1 DO BEGIN WRITE(output,' ':6,NAME[I]); IF (I+4) MOD 3=0 THEN BEGIN WRITELN(output); WRITE(ou THEN WRITE(output,'#',CHR(BELL),CHR(BSS)); UNTIL CH IN ['0'..'9',CHR(SP),CHR(CR)]; IF CH IN ['0'..'9'] THEN IF N<1000 THEN BEGIN N:=N*10+ORD(CH)-ORD('0'); WRITE(output,CH); digitstput,' ') END END; WRITELN(output); WRITELN(output); if strlen(efilename) <> 0 then writeln(output,' File ',vstr,':',pstr,nstr) else writeln(output,' System workfile'); {LAF 880101 "MOD 100" adwritten := digitswritten + 1; END else WRITE(output,'#',CHR(BELL),CHR(BSS)); UNTIL CH IN [CHR(SP),CHR(CR)]; GETINT:=N; if digitswritten = 0 then write(output,'0 ') else WRITE(output,' ') END; procded} WRITELN(output,' Date Created: ',CREATED.MONTH:1,'-',CREATED.DAY:1 ,'-', CREATED.YEAR MOD 100:1,' Last Used: ',LASTUSED.MONTH:1,'-', LASTUSED.DAY:1,'-',LASTUSED.YEAR MOD 100:1); end; end; function marginsok : boolean;     CR)]; REDISPLAY; END; END; FUNCTION MIN(* (A,B:INTEGER):INTEGER *); BEGIN IF AB THEN MAX:=A ELSE MAX:=B END; FUNCTION GETCH: CHAR; VAR GCH: CHAR; BEGIN IFCREEN; VAR I:INTEGER; BEGIN IF SCREENHAS(CLEARSCN) THEN CONTROL(CLEARSCN) ELSE BEGIN HOME; EERASEOS(0,0) END; END; PROCEDURE ECLEARLINE(*Y:INTEGER*); VAR I: INTEGER; BEGIN IF SCREENHAS(CLEARLNE) THEN CONTROL(CLEARLNE) E EOLN(KEYBOARD) THEN begin GCH:=EOL; get(keyboard); end else READ(KEYBOARD,GCH); GETCH:=GCH; END; PROCEDURE CONTROL(*(WHAT: SCREENCOMMAND)*); BEGIN WITH SCREENN DO BEGIN IF HASPREFIX[WHAT] THEN WRITE(output,PREFIX); LSE BEGIN fgotoxy(output,0,Y); ERASETOEOL(0,Y); END; END; PROCEDURE PUTMSG; BEGIN CONTROL(WHOME); ECLEARLINE(0); SAVETOP:=MSG; WRITE(output,MSG); END; PROCEDURE HOME; BEGIN IF SCREENHAS(WHOME) THEN CONTROL(WHOME) ELSE  begin with pagezero do if (lmargin < rmargin) AND (PARAMARGIN < RMARGIN) then { 3.0 BUG #2 } marginsok := true else begin marginsok := false; error('Improper margins',fatalifstreaming); eprompt; end WRITE(output,CH[WHAT]); END END; FUNCTION SCREENHAS(*(WHAT: SCREENCOMMAND): BOOLEAN*); BEGIN SCREENHAS:=SCREENN.CH[WHAT]<>CHR(0); END; FUNCTION MAPCRTCOMMAND(VAR KCH:CHAR): KEYCOMMAND; VAR WHATITIS: KEYCOMMAND; PREFIXREAD: BOOLEAN; BEGIN W; end; BEGIN maybeupdated := false; WITH PAGEZERO DO BEGIN showenviron; REPEAT fgotoxy(output,STRLEN(PROMPTLINE),0); CH:=UCLC(GETCH); maybeupdated := true; CASE CH OF 'A': BEGIN fgotoxy(outputITH KEYBRD DO BEGIN IF (KCH=PREFIX) AND (PREFIX <> CHR(0)) THEN BEGIN PREFIXREAD:=TRUE; READ(KEYBOARD,KCH); END ELSE PREFIXREAD:=FALSE; WHATITIS:=BACKSPACEKEY; WHILE (WHATITIS <> NOTLE,18,1); AUTOINDENT:=GETBOOL END; 'F': BEGIN fgotoxy(output,18,2); FILLING:=GETBOOL END; 'L': repeat fgotoxy(output,18,3); LMARGIN:=GETINT; until marginsok; 'R': repeat fgotoxy(output,18,4); RMARGIN:=GETINT; until marginsok; GAL) AND NOT((CH[WHATITIS]=KCH) AND (PREFIXREAD=HASPREFIX[WHATITIS])) DO WHATITIS:=SUCC(WHATITIS); MAPCRTCOMMAND:=WHATITIS; END; END; FUNCTION MAPTOCOMMAND(* (CH:CHAR): COMMANDS *); (* For now, only the vector keys go t 'P': repeat fgotoxy(output,18,5); PARAMARGIN:=GETINT; until marginsok; 'C': BEGIN fgotoxy(output,18,6); READ(input,RUNOFFCH) END; 'T': BEGIN fgotoxy(output,18,7); TOKDEF:=GETBOOL END; 'I': BEGIN fgotoxy(output,18,8hrough the new keyboard record *) VAR KCMD: KEYCOMMAND; BEGIN IF (CH=syscom^.crtctrl.escape) AND (CH<>CHR(0)) THEN BEGIN KCMD:=MAPCRTCOMMAND(CH); IF KCMD IN [UPKEY..RIGHTKEY] THEN CASE KCMD OF UPKEY: MAPTOCOMMAND:=UP;); ignorecase:=GETBOOL END; 'Z': begin count := 0; name[0] := ' '; showenviron; end; otherwise begin maybeupdated := false; if not (ch in [' ', chr(etxx), chr(cr)]) then  DOWNKEY: MAPTOCOMMAND:=DOWN; LEFTKEY: MAPTOCOMMAND:=LEFT; RIGHTKEY: MAPTOCOMMAND:=RIGHT otherwise END; END ELSE MAPTOCOMMAND:=TRANSLATE[CH]; END; FUNCTION UCLC(*(CH:CHAR):CHAR*); (* Map Lower Ca begin ERROR('Not option',fatalifstreaming); EPROMPT; end; end; END; updated := updated or maybeupdated; UNTIL CH IN [' ',CHR(ETXX),CHR(se to Upper Case *) BEGIN IF CH IN ['a'..'z'] THEN UCLC:=CHR(ORD(CH)-32) ELSE UCLC:=CH END; PROCEDURE EPROMPT; BEGIN PROMPTLINE[1]:=DIRECTION; SAVETOP:=PROMPTLINE; CONTROL(WHOME); ECLEARLINE(0); WRITE(output,PROMPTLINE) END; PROCEDURE ECLEARS      fgotoxy(output,0,0); END; PROCEDURE ERASETOEOL(*X,LINE:INTEGER*); VAR I: INTEGER; BEGIN IF SCREENHAS(ERASEEOL) THEN CONTROL(ERASEEOL) ELSE BEGIN IF LINE=SCREENHITE THEN I := SCREENWID-X ELSE I := SCREENWID-X+1; T,SP,DLE] DO BEGIN IF EBUF^[PTR]=CHR(DLE) THEN BEGIN PTR:=PTR+1; indent:=indent+max(0, ord(ebuf^[ptr])-32); { 3.0 bug #1 } { INDENT:=INDENT+ORD(EBUF^[PTR])-32; } { 3.0 bug #1 } END ELS call (fibp(gfiles[1])^.am, fibp(gfiles[1]), writebytes, BLANKAREA, I, 0); fgotoxy(output,X,LINE) END; END; PROCEDURE BLANKCRT(*Y: INTEGER*); BEGIN IF SCREENHAS(ERASEEOS) THEN BEGIN fgotoxy(output,0,Y); CONTROL(ERASEEOS) E IF ORD(EBUF^[PTR])=SP THEN INDENT:=INDENT+1 ELSE (*HT*) INDENT:=((INDENT DIV 8)+1)*8; (* KLUDGE FOR COLUMNAR TAB! *) PTR:=PTR+1 END; BYTES:=PTR-OLDPTR; LEADBLANKS:=INDENT; END(*LEADBLANKS*); PROCEDURE REDISPLAY;  END ELSE IF Y=1 THEN BEGIN ECLEARSCREEN; WRITELN(output,SAVETOP) END ELSE BEGIN fgotoxy(output,0,Y); EERASEOS(0,Y); END; END; PROCEDURE EERASEOS(*X,LINE*); VAR I: INTEGER; BEGIN IF SCRE(* Do a total update of the screen. Note that this code is partially a duplicate of lineout/upscreen for reasons of speed. *) VAR LINEDIST,EOLDIST,LINE: INTEGER; PTR: EPTRTYPE; T: PACKED ARRAY [0..MAXSW] OF CHAR; BEGIN BLANKCRT(1); LINE:=1; ENHAS(ERASEEOS) THEN CONTROL(ERASEEOS) ELSE BEGIN ERASETOEOL(X,LINE); FOR I:=LINE+1 TO SCREENHITE DO BEGIN WRITELN(output); ECLEARLINE(I); END; fgotoxy(output,X,LINE); END; END; PROCEDURE PTR:=LINE1PTR; REPEAT BLANKS:=MIN(LEADBLANKS(PTR,BYTES),SCREENWID); fgotoxy(output,BLANKS,LINE); PTR:=PTR+BYTES; EOLDIST:=SCAN(MAXCHAR,=EOL,EBUF^[PTR]); LINEDIST:=MAX(0,MIN(EOLDIST,SCREENWID-BLANKS+1)); MOVELEFT(EBUF^[PTR],T[0],L ERRWAIT; BEGIN WRITE(output,CHR(BELL)); EPROMPT; END; PROCEDURE ERROR(*S: STRING80;HOWBAD: ERRORTYPE*); BEGIN call (fibp(gfiles[0])^.am, fibp(gfiles[2]), clearunit, gfiles[2], 0, 0); {UNITCLEAR(1); (* Throw away all characters queued up *) IF HINEDIST); IF EBUF^[PTR+LINEDIST]<>EOL THEN (* Line truncation *) T[MAX(0,LINEDIST-1)]:='!'; WRITE(output,T:LINEDIST); PTR:=PTR+EOLDIST+1; LINE:=LINE+1 UNTIL (LINE>SCREENHITE) OR (PTR>=BUFCOUNT) END; PROCEDURE CENTERCURSOR (*VAR LINE: IOWBAD=FATAL THEN BLANKCRT(1) ELSE BEGIN HOME; ECLEARLINE(0) END; WRITE(output,direction,'ERROR: ',S); IF HOWBAD=FATAL THEN if streaming then escape(-1) else escape(101) ELSE BEGIN if not streaming then begin NTEGER; LINESUP: INTEGER; NEWSCREEN: BOOLEAN*); (* Figure out if the cursor is still on the screen. If it is, and newscreen is false, then no redisplay is done. Otherwise an attempt is made to position the cursor at line "linesup". line is then upWRITE(output,' continues.'); REPEAT UNTIL GETCH=' '; end; NEEDPROMPT:=TRUE END; END; FUNCTION LEADBLANKS(* (PTR: PTRTYPE; VAR BYTES: INTEGER): INTEGER *); (* On entry- PTR points to the beginning of a line On dated to the actual line the cursor was forced to. *) VAR MARK: INTEGER; PTR: EPTRTYPE; BEGIN IF EBUF^[CURSOR]=EOL THEN PTR:=CURSOR ELSE PTR:=CURSOR+1; LINE:=0; REPEAT PTR:=PTR-1; PTR:=SCAN(-MAXCHAR,=EOL,EBUF^[PTR])+PTR; LINE:=LINEexit- function returns the number of leading blanks on that line. bytes has the offset into the line of the first non-blank character *) VAR OLDPTR: EPTRTYPE; INDENT: INTEGER; BEGIN OLDPTR:=PTR; INDENT:=0; WHILE ORD(EBUF^[PTR]) IN [H+1; IF LINE=LINESUP THEN MARK:=PTR; UNTIL (LINE>SCREENHITE) OR ((LINE1PTR=PTR+1) AND NOT NEWSCREEN) OR (PTR<1); IF LINE>SCREENHITE THEN (* Off the screen *) BEGIN LINE1PTR:=MARK+1; REDISPLAY; LINE:=LINESUP; END ELSE       N:=N*10+ORD(CH)-ORD('0'); CH:=GETCH END UNTIL (NOT (CH IN ['0'..'9'])) OR OVERFLOW; IF OVERFLOW THEN BEGIN ERROR('Repeatfactor>=10000',fatalifstreaming); GETNUM:=0; END ELSE GETNUM:=N; if overflST,EOLDIST: INTEGER; T: PACKED ARRAY [0..MAXSW] OF CHAR; BEGIN fgotoxy(output,BLANKS,LINE); PTR:=PTR+BYTES; EOLDIST:=SCAN(MAXCHAR,=EOL,EBUF^[PTR]); LINEDIST:=MAX(0,MIN(EOLDIST,SCREENWID-BLANKS+1)); MOVELEFT(EBUF^[PTR],T[0],LINEDIST); IF EBUF^ow then ecommand:=illegal else ECOMMAND:=MAPTOCOMMAND(CH); (* Takes CH and maps it to a command *) END; PROCEDURE GETLEADING; BEGIN (* Sets: LINESTART ......... A pointer to the beginning of the line STUFFSTART ........ A pointer to th[PTR+LINEDIST]<>EOL THEN (* Line truncation *) BEGIN LINEDIST:=MAX(LINEDIST,1); T[LINEDIST-1]:='!'; END; if blanks>=screenwid then fgotoxy(output,screenwid,line); WRITE(output,T:LINEDIST); PTR:=PTR+EOLDIST+1 END; PROCEDURE UPSCREIF LINE1PTR=PTR+1 THEN BEGIN IF NEWSCREEN THEN REDISPLAY END ELSE BEGIN LINE1PTR:=1; REDISPLAY; END; END; PROCEDURE actualXY(*VAR INDENT,LINE: INTEGER*); { NEW FOR 3.0 bug #7 } { added to find logical xe beginning of the text on the line BYTES ............. The number of bytes between LINESTART and STUFFSTART BLANKS ............ The indentation of the line *) LINESTART:=CURSOR; IF EBUF^[LINESTART]=EOL THy position. Same code as FINDXY used to } { have except for final INDENT assignment. } VAR I,LEAD: INTEGER; PTR,EOLPTR: EPTRTYPE; BEGIN (* Place CRT cursor on the screen at the position corresponding to the logical cursor.EN LINESTART:=LINESTART-1; (* for scan! *) LINESTART:=SCAN(-MAXCHAR,=EOL,EBUF^[LINESTART])+LINESTART+1; BLANKS:=LEADBLANKS(LINESTART,BYTES); STUFFSTART:=LINESTART+BYTES END (* GETLEADING *); procedure movetobuf(*cursor,anchor: eptrtype*); begin if *) LINE:=1; PTR:=LINE1PTR; EOLPTR:=SCAN(MAXCHAR,=EOL,EBUF^[PTR])+PTR; WHILE EOLPTR(bufsize-bufcount-10)) then if not streaming then error('Copy buffer ovflw', nonfatal) else else begin copyok:=true; copylength:=abs(cursor-anchor); copystart:=bufsize-copylength+1; moveleft(the indentation on that line of the cursor *) LEAD:=LEADBLANKS(PTR,I); INDENT:=(LEAD-I)+(CURSOR-PTR); (* (extra spaces) + (offset into line) *) END;(* FINDXY *) PROCEDURE FINDXY(*VAR INDENT,LINE: INTEGER*); BEGIN actualXY(INDebuf^[min(cursor,anchor)],ebuf^[copystart], copylength); end; end; FUNCTION OKTODEL (* (CURSOR,ANCHOR: PTRTYPE):BOOLEAN *) ; var temp, cursortemp: eptrtype; BEGIN IF (ABS(CURSOR-ANCHOR)>((BUFSIZE-BUFCOUNT)-10)) and not streaming THEN BEGIN ENT, LINE); { 3.0 BUG #7 } INDENT:=MIN(SCREENWID, INDENT); { 3.0 BUG #7 } END;(* FINDXY *) { 3.0 BUG #7 } PROCEDURE SHOWCURSOR; VAR X,Y: INTEGER; BEGIN FINDXY(X,Y); fgotoxy MSG:='No room to copy deletion. Delete anyway? (y/n)'; PUTMSG; IF UCLC(GETCH)='Y' THEN OKTODEL:=TRUE ELSE OKTODEL:=FALSE; END ELSE BEGIN (* COPYLINE is set by the caller *) COPYOK:=TRUE; COPYLENGTH:=ABS(CURSOR(output,X,Y) END(* SHOWCURSOR *); FUNCTION GETNUM(*:INTEGER*); VAR N: INTEGER; OVERFLOW: BOOLEAN; BEGIN N:=0; OVERFLOW:=FALSE; IF NOT (CH IN ['0'..'9']) THEN N:=1 ELSE REPEAT IF N >= 1000 THEN OVERFLOW:=TRUE ELSE BEGIN -ANCHOR); COPYSTART:=BUFSIZE-COPYLENGTH+1; MOVELEFT(EBUF^[MIN(CURSOR,ANCHOR)],EBUF^[COPYSTART],COPYLENGTH); OKTODEL:=TRUE END; END; PROCEDURE LINEOUT(*VAR PTR:PTRTYPE; BYTES,BLANKS,LINE:INTEGER*); (* Write a line out *) VAR LINEDI     EN(*FIRSTLINE,WHOLESCREEN: BOOLEAN; LINE: INTEGER*); (* Zap, Insert and Delete call this procedure to update (possibly partially) the screen. FIRSTLINE means only the line that the cursor is on need be updated. WHOLESCREEN means that everything musbe filled. Note: A paragraph is defined as lines of text delimited by a line with no text on it whatsoever, or a line of a text whose first character is RUNOFFCH *) label 1; VAR SAVE,PTR,WPTR: INTEGER; WLENGTH,X: INTEGER; DONE: BOOLEAN; t be updated. If neither of these is true then only the part of the screen that's after the cursor is updated *) VAR PTR: EPTRTYPE; BEGIN (* Upscreen *) IF FIRSTLINE THEN BEGIN GETLEADING; fgotoxy(output,0,LINE); ERASETOEOL(0,LI startadjust: integer; BEGIN updated := true; WITH PAGEZERO DO BEGIN SAVE:=CURSOR; CURSOR:=PARAPTR; GETLEADING; IF EBUF^[STUFFSTART] IN [EOL,RUNOFFCH] THEN goto 1; IF WHOLE THEN (* Scan backwards for the beginning of NE); (* Clean the line *) LINEOUT(LINESTART,BYTES,BLANKS,LINE) (* Just this line *) END ELSE IF WHOLESCREEN THEN CENTERCURSOR(TRASH,MIDDLE,TRUE) ELSE (* Only update the part of the screen after the cursor *) BEGIN fgthe paragraph *) BEGIN REPEAT CURSOR:=LINESTART-1; GETLEADING UNTIL (LINESTART<=1) OR (EBUF^[STUFFSTART] IN [RUNOFFCH,EOL]); IF EBUF^[STUFFSTART] IN [RUNOFFCH,EOL] THEN PTR:=CURSOR+1otoxy(output,0,LINE); EERASEOS(0,LINE); GETLEADING; PTR:=LINESTART; REPEAT BLANKS:=MIN(LEADBLANKS(PTR,BYTES),SCREENWID); LINEOUT(PTR,BYTES,BLANKS,LINE); (* Writes out the line at ptr *) LINE:=LI ELSE PTR:=1; X:=PARAMARGIN; END ELSE BEGIN PTR:=cursor; { formerly LINESTART } { mods 12/22/81 jws } x:=cursor - stuffstart + blanks; { IF BLANKS=PARAMARGIN THEN X:=PARAMNE+1 UNTIL (LINE>SCREENHITE) OR (PTR>=BUFCOUNT) END; END; PROCEDURE READJUST(*CURSOR:PTRTYPE; DELTA: INTEGER*); (* if DELTA<0 then move all affected markers to CURSOR. Also adjust all markers >= CURSOR by DELTA *) VAR I,j: INTEGER; BEGARGIN ELSE X:=LMARGIN } END; CURSOR:=BUFSIZE-(BUFCOUNT-PTR)+1; (* Split the buffer *) MOVERIGHT(EBUF^[PTR],EBUF^[CURSOR],BUFCOUNT-PTR); if not whole then {don't want to lose leading space RAM 27AUG82} if (ebuf^[cuIN WITH PAGEZERO DO begin if lastpat >= cursor then lastpat := max(lastpat+delta,cursor); FOR I:=0 TO COUNT-1 DO begin j:=poffset[3*i]*65536+poffset[3*i+1]*256+poffset[3*i+2]; IF j>=CURSOR THEN rsor] = ' ') then if (ebuf^[ptr-1] = ' ') then begin if (ebuf^[ptr-2] in ['.', '?', ':', '!']) then begin ebuf^[ptr]:= ' '; ptr := ptr + 1; curs begin j:=MAX(j+DELTA,CURSOR); poffset[3*i]:=j div 65536; poffset[3*i+1]:=(j mod 65536) div 256; poffset[3*i+2]:=j mod 256; end end; end; END; PROCEDURE THEFIXER(*PARAPTR:Por := cursor + 1; end end else begin if (ebuf^[ptr-1] in ['.', '?', ':', '!']) and (ebuf^[cursor + 1] = ' ') then begin ebuf^[ptr]:= ' '; TRTYPE;RFAC:INTEGER;WHOLE:BOOLEAN*); (* PARAPTR points somewhere in a paragraph. If WHOLE is true then the entire paragraph is filled, otherwise only that directly after the cursor is filled. RFAC, when implemented will tell how many paragraphs to  ptr := ptr + 1; cursor := cursor + 1; end; ebuf^[ptr] := ' '; ptr := ptr + 1; cursor := cursor + 1; end; startadjust:=     ; (* The last transfer will move over the for the paragraph *) IF NOT DONE THEN BEGIN EBUF^[PTR+WLENGTH-1]:=' '; (* If , map to one space only *) C(GETCH); if streaming and not(ch in ['B','F',chr(escc)]) then begin msg:='Illegal Copy option.'; putmsg; escape(-1); end; UNTIL CH IN ['B','F',CHR(ESCC)]; IF CH='F' THEN escape(103); IF CH='B' THEN BEGIN  IF EBUF^[CURSOR-2]=' ' THEN PTR:=PTR-1; END END END; X:=X+WLENGTH; PTR:=PTR+WLENGTH; UNTIL DONE; READJUST(startadjust,(BUFSIZE-CURSOR+PTR+1)-BUFCOUNT); BUFCOUNT:=BU IF NOT COPYOK OR ((BUFCOUNT+COPYLENGTH+10>COPYSTART) AND (COPYSTART>=BUFCOUNT)) THEN ERROR('Invalid copy.',fatalifstreaming) ELSE IF BUFCOUNT+COPYLENGTH>=BUFSIZE THEN ERROR('No room',fatalifstreaming) ELSEptr; (* Now dribble back the (rest of the) paragraph *) if whole then begin EBUF^[PTR]:=CHR(DLE); EBUF^[PTR+1]:=CHR(X+32); PTR:=PTR+2; end; EBUF^[CURSOR-1]:=EOL; (* sentinel for getleading *) FSIZE-CURSOR+PTR+1; MOVELEFT(EBUF^[CURSOR],EBUF^[PTR],BUFSIZE-CURSOR+1); EBUF^[BUFCOUNT]:=CHR(0); CURSOR:=MIN(BUFCOUNT-1,SAVE); GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART) END; 1:END; PROCEDURE GETNAME(*MSG:STRING80; VAR M: DONE:=FALSE; REPEAT WHILE EBUF^[CURSOR] IN [CHR(HT),CHR(SP),CHR(DLE)] DO IF EBUF^[CURSOR]=CHR(DLE) THEN CURSOR:=CURSOR+2 ELSE CURSOR:=CURSOR+1; WPTR:=CURSOR; (* Skip over a tokNAME*); VAR I: INTEGER; S: STRING80; BEGIN NEEDPROMPT:=TRUE; HOME; ECLEARLINE(0); WRITE(output,MSG,' what marker? '); READLN(input,S); {remove control characters} if strlen(s)>=1 then begin i:=1; while i<=strlen(s) do begin en *) WHILE NOT (EBUF^[CURSOR] IN [EOL,' ']) DO CURSOR:=CURSOR+1; (* Special cases for "." *) IF (EBUF^[CURSOR-1] in ['.','?',':','!']) THEN IF (EBUF^[CURSOR]=' ') AND (EBUF^[CURSOR+1]=' ') THEN CURSORif (ord(s[i])<=32) or (s[i]=',') or (ord(s[i])=127) then strdelete(s,i,1) else i:=i+1; end; end; FOR I:=1 TO STRLEN(S) DO S[I]:=UCLC(S[I]); MOVELEFT(S[1],M,MIN(8,STRLEN(S))); FILLCHAR(M[STRLEN(S)+1],MAX(0,8-STRLEN(S)),' ') END;:=CURSOR+1; WLENGTH:=CURSOR-WPTR+1; (* Including the delimiter *) IF (X+WLENGTH>RMARGIN) OR (RMARGIN-LMARGIN+1<=WLENGTH) THEN BEGIN IF (EBUF^[PTR-1]=' ') and (ebuf^[ptr-2]<>chr(dle)) THEN PTR:=PTR-1;  end; {edit1} module edit2; import sysglobals, misc, sysdevs, fs, ci, edit1; export procedure xeditor; implement PROCEDURE EDITCORE; (* Core procedures. Execute these commands until either a set environment comes along or a  EBUF^[PTR]:=EOL; EBUF^[PTR+1]:=CHR(DLE); EBUF^[PTR+2]:=CHR(LMARGIN+32); PTR:=PTR+3; X:=LMARGIN END; CURSOR:=CURSOR+1; MOVELEFT(EBUF^[WPTR],EBUF^[PTR],WLENGTH); IF EBUquit command. *) PROCEDURE NEXTCOMMAND; FORWARD; PROCEDURE FIXDIRECTION; BEGIN IF ECOMMAND=FORWARDC THEN DIRECTION:='>' ELSE DIRECTION:='<'; HOME; WRITE(output,DIRECTION); (* Update prompt line *) SHOWCURSOR; NEXTCOMMAND END; PROCEF^[CURSOR-1]=EOL THEN BEGIN IF (EBUF^[CURSOR]=CHR(0)) OR (CURSOR > BUFSIZE) THEN DONE:=TRUE ELSE BEGIN GETLEADING; DONE:=(EBUF^[STUFFSTART]=EOL) OR (EBUF^[STUFFSTART]=RUNOFFCH)DURE COPY; var copykludge : boolean; templength : integer; tempstart : integer; i : integer; BEGIN PROMPTLINE:=' Copy: Buffer File <'+esckey+'>'; { 3.0 ITF fix 4/6/84 } EPROMPT; NEEDPROMPT:=TRUE; REPEAT CH:=UCL       BEGIN updated := true; copykludge:=false; IF COPYLINE THEN BEGIN GETLEADING; if not iflag then begin if (cursor=stuffstart) then cursor:=linestar I:=0; WHILE (INAME[I]) DO I:=I+1; IF MNAME<>NAME[I] THEN ERROR('Not there.',fatalifstreaming) ELSE BEGIN CURSOR:=poffset[3*i]*65536+poffset[3*i+1]*256+poffset[3*i+2];t else begin copykludge := true; tempstart := copystart; templength := copylength; i := 0; w GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART); CENTERCURSOR(TRASH,MIDDLE,FALSE) END; END; END; END; (* jumpmarker *) BEGIN (* jump *) PROMPTLINE:=' JUMP: Begin End Marker <'+esckey+'>'; {hile (i < copylength) and ( (ebuf^[copystart+i] = ' ' ) or (ebuf^[copystart+i] = chr(DLE)) ) do begin if ebuf^[copystart+i] = chr(DLE) then 3.0 ITF fix 4/6/84 } EPROMPT; NEEDPROMPT:=TRUE; (* Need to redisplay EDIT: promptline! *) REPEAT CH:=UCLC(GETCH); if streaming and not(ch in ['B','E','M',chr(escc)]) then begin msg:='Illegal Jump option.'; putmsg;  i := i + 1; i := i + 1; end; copystart := copystart + i; copylength := copylength - i; end  escape(-1); end; IF CH='B' THEN BEGIN CURSOR:=1; GETLEADING; CURSOR:=STUFFSTART; CENTERCURSOR(TRASH,1,FALSE) END ELSE IF CH='E' THEN BEGIN CURSOR:=BUFCOUNT-1; C end; END; MOVERIGHT(EBUF^[CURSOR],EBUF^[CURSOR+COPYLENGTH],BUFCOUNT-CURSOR+1); IF (COPYSTART>=CURSOR) AND (COPYSTARTCHR(ESCC) THEN ERRWAIT; UNTIL (CH IN ['B','E','M',CHR(ESCC)]); NEXTCOMMAND; END; PROCEDURE DEFMACRO; BEGIN WITH PAGEZERO DO IF FI ELSE MOVELEFT(EBUF^[COPYSTART],EBUF^[CURSOR],COPYLENGTH); BUFCOUNT:=BUFCOUNT+COPYLENGTH; READJUST(CURSOR,COPYLENGTH); GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART); CENTERCURSORLLING AND NOT AUTOINDENT THEN BEGIN BLANKCRT(1); THEFIXER(CURSOR,REPEATFACTOR,TRUE); CENTERCURSOR(TRASH,MIDDLE,TRUE); END ELSE ERROR('Wrong environment',fatalifstreaming); COPYOK:=FALSE; SHOWCURSOR; NEXTC(TRASH,MIDDLE,TRUE); if copykludge then begin copystart:=tempstart; copylength:=templength; end; END; END (* CH='B' *); SHOWCURSOR; NEXTCOMMAND; END(*COPY*); PROCEDUOMMAND; END; PROCEDURE SETMARKER; LABEL 1; VAR I,SLOT: INTEGER; MNAME: NAME; BEGIN WITH PAGEZERO DO BEGIN NEEDPROMPT:=TRUE; GETNAME('Set',MNAME); IF MNAME<>' ' THEN BEGIN SLOT:=COUNT; FOR I:=0RE FIND; FORWARD; PROCEDURE INSERTIT; FORWARD; PROCEDURE JUMP; VAR CH: CHAR; PROCEDURE JUMPMARKER; VAR I: INTEGER; MNAME: NAME; BEGIN WITH PAGEZERO DO BEGIN GETNAME('Jump to',MNAME); IF MNAME<>' ' THEN BEGIN  TO COUNT-1 DO IF NAME[I]=MNAME THEN SLOT:=I; IF SLOT >= 10 THEN BEGIN BLANKCRT(1); FOR I:=0 TO COUNT-1 DO WRITELN(output,I:1,') ',NAME[I]); MSG:='Marker ovflw. Wh      gin := 0; 3.0 BUG #34 3/22/84 } {rmargin := screenwid; 3.0 BUG #34 3/22/84 } {paramargin := 15; 3.0 BUG #34 3/22/84 } tokdef := false; escape(1 THEN BEGIN { 2/9/84 jws } IF EBUF^[CURSOR]<>EOL { 2/9/84 jws } THEN BEGIN { 2/9/84 jws } c:=EBUF^[CURS03); { display the new defaults } end; otherwise if ch <> chr(escc) then errwait; end; { case ch of } UNTIL CH IN ['E','M','P','D',CHR(ESCC)]; { MCh: added 'P' and 'D' } SHOWCURSOR; NEXTCOMMAND; END(* SETSTUFF *); PROCEDURE OR]; { save current char } { 2/9/84 jws } SAVE[I]:=c; { 2/9/84 jws } I:=I+1; { bump save ptr } { 2/9/84 jws } CURSOR:=CURSOR+1; { next cursor ich one to replace?'; PUTMSG; if streaming then escape(-1); CH:=GETCH; CENTERCURSOR(TRASH,MIDDLE,TRUE); IF NOT (CH IN ['0'..'9']) THEN GOTO 1; SLOT:=ORD(CH)-ORD('0') VERIFY; BEGIN CENTERCURSOR(TRASH,MIDDLE,TRUE); SHOWCURSOR; NEXTCOMMAND END (* VERIFY *); PROCEDURE XMACRO; { EXTENSIVELY MODIFIED FOR 3.0 BUG #7 } { FIX PRODUCES PROPER BEHAVIOR WHEN OPERATING PAST SCREENWIDTH } { ALSO ENHANCED TO ALLOW RIGHT ARROW  END; updated := true; NAME[SLOT]:=MNAME; poffset[3*slot]:=cursor div 65536; poffset[3*slot+1]:= (cursor mod 65536) div 256; poffset[3*slot+2]:= cursor mod 256; IF SLOT=COUNT THEN COUNT:=COUNMOVEMENT OF CURSOR 2/9/84 jws } VAR SAVEC,I: INTEGER; SAVE:PACKED ARRAY [0..MAXSTRING] OF CHAR; c: char; { working char only } { 2/9/84 jws } x,y: integer; BEGIN PROMPTLINE:=' Xchnge: Text <'+esckey+'> aborts <'+exckT+1 END; END; 1:END; PROCEDURE SETSTUFF; VAR CH: CHAR; BEGIN PROMPTLINE:=' Set: Env Mrk Prog Doc <'+esckey+'>'; {3.0 ITF fix 4/6/84 } EPROMPT; NEEDPROMPT:=TRUE; with pagezero do REPEAT CH:=UCLC(GETCH); if streaming and not(ch ey+'> accepts'; { 3.0 ITF fix } EPROMPT; NEEDPROMPT:=TRUE; SHOWCURSOR; SAVEC:=CURSOR; I:=0; actualXY(x,y); { 3.0 BUG #7 } REPEAT CH:=GETCH; in ['E','M','P','D',CHR(ESCC)]) then begin msg:='Illegal Set option.'; putmsg; escape(-1); end; case ch of 'E': escape(103); 'M': setmarker; 'P': begin updated := true;  IF MAPTOCOMMAND(CH)=LEFT THEN BEGIN IF (CURSOR>SAVEC) THEN BEGIN I:=I-1; CURSOR:=CURSOR-1; (* Decrement both ptrs *) EBUF^[CURSOR]:=SAVE[I]; (* Restore buffer *) x:=x-1;  autoindent := true; filling := false; {lmargin := 0; 3.0 BUG #34 3/22/84 } {rmargin := screenwid; 3.0 BUG #34 3/22/84 } {paramargin := 5;  { new line position } { 3.0 BUG #7 } if x<=screenwid then { display if visible } { 3.0 BUG #7 } WRITE(output,CHR(BSS),EBUF^[CURSOR],CHR(BSS)); END ELSE { 2 3.0 BUG #34 3/22/84 } tokdef := true; escape(103); { display the new defaults } end; 'D': begin updated := true; autoindent := false; filling := true; {lmar/9/84 jws } WRITE(output, CHR(BELL)) { 2/9/84 jws } END ELSE BEGIN { 2/9/84 jws } IF MAPTOCOMMAND(CH)=RIGHT { 2/9/84 jws }       pos. } { 2/9/84 jws } if x<=SCREENWID THEN WRITE(output,c); { 2/9/84 jws } x:=x+1; { 2/9/84 jws } END { 2/9/84 jws }  *); PROCEDURE ZAPIT; label 1; var sizeofzap : integer; BEGIN sizeofzap := abs(cursor-lastpat); IF (sizeofzap>80) and not streaming THEN BEGIN PROMPTLINE:= ' WARNING! Zap more than 80 chars? (y/n)'; EPROMPT; NEEDPROMPT:=TRUE;  ELSE { 2/9/84 jws } WRITE(output,CHR(BELL)) { 2/9/84 jws } END { 2/9/84 jws } ELSE  IF UCLC(GETCH)<>'Y' THEN BEGIN SHOWCURSOR; NEXTCOMMAND; goto 1; END; END; IF OKTODEL(MIN(CURSOR,LASTPAT),MAX(CURSOR,LASTPAT)) THEN BEGIN updated := true; COPYLINE:=FALSE; IF CUR { 2/9/84 jws } IF CH=EOL THEN BEGIN ERRWAIT; SHOWCURSOR; END ELSE IF NOT (CH IN [CHR(ETXX),CHR(ESCC)]) THEN SOR>LASTPAT THEN MOVELEFT(EBUF^[CURSOR],EBUF^[LASTPAT],BUFCOUNT-CURSOR) ELSE MOVELEFT(EBUF^[LASTPAT],EBUF^[CURSOR],BUFCOUNT-LASTPAT); BUFCOUNT:=BUFCOUNT-sizeofzap; if cursor>lastpat then CURSOR:=LASTPAT; READJUST(CUR { 2/9/84 jws } IF (EBUF^[CURSOR]<>EOL) { 2/9/84 jws } THEN BEGIN IF ch<' ' THEN CH:='?'; { handle control chars as ? } SAVE[I]:=EBUF^[CURSOR]; SOR,-sizeofzap); CENTERCURSOR(TRASH,MIDDLE,TRUE); END; SHOWCURSOR; NEXTCOMMAND; 1: END; PROCEDURE INSERTIT; CONST FUDGEFACTOR=10; VAR THEREST,LEFTPART,SAVEBUFCOUNT: EPTRTYPE; CLEARED,WARNED,OK,EXITPROMPT,NOTEXTYET,FIRSTLINE: BOOLEAN;  I:=I+1; EBUF^[CURSOR]:=CH; CURSOR:=CURSOR+1; if (x<=screenwid) THEN WRITE(output,CH); { 3.0 BUG #7 } x:=x+1; { 3.0 BUG #7 }  SPACES,LMOVE,X,LINE,EOLDIST,RJUST: INTEGER; CONTEXT: PACKED ARRAY [0..MAXSTRING] OF CHAR; myspaces: boolean; { added 1/5/82 jws } didspecialpopov: boolean; {added 9/14/83 jws} popovlen: integer; {added 9/14/83 jws} popovptr: eptrtype; END ELSE WRITE(output, CHR(BELL)) { 2/9/84 jws } END { IF MAPTOCOMMAND=LEFT ELSE BEGIN } { 2/9/84 jws } UNTIL CH IN [CHR(ETXX),CHR(ESCC)]; IF CH=CHR(etxx) THEN begin  {added 9/14/83 jws} PROCEDURE SLAMRIGHT; (* Move (slam) the portion of the EBUF^ to the right of (and including) the cursor so that the last NUL in the file (EBUF^[BUFCOUNT]) is now at EBUF^[BUFSIZE]. THEREST points to the beginning of th if cursor <> savec then begin updated := true; getleading; {11/29/88 DEW fix for defect} if CURSOR < STUFFSTART then {11/29/88 DEW #FSDdt01798} CURSOR := STUFFSTART; e right-justified text. *) BEGIN GETLEADING; THEREST:=BUFSIZE-(BUFCOUNT-CURSOR); LMOVE:=BUFCOUNT-CURSOR+1; MOVERIGHT(EBUF^[CURSOR],EBUF^[THEREST],LMOVE); GETLEADING; (* Set blanks *) IF THEREST-CURSOR or a blank compression code, then fall into the code for a (also changing the CH to for communication to the outer block) *) VAR PTR: EPTRTYPE; BEGIN  end; fgotoxy(output,X,LINE) END ELSE IF VALUE>=THEREST-MAXCHAR THEN BEGIN IF NOT WARNED THEN BEGIN if not streaming then begin ERROR('Finish the insertion',NONFATAL); EP IF (CH=CHR(BSS)) AND NOT( (EBUF^[CURSOR-2]=CHR(DLE)) OR (EBUF^[CURSOR-1]=EOL) ) THEN BEGIN IF CURSOR or equivalent *) CH:=CHR(DELL); (* Tell tr (one past the last valid character inserted into the buffer), put back together the two halves of the buffer. Then, to polish it off, update the screen so that the rest of the editor can cope *) VAR PTR: EPTRTYPE; LNGTH: INTEGER; BEGIN WIROMPT; end; fgotoxy(output,X,LINE); WARNED:=TRUE END; IF VALUE>THEREST-FUDGEFACTOR THEN BEGIN ERROR('Buffer Overflow!!!!',fatalifstreaming); WRAPUP; escapTH PAGEZERO DO IF NOTEXTYET AND (NOT FIRSTLINE) AND ((NOT FILLING) OR AUTOINDENT) AND (CH<>CHR(ESCC)) THEN (* We want the blanks before THEREST *) BEGIN getleading; {added 1/5/82 jws} BUFCOUNT:=BUFCOUNT+2; THEREe(104); END END END; PROCEDURE SPACEOVER; (* This procedure handles spaces and tabs inserted into the buffer *) BEGIN IF CH=CHR(HT) THEN SPACES:=8-X+(x div 8)*8 {WAH 4/9/80} ELSE SPACES:=1; IF CHECK(CURSOR+SPACES) THEN BEGIN ST:=THEREST-2; LMOVE:=LMOVE+2; CURSOR:=SCAN(-MAXCHAR,=EOL,EBUF^[CURSOR-1])+CURSOR; if myspaces then ebuf^[therest+1]:=chr(blanks+32); { jws 1/5/82 } END; MOVELEFT(EBUF^[THEREST],EBUF^[CURSOR],LMOVE); READJUST(LEFTPART+1,CUFILLCHAR(EBUF^[CURSOR],SPACES,' '); CURSOR:=CURSOR+SPACES; if notextyet then myspaces:=true; {jws 1/5/82} END END; PROCEDURE FIXUP; FORWARD; PROCEDURE ENDLINE; (* First, if there was no text inserted on the current line, then convert aRSOR-(LEFTPART+1)); BUFCOUNT:=BUFCOUNT+(CURSOR-(LEFTPART+1)); {scs 3/20/80} WITH PAGEZERO DO begin IF FILLING AND NOT AUTOINDENT AND (CH=CHR(ETXX)) THEN BEGIN THEFIXER(CURSOR,1,FALSE); { 3.0 BUG #5 -- ll of the spaces to blank compression codes. Then insert an into the buffer followed by the appropriate number of spaces for the indentation. *) BEGIN WITH PAGEZERO DO BEGIN IF NOTEXTYET THEN FIXUP; EBUF^[CURSOR]:=EOL; REMOVED FIX 4/27} FIRSTLINE:=FALSE; FINDXY(X,LINE); END; UPSCREEN(FIRSTLINE, EXITPROMPT OR (CH=CHR(ESCC)) OR (FILLING AND NOT AUTOINDENT), LINE); end; GETLEADING; CURSOR:=MAX(CURSOR,STIF AUTOINDENT THEN GETLEADING ELSE IF FILLING THEN BEGIN GETLEADING; IF EBUF^[STUFFSTART]=EOL THEN (* Empty line *) BLANKS:=PARAMARGIN ELSE BLANKS:=LMARGIN END ELSEUFFSTART); LASTPAT:=LEFTPART+1; movetobuf(cursor,lastpat); NEXTCOMMAND END; FUNCTION CHECK(VALUE:INTEGER): BOOLEAN; (* VALUE is the potential value of the cursor. If it is not in legal range then CHECK is false. This function also warns the BLANKS:=0; IF CHECK(CURSOR+BLANKS+1) THEN BEGIN FILLCHAR(EBUF^[CURSOR+1],BLANKS,' '); CURSOR:=CURSOR+BLANKS+1 END; NOTEXTYET:=TRUE; myspaces:=false; END; END; PROCEDURE BACKUP; (* If the CH is a b      he CRT driver that the line has changed *) GETLEADING; IF CHECK(LINESTART-1) THEN CURSOR:=LINESTART-1; NOTEXTYET:=FALSE; (* thank you shawn! *) END END; PROCEDURE FIXUP; (* Convert the indentation spaces into blank compression codes, fgotoxy(output,RJUST,LINE); ERASETOEOL(RJUST,LINE); WRITE(output,CHR(LF)); IF LINE=SCREENHITE THEN BEGIN EXITPROMPT:=TRUE; LINE:=SCREENHITE-1 END; WRITE(output,CONTEXT:(min(screenwid-rjust+1,EOLDIST))); FIRSTLINE:=FALSE; (* Says that the whole  and move the current line around accordingly *) label 1; BEGIN (* First compress the current line *) EBUF^[CURSOR]:=EOL; (* Fool Getleading *) GETLEADING; IF BYTES >= 2 THEN (* OK to put in # as it stands *) MOVELEFT(EBUF^[STUFFSTART]screen has been affected. *) END; PROCEDURE WRITESP(CH:CHAR;HOWMANY:INTEGER); BEGIN IF X+HOWMANY<=SCREENWID THEN WRITE(output,CH:HOWMANY); IF X+HOWMANY>=SCREENWID THEN BEGIN fgotoxy(output,SCREENWID,LINE); IF X+HOWMANY>SCREENWID THEN ,EBUF^[LINESTART+2],CURSOR-STUFFSTART) ELSE IF CHECK(CURSOR+2-BYTES) THEN MOVERIGHT(EBUF^[STUFFSTART],EBUF^[STUFFSTART+2-BYTES],CURSOR-STUFFSTART) ELSE BEGIN OK:=FALSE; goto 1; END; CURSOR:=CURSOR-(BYTES-2); EBUF^[LINESTART]:=CHR(DLE); BEGIN WRITE(output,'!'); fgotoxy(output,SCREENWID,LINE); END END; X:=X+HOWMANY END; PROCEDURE CLEANSCREEN; (* Code to, if possible, only erase the line, otherwise clear the screen. Then call popdown *) BEGIN  EBUF^[LINESTART+1]:=CHR(32+BLANKS); 1: END; PROCEDURE INSERTCH; (* This procedure inserts a single character into the buffer. It also handles all of the control codes (EOL,BS,DEL) and buffer over- and under- flow conditions. INSERTCH is caFIRSTLINE:=FALSE; IF CLEARED THEN BEGIN IF XSCREENHITE THEN BEGIN LINE:=LINE-1; WRITELN(lled by the CRT handler *) BEGIN REPEAT OK:=TRUE; (* No errors that invalidate the current character have occured *) CH:=GETCH; IF MAPTOCOMMAND(CH)=LEFT THEN CH:=CHR(BSS); IF ORD(CH) IN [SP,HT,CR,BSS,DELL,ETXX,ESCC] THEN BEGIN (* output); EXITPROMPT:=TRUE END; IF EOLDIST<>0 THEN POPDOWN END; PROCEDURE POPOV; (* When in filling mode, this procedure is called when a line is overflowed (X >= rightmargin). The word is scanned off and "popped" down to the next line. and are handled in the body of insertit *) IF ORD(CH) IN [SP,HT] THEN SPACEOVER ELSE IF CH=EOL THEN ENDLINE ELSE IF ORD(CH) IN [BSS,DELL] THEN BACKUP; END ELSE BEGIN (* A character to insert! *) {notice*) label 1; VAR i: integer; WLENGTH: INTEGER; SAVE,PTR: EPTRTYPE; WORD: PACKED ARRAY [0..MAXSW] OF CHAR; BEGIN IF NOTEXTYET THEN FIXUP; {following stmt mod 12/18/81 by jws} PTR:=max(SCAN(-MAXCHAR,=' ',EBUF^[CURSOR-1]), max(scan(-maxc commented out code to allow underlining Husni 12/12/79} IF (CH<'!') {OR (CH>'~')} THEN CH:='?'; (* No non-printing characters *) IF NOTEXTYET THEN FIXUP; IF CHECK(CURSOR+1) AND OK THEN BEGIN NOTEXTYET:=FALSE; har,=eol,ebuf^[cursor-1]), scan(-maxchar,=chr(dle),ebuf^[cursor-1])+1))+CURSOR; WLENGTH:=CURSOR-PTR; WITH PAGEZERO DO IF WLENGTH>=RMARGIN-LMARGIN THEN BEGIN WRITESP(CH,1); goto 1; END; fgotoxy(output,min(screenwid,X)- EBUF^[CURSOR]:=CH; CURSOR:=CURSOR+1 END; END; UNTIL OK; END; PROCEDURE POPDOWN; (* Displays CONTEXT, doing an implied scrollup if nec. *) BEGIN IF CLEARED THEN ERASETOEOL(X,LINE) ELSE BEGIN CLEARED:=TRUE; EERASEOS(X,LINE) END; WLENGTH+1,LINE); ERASETOEOL(min(screenwid,X)-WLENGTH+1,LINE); MOVERIGHT(EBUF^[PTR],EBUF^[PTR+3],WLENGTH); MOVELEFT(EBUF^[PTR+3],WORD,WLENGTH); if (not didspecialpopov) and (ptr<=leftpart) then begin {jws 9/14/83} popovptr:=ptr;       gotoxy(output,X,LINE); ERASETOEOL(X,LINE); FIRSTLINE:=TRUE; IF EOLDIST<>0 THEN (* A context needs to be displayed *) IF RJUST>X THEN (* and it will fit on the current line ... *) BEGIN fgotoxy(output,RJUST,LINE); WRITE(outpuROMPT THEN BEGIN EPROMPT; EXITPROMPT:=FALSE; END END ELSE BEGIN fgotoxy(output,0,LINE); CLt,CONTEXT:EOLDIST); fgotoxy(output,X,LINE) END ELSE (* and it won't fit on the current line *) BEGIN FIRSTLINE:=FALSE; EERASEOS(X,LINE);(* Clear the screen *) WRITELN(output); IF LINE=SCREENHITE THEN EARED:=FALSE; ERASETOEOL(0,LINE); LINE:=LINE-1; END; GETLEADING; X:=BLANKS-BYTES+CURSOR-LINESTART; fgotoxy(output,X,LINE); END; END; UNTIL CH  {jws 9/14/83} popovlen:=wlength; {jws 9/14/83} leftpart:=leftpart+3; {jws 9/14/83} savebufcount:=savebufcount+3; {jws 9/ BEGIN LINE:=SCREENHITE-1; EXITPROMPT:=TRUE; END; fgotoxy(output,RJUST,LINE+1); WRITE(output,CONTEXT:(min(screenwid-rjust+1,EOLDIST))); fgotoxy(output,X,LINE) END; REPEAT INSERT14/83} didspecialpopov:=true; {jws 9/14/83} end; {jws 9/14/83} CURSOR:=CURSOR+3; EBUF^[PTR]:=EOL; EBUF^[PTR+1]:=CHR(DLE); WITH PAGEZERO DO IF AUTOINDENT THECH; IF NOT (ORD(CH) IN [CR,ETXX,ESCC,DELL]) THEN BEGIN IF TRANSLATE[CH]=LEFT THEN BEGIN IF X<=SCREENWID THEN WRITE(output,CHR(BSS),' ',CHR(BSS)); X:=X-1; END ELSE N BEGIN SAVE:=CURSOR; (* Set blanks to the indentation of the line above *) CURSOR:=PTR; GETLEADING; CURSOR:=SAVE; if (blanks+wlength)>=rmargin then blanks:=lmargin; {jws 12/18/81} END ELSE BLANKS:=LMARGI IF CH=CHR(HT) THEN WRITESP(' ',SPACES) ELSE IF PAGEZERO.FILLING AND (X+1>=PAGEZERO.RMARGIN) THEN POPOV ELSE WRITESP(CH,1); IF NOT PAGEZERO.FILLING AND (X=SCREENWID-8) AND (CH<>CHR(BSS)) THEN WRITE(outputN; EBUF^[PTR+2]:=CHR(BLANKS+32); CLEANSCREEN; X:=BLANKS; fgotoxy(output,X,LINE); if (x+wlength)<=screenwid then begin WRITE(output,WORD:WLENGTH); X:=X+WLENGTH; end else for i:=1 to wlength do writesp(word[i-1],1); ,CHR(BELL)); IF (EOLDIST<>0) AND (X>=RJUST) AND FIRSTLINE THEN (*ran into context *) BEGIN POPDOWN; fgotoxy(output,min(X,screenwid),LINE) END; END ELSE (* ch in [eol,etxx,escc,dell]  NOTEXTYET:=FALSE; 1: END; BEGIN (* INSERT *) try didspecialpopov:=false; { jws 9/14/83 } iflag:=true; (*WAH 1/18/80*) myspaces:=false; { jws 1/5/82 } CLEARED:=FALSE; EOLDIST:=SCAN(MAXCHAR,=EOL,EBUF^[CURSOR]); MOVELEFT(EBUF^[CURSOR]*) BEGIN IF CH=EOL THEN BEGIN CLEANSCREEN; X:=BLANKS; fgotoxy(output,X,LINE); END ELSE IF CH=CHR(DELL) THEN BEGIN IF LINE<=1 THEN (* Rubbed o,CONTEXT[0],min(maxstring+1,EOLDIST)); RJUST:=max(SCREENWID-EOLDIST,0); SLAMRIGHT; SAVEBUFCOUNT:=BUFCOUNT; PROMPTLINE:=INSERTPROMPT; EPROMPT; EXITPROMPT:=FALSE; NEEDPROMPT:=TRUE; LEFTPART:=CURSOR-1; NOTEXTYET:=FALSE; FINDXY(X,LINE); fut all of what was on the screen *) BEGIN BUFCOUNT:=CURSOR+1; EBUF^[CURSOR]:=EOL; CENTERCURSOR(LINE,MIDDLE,TRUE); IF EOLDIST<>0 THEN POPDOWN; IF EXITP      IN [CHR(ETXX),CHR(ESCC)]; IF CH=CHR(ESCC) THEN if not didspecialpopov then {jws 9/14/83} CURSOR:=LEFTPART+1 else begin {jws 9/14/83} moveleft(ebuf^[popovptr+rtype; begin line:=0; IF EBUF^[CURSOR]=EOL THEN PTR:=CURSOR ELSE PTR:=CURSOR+1; ptr:=ptr-1; ptr:=ptr+scan(-maxchar,=eol,ebuf^[ptr])+1; line1ptr:=ptr; getleading; BLANKS:=MIN(LEADBLANKS(PTR,BYTES),SCREENWID); if ptr>= 1 then begin 3], ebuf^[popovptr], popovlen); {jws 9/14/83} leftpart:=leftpart-3; {jws 9/14/83} cursor:=leftpart+1; {jws 9/14/83} savebufcount:=savebufcount-3;  if syscom^.miscinfo.haslccrt then dodownscroll else WRITE(OUTPUT,CHR(31)); line:=line+1; fgotoxy(output,0,LINE); ERASETOEOL(0,LINE); (* Clean the line *) LINEOUT(PTR,BYTES,BLANKS,LINE); (* Writes out the line at {jws 9/14/83} didspecialpopov:=false; {jws 9/14/83} end {jws 9/14/83} else if cursor <> leftpart + 1 then updated := true; BUFCOUNT:=SAVEBUFCO ptr *) end; exitprompt:=not(syscom^.miscinfo.haslccrt); end; PROCEDURE CLEAR(X1,Y1,X2,Y2: INTEGER); FORWARD; PROCEDURE CENTER; label 1; var xanch,yanch: integer; function anchoronscreen: boolean; var save: eptrtype; begin save:=cursor; cursUNT; WRAPUP; recover if escapecode<>104 then escape(escapecode); END; PROCEDURE MOVEIT; VAR SCROLLMARK,X,LINE,I: INTEGER; EXITPROMPT: BOOLEAN; (* Prompt after leaving Moveit! *) OLDLINE,OLDX: INTEGER; NEWDIST,DIST: INTEGER; DOFFSCREEN,ATENDor:=anchor; findxy(xanch,yanch); cursor:=save; if (yanch>=1) and (yanch<=screenhite) and (xanch>=0) then anchoronscreen:=true else anchoronscreen:=false; end; BEGIN IF INDELETE THEN BEGIN if line>screenhite then begin ,INREPLACE,INDELETE: BOOLEAN; PTR,ANCHOR,OLDCURSOR: EPTRTYPE; deltaline: integer; { used only for left moves } doresolve: boolean; { don't resolve when went off page} xtemp: integer; PROCEDURE SCROLLUP(BOTTOMLINE:EPTRTYPE; HOWMANY: INTEGER); ( centercursor(line,1,true); findxy(x,line); if (dist>=0) and (cursor>anchor) then begin if x>0 then clear(0,1,max(x-1,0),line) end else if cursor=HOWMANY) OR (BOTTOMLINE>=BUFCOUNT); EXITPROMPT:=not(syscom^.miscinfo.haslccrt); END(* SCROLLUP *); procedure scrolldown; var ptr: eptcursor<>anchor) then clear(xanch,yanch,max(x-1,0),line) end else begin if x<>0 then clear(0,1,max(x-1,0),line) end end else begin centercursor(line, screenhite, true); findxy(x,line);        PROCEDURE UPMOVE; VAR I:INTEGER; BEGIN I:=1; GETLEADING; (* FIND THE LINE FIRST *) WHILE (I<=REPEATFACTOR) AND (LINESTART>1) DO BEGIN CURSOR:=LINESTART-1; (* LAST CHAR OF LINE ABOVE *) GETLEADING; LINE:=LINE-1; I:=I+1; ENHITE); if indelete then findxy(x,line); END(* DOWNMOVE *); PROCEDURE LEFTMOVE; BEGIN deltaline:=0; GETLEADING; (* SET LINESTART AND STUFFSTART *) WHILE (STUFFSTART>CURSOR-REPEATFACTOR) and (linestart>1) DO BEGIN REPEATFACTOR:=REND; (* If possible set the cursor at the same x coord we came from. Otherwise, set it either to the beginning of the buffer, the beginning of text on that line, or the end of the text on that line *) CURSOR:= MAX(1, (* The begPEATFACTOR-(CURSOR-STUFFSTART+1); (* CHARS MOVED OVER *) IF EBUF^[CURSOR]=EOL THEN CURSOR:=CURSOR-1; CURSOR:=MAX(SCAN(-MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR,1); LINE:=LINE-1; deltaline:=deltaline+1; GETLEADING; (* RESET LINESTART if (dist<=0) and (cursoranchor then if anchoronscreen then inning of the buffer *) MAX(STUFFSTART, (* The beginning of the text *) MIN(X-BLANKS+BYTES+LINESTART, (* same col *) SCAN(MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR (* eol *) )  if x>0 then clear(xanch,yanch,max(x-1,0),line) else clear(xanch,yanch, screenwid, line-1) else if x>0 then clear(0,1,max(x-1,0),line) else clear (0,1,screenwid,line-1) else  ) ); IF LINE<1 THEN CENTER; if indelete then findxy(x,line); END(* UPALINE *); PROCEDURE DOWNMOVE; VAR I: INTEGER; NEXTEOL: EPTRTYPE; BEGIN I:=1; NEXTEOL:=SCAN(MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR; WHILE (NEXTEOLanchor then clear(x,line,max(0,xanch-1),yanch) end else begin fgotoxy(output,x,line); write(ouCOUNT-1) AND (I<=REPEATFACTOR) DO BEGIN CURSOR:=NEXTEOL+1; NEXTEOL:=SCAN(MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR; IF NEXTEOLQUITC) THEN BEGIN EPROMPT; EXITPROMPT:=FALSE; END; 1:OLDLINE:=LINE; OLDX:=X; END;  ,SCAN(MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR ) ) ); IF LINE>SCREENHITE THEN IF (LINE-SCREENHITE>=SCREENHITE) OR (INDELETE) THEN CENTER ELSE SCROLLUP(SCROLLMARK,LINE-SCREE       AND STUFFSTART *) END; CURSOR:=MAX(STUFFSTART,MAX(CURSOR-REPEATFACTOR,1)); IF LINE<1 THEN CENTER; FINDXY(X,LINE); END (* LEFTMOVE *); PROCEDURE RIGHTMOVE; VAR EOLPTR: EPTRTYPE; BEGIN EOLPTR:=SCAN(MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR; WHILE  CENTER ELSE SCROLLUP(SCROLLMARK,LINE-SCREENHITE); CURSOR:=MIN(CURSOR,BUFCOUNT-1) END; if atend and (direction='>') then cursor:=oldcursor else begin GETLEADING; CURSOR:=STUFFSTART; (* FORCED TO BEGINNING OF STUFF *(EOLPTRSCREENHITE THEN IF (LINE-SCREENHITE>=SCREENHITE) OR (INDELETE) THEN CENTER ELSE  PROCEDURE JUMPEND; BEGIN CURSOR:=BUFCOUNT-1; CENTERCURSOR(TRASH,SCREENHITE,FALSE) END; PROCEDURE ADJUSTING; LABEL 1; TYPE MODES=(RELATIVE,LEFTJ,RIGHTJ,CENTER); VAR LLENGTH,TDELTA,I: INTEGER; SAVEDIR: CHAR; MODE: MODES; PROCEDURE DOIT(DELTA: SCROLLUP(SCROLLMARK,LINE-SCREENHITE); FINDXY(X,LINE); END(* RIGHTMOVE *); PROCEDURE LINEMOVE(REPEATFACTOR: INTEGER); VAR I, oldcursor: INTEGER; BEGIN ATEND:= (CURSOR >= BUFCOUNT-1); I:=1; IF DIRECTION='<' THEN BEGIN WHILE (I<=REPEATFAINTEGER); VAR EOLDIST: INTEGER; T: PACKED ARRAY [0..MAXSTRING] OF CHAR; BEGIN GETLEADING; (* Set linestart, stuffstart, and blanks *) IF BLANKS+DELTA<0 THEN DELTA:=-BLANKS; IF (EBUF^[LINESTART]=CHR(DLE)) AND (STUFFSTART-LINESTART=2) THEN X:=OCTOR) AND (CURSOR>1) DO BEGIN IF EBUF^[CURSOR]=EOL THEN CURSOR:=CURSOR-1; (* NULL LINE CASE *) CURSOR:=SCAN(-MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR; (* 1 UP *) IF CURSOR>=1 THEN BEGIN LINE:=LINE-1; I:=I+1 END; END;RD(EBUF^[LINESTART+1])+DELTA-32 ELSE BEGIN IF STUFFSTART-LINESTART>2 THEN MOVELEFT(EBUF^[STUFFSTART],EBUF^[LINESTART+2],BUFCOUNT-STUFFSTART) ELSE BEGIN IF BUFCOUNT>BUFSIZE-100 THEN BEGIN  CURSOR:=MAX(1,CURSOR); (* BACK INTO REALITY *) ATEND:= (CURSOR=1); IF LINE<1 THEN CENTER END ELSE BEGIN (* DIRECTION='>' *) oldcursor:=cursor; WHILE (I<=REPEATFACTOR) AND (CURSORSTUFFSTART THEN BEGIN  oldcursor:=cursor; CURSOR:=SCAN(MAXCHAR,=EOL,EBUF^[CURSOR])+CURSOR+1; (*1 DOWN *) ATEND:= (CURSOR >= BUFCOUNT); if ATEND then cursor := oldcursor else BEGIN LINE:=LINE+1;  READJUST(LINESTART, LINESTART+2-STUFFSTART); BUFCOUNT:=BUFCOUNT+(LINESTART+2-STUFFSTART); {scs 3/20/80} END; EBUF^[LINESTART]:=CHR(DLE); X:=BLANKS+DELTA; END; if x>223 then x:=223; { don't wrap around ! } EBUF^[L IF LINE=SCREENHITE+1 THEN SCROLLMARK:=CURSOR; END; I:=I+1; END; IF LINE>SCREENHITE THEN IF (LINE-SCREENHITE>=SCREENHITE) OR (ECOMMAND=PARAC) OR INREPLACE OR INDELETE THEN INESTART+1]:=CHR(X+32); CURSOR:=LINESTART+2; GETLEADING; fgotoxy(output,0,LINE); ERASETOEOL(0,LINE); (* erase the line *) LINEOUT(LINESTART,BYTES,BLANKS,LINE); fgotoxy(output,X,LINE); END(* DOIT *); BEGIN (* adjusting *) try updated := true; WIT      D (* case *) END (* else *) END; (* if not atend *) END (* while ... *) END ELSE IF ECOMMAND=LEFT THEN BEGIN DOIT(-REPEATFACTOR); TDELY THEN BEGIN CASE ECOMMAND OF UP,LEFT: JUMPBEGIN; DOWN,RIGHT: JUMPEND; SPACE,ADVANCE,TABB,parac: IF DIRECTION='<' THEN JUMPBEGIN ELSE JUMPEND otTA:=TDELTA-REPEATFACTOR; MODE:=RELATIVE END ELSE IF ECOMMAND=RIGHT THEN BEGIN DOIT(REPEATFACTOR); TDELTA:=TDELTA+REPEATFACTOR; MODE:=RELATIVE herwise END; NEEDPROMPT:=TRUE; NEXTCOMMAND; escape(107); END; FINDXY(X,LINE); REPEAT OLDX:=X; OLDLINE:=LINE; CASE ECOMMAND OF LEFT: LEFTMOVE; RIGHT: RIGHTMOVE; SPACE: IF DIRECTION='<' THEN H PAGEZERO DO BEGIN SAVEDIR:=DIRECTION; EXITPROMPT:=FALSE; INDELETE:=FALSE; LASTPAT:=CURSOR; INREPLACE:=TRUE; PROMPTLINE:=ADJUSTPROMPT; EPROMPT; NEEDPROMPT:=TRUE; MODE:=RELATIVE; SHOWCURSOR; FINDXY(X,LINE);  END ELSE IF ECOMMAND IN [LISTC,REPLACEC,COPYC] THEN BEGIN GETLEADING; LLENGTH:=SCAN(MAXCHAR,=EOL,EBUF^[STUFFSTART]); IF ECOMMAND=LISTC THEN  TDELTA:=0; REPEAT CH:=GETCH; ECOMMAND:=MAPTOCOMMAND(CH); INFINITY:=FALSE; IF ECOMMAND=SLASHC THEN BEGIN REPEATFACTOR:=1; INFINITY:=TRUE; CH:=GETCH; ECOMMAND: BEGIN MODE:=LEFTJ; DOIT(LMARGIN-BLANKS); END ELSE IF ECOMMAND=REPLACEC THEN BEGIN MODE:=RIGHTJ; =TRANSLATE[CH]; END ELSE IF ECOMMAND=DIGIT THEN REPEATFACTOR:=GETNUM ELSE REPEATFACTOR:=1; IF ECOMMAND IN [UP,DOWN] THEN BEGIN IF ECOMMAND=UP THEN DIRECTION:='<' ELSE DIRECTION DOIT((RMARGIN-LLENGTH+1)-BLANKS); END ELSE (* ECOMMAND=COPYC *) BEGIN MODE:=CENTER; DOIT(((RMARGIN-LMARGIN+1)-LLENGTH) DIV:='>'; I:=1; ATEND:=FALSE; WHILE NOT ATEND AND ((I<=REPEATFACTOR) OR INFINITY) DO BEGIN I:=I+1; LINEMOVE(1); IF NOT ATEND THEN BEGIN  2-BLANKS+LMARGIN) END END ELSE IF CH<>CHR(ETXX) THEN BEGIN ERRWAIT; SHOWCURSOR; END; 1: UNTIL CH=CHR(ETXX); DIRECTION:= IF MODE=RELATIVE THEN DOIT(TDELTA) ELSE BEGIN LLENGTH:=SCAN(MAXCHAR,=EOL,EBUF^[STUFFSTART]); CASE MODE OF LEFTJ: DOIT(LMARGIN-SAVEDIR; END; recover if escapecode<>105 then escape(escapecode); END; FUNCTION TABBY: INTEGER; BEGIN IF REPEATFACTOR > 0 THEN IF DIRECTION = '>' THEN TABBY:=8*(REPEATFACTOR-1)+ 8-X+(x div 8)*8 {WAH 4/9/80} ELSE BEGIN BLANKS); RIGHTJ: DOIT((RMARGIN-LLENGTH+1)-BLANKS); CENTER: DOIT(((RMARGIN-LMARGIN+1)-LLENGTH) DIV 2-BLANKS+LMARGIN) otherwise ENIF X=0 THEN TABBY:=REPEATFACTOR*8 ELSE TABBY:=8*(REPEATFACTOR-1)+X-((x-1) div 8)*8; {WAH 4/9/80} END ELSE TABBY:=0; END; PROCEDURE MOVING; VAR SAVEX: INTEGER; BEGIN INDELETE:=FALSE; INREPLACE:=FALSE; EXITPROMPT:=FALSE; IF INFINIT      begin ecommand:=left; LEFTMOVE; end ELSE begin ecommand:=right; RIGHTMOVE; end; UP: UPMOVE; DOWN: r+loff; end else begin if xtemp1000 THEN error('Too many',fatalifstreaming) ELSE LINEMOVE(SCREENHITE*REPEATFACTOR); TABB: BEGIN FINDXY(X,LINE); :=xtemp+1; end END; END; PROCEDURE CLEAR(*X1,Y1,X2,Y2: INTEGER*); (* Screen co-ordinate (X1,Y1) is assumed to be before (X2,Y2). This procedure takes these co-ordinates and clears (writes blanks) over the screen between them (inclusiv { 3.0 BUG } IF REPEATFACTOR >= 4096 THEN error('Too many',fatalifstreaming) ELSE BEGIN REPEATFACTOR:=TABBY; IF DIRECTION='<' THEN LEFTMOVE ELSE RIGHTMOVE; e) *) VAR XX,I: INTEGER; BEGIN fgotoxy(output,X1,Y1); XX:=X1; FOR I:=Y1 TO Y2-1 DO BEGIN IF I<>0 THEN ERASETOEOL(XX,I); XX:=0; WRITELN(output); END; IF Y1<>Y2 THEN FOR I:=0 TO X2 DO WRITE(output,' ') ELSE FO SAVEX:=X+1; WHILE (X<>SAVEX) AND (X MOD 8<>0) DO BEGIN SAVEX:=X; REPEATFACTOR:=1; IF DIRECTION='>' THEN RIGHTMOVE ELSE LEFTMOVR I:=X1 TO X2 DO WRITE(output,' ') END; PROCEDURE DELETING; LABEL 1; VAR ATBOL,SAVE: EPTRTYPE; OK,ATBOT,NOMOVE: BOOLEAN; STARTLINE: INTEGER; savex: integer; PROCEDURE RESOLVESCREEN; label 1; VAR X1,X2,x3,Y1,Y2,y3,SAVE: INTEGER; C1,C2: EPTRTYE; END; END; END; otherwise END; fgotoxy(output,X,LINE); REPEATFACTOR:=1; NEXTCOMMAND UNTIL NOT (ECOMMAND IN [UP,DOWN,LEFT,RIGHT,ADVANCE,SPACE,TABB]); IF EXITPROMPT THEN EPROMPT; SHOWPE; BEGIN X1:=X; Y1:=LINE; X2:=OLDX; Y2:=OLDLINE; IF NEWDIST>DIST THEN BEGIN C1:=CURSOR-1; C2:=OLDCURSOR; if (y1<>y2) or (x1<>x2) then X1:=X1-1; END ELSE IF NEWDISTx1) or (y1<>y2) then X2:=X2-1; END ELSE goto 1; IF (Y1>Y2) OR ((Y1=Y2) AND (X1>X2)) THEN BEGIN SAVE:=C1; C1:=C2; C2:=SAVE; SAVE:=Y1; Y1:=Y2; Y2:=SAVE; SAVE:=X1; X1:; INDENT:=LEADBLANKS(PTR,LOFF); IF (PTR0) THEN begin while (xtemp0) do begin write(output,' '); indent:=indent-1; =X2; X2:=SAVE END; if ((dist>0) and (cursoranchor)) then begin save:=cursor; cursor:=anchor; findxy(x3,y3); cursor:=save; if cursor=screenwid) and (indent>0) then begin write(output,'!'); xtemp:=xtemp+1; end; end; ptr:=pt; fgotoxy(output,x3,y3); xtemp:=x3; putitback(anchor, oldcursor-1); end else begin fgotoxy(output,x1,y1); xtemp:=x1; putitback(oldcursor, anchor-1); clear(x3,y3,x2,y2);       BEGIN REPEATFACTOR:=TABBY; IF DIRECTION='<' THEN LEFTMOVE ELSE RIGHTMOVE; SAVEX:=X+1; WHILE (X<>SAVEX) AND (X MOD 8<>0) DO BEGIN  NEXTCOMMAND; END; BEGIN try IF ECOMMAND=DELETEC THEN DELETING ELSE IF ECOMMAND=ADJUSTC THEN BEGIN ADJUSTING; NEXTCOMMAND END ELSE MOVING; recover if escapecode<>107 then escape(escapecode); END; PROCEDURE  SAVEX:=X; REPEATFACTOR:=1; IF DIRECTION='>' THEN RIGHTMOVE ELSE LEFTMOVE END END END otherwise begin FIND; label 1; VAR THERE,FOUND,LASTPATTERN: BOOLEAN; TRASH,COULDBE,PLENGTH,START,STOP,NEXTSTART: INTEGER; NEXT,PTR: EPTRTYPE; MODE: (LITERAL,TOKEN); I: INTEGER; DELIMITER: CHAR; JUSTIN: BOOLEAN; POSSIBLE,PAT: PTYPE; USEOLD,VERIFY: BOOLE end end else begin IF ABS(NEWDIST)>ABS(DIST) THEN CLEAR(X1,Y1,X2,Y2) ELSE BEGIN fgotoxy(output,X1,Y1); xtemp:=x1; PUTITBACK(C1,C2) END end; fgotoxy(output,X,LINE); 1:END; B eprompt; fgotoxy(output,x,line) end END; NEWDIST:=CURSOR-ANCHOR; if doresolve then RESOLVESCREEN; END ELSE IF (CH<>CHR(ESCC)) AND (CH<>CHR(ETXX)) THEN BEGIN ERRWAIEGIN iflag:=false; (*WAH 1/18/80*) DOFFSCREEN:=FALSE; INDELETE:=TRUE; INREPLACE:=FALSE; EXITPROMPT:=FALSE; ANCHOR:=CURSOR; NEWDIST:=0; GETLEADING; ATBOL:=LINESTART; ATBOT:=(CURSOR=STUFFSTART); PROMPTLINE:=DELETEPROMPT; EPROMPT; NET; fgotoxy(output,X,LINE); END UNTIL (CH IN [CHR(ETXX),CHR(ESCC)]); IF CH=CHR(ETXX) THEN BEGIN GETLEADING; (* Indentation fixup *) IF ATBOT AND (CURSOR=STUFFSTART) THEN BEGIN CURSOR:=LINESTART; EDPROMPT:=TRUE; SHOWCURSOR; FINDXY(X,LINE); STARTLINE:=LINE; REPEAT doresolve:=true; OLDCURSOR:=CURSOR; DIST:=NEWDIST; OLDX:=X; OLDLINE:=LINE; CH:=GETCH; ECOMMAND:=TRANSLATE[CH]; IF ECOMMAND=DIGIT THEN REPEATFACTOR:=GETN SAVE:=ANCHOR; ANCHOR:=ATBOL; END; IF OKTODEL(CURSOR,ANCHOR) THEN BEGIN updated := true; READJUST(MIN(CURSOR,ANCHOR),-ABS(CURSOR-ANCHOR)); COPYLINE:=(CURSOR=LINESTART) AND ATBOT; IFUM ELSE REPEATFACTOR:=1; IF ECOMMAND IN [REVERSEC..DIGIT,ADVANCE,SPACE] THEN BEGIN CASE ECOMMAND OF LEFT: LEFTMOVE; RIGHT: RIGHTMOVE; SPACE: IF DIRECTION='<' THEN LEFTMOVE ELSE RIGHTMOVE; ANCHOR'; fgotoxy(output,0,0); WRITE(output,DIRECTION); fgotoxy(output,X,LINE) END; TABB: BEGIN IF REPEATFACTOR>=4096 THEN error('Too many',fatalifstreaming) ELSE  END; COPYLINE:=(CURSOR=LINESTART) AND ATBOT; movetobuf(cursor,anchor); if copyline then cursor:=save else CURSOR:=ANCHOR; END; 1:INDELETE:=FALSE; OK:=(LINE=STARTLINE) AND NOT DOFFSCREEN; UPSCREEN(OK,NOT OK,LINE);      AN; PROCEDURE NEXTCH; BEGIN CH:=GETCH; IF CH=CHR(ESCC) THEN BEGIN IF NOT JUSTIN THEN REDISPLAY; SHOWCURSOR; NEXTCOMMAND; escape(106); END ELSE IF ((ord(ch)>=32) and (ord(ch)<>127)) or (ch=chr(bss)) then IN THEN REDISPLAY; NEXTCOMMAND; escape(106); END; PLENGTH:=I-1; END (* PARSESTRING *); FUNCTION OK(PTR: EPTRTYPE): BOOLEAN; (* Compare PAT against the buffer *) VAR I : INTEGER; lch : char; lch2 : char; done : boolean; BEWRITE(output,CH); END; PROCEDURE SKIP; BEGIN WHILE CH IN [CHR(SP),CHR(HT),EOL] DO NEXTCH END; PROCEDURE OPTIONS; BEGIN REPEAT CH:=UCLC(CH); IF CH='L' THEN BEGIN MODE:=LITERAL; NEXTCH; END ELSE IF (CH='V')GIN I:=0; if (mode = literal) or (not pagezero.ignorecase) then WHILE (I= 'a') and (lch <= 'z') then lch := chr( ord(lch ) - (ord('a')-ord('A')) ); if (lch2 >= 'a') and (lch2 <= 'z') then lch2 := chr( ord(lch2) - (ord('a')-ord('A')) ); if lcommand=replacec)) OR (CH='T') OR (CH='L')); SKIP; IF (CH='S') OR (CH='s') THEN USEOLD:=TRUE; END; PROCEDURE PARSESTRING(VAR PATTERN: PTYPE; VAR PLENGTH: INTEGER); VAR I,J: INTEGER; BEGIN SKIP; IF CH IN ['A'..'Z','a'..'z','0'..'9',CHR(127),CHR(BSS)h = lch2 then i := i + 1 else done := true; end; end; OK:= I=PLENGTH; END; PROCEDURE SKIPKIND3(VAR CURSOR: EPTRTYPE); BEGIN (* Skip over kind3 characters in the ebuf. Update the cursor to the first n,chr(0)..chr(31)] THEN BEGIN error('Invalid delimiter.',fatalifstreaming); IF NOT JUSTIN THEN REDISPLAY; NEXTCOMMAND; escape(106); END; DELIMITER:=CH; I:=0; REPEAT NEXTCH; IF CH=CHR(BSS) THEN BEGIN on-kind3 character *) WHILE EBUF^[CURSOR] IN [CHR(SP),CHR(HT),CHR(DLE),EOL] DO IF EBUF^[CURSOR]=CHR(DLE) THEN CURSOR:=CURSOR+2 ELSE CURSOR:=CURSOR+1; END; PROCEDURE SCANBACKWARD; LABEL 1; VAR LOC: EPTRTYPE; CHTHERE: IF (PATTERN[I]<>EOL) AND (I>0) THEN (* Don't go overboard! *) BEGIN WRITE(output,' ',CHR(BSS)); I:=I-1 END ELSE CONTROL(RIGHTCURSOR); (* Make up for the NEXTCH wrote out *) END ELSE I BOOLEAN; lch : char; lch2 : char; BEGIN CHTHERE:=TRUE; THERE:=FALSE; FILLCHAR(PAT[0],SIZEOF(PAT),' '); MOVELEFT(TARGET[START],PAT[0],PLENGTH); lch := pat[0]; lch2 := lch; if (pagezero.ignorecase) and (mode = token) then if (lch >F CH=CHR(127) THEN BEGIN IF (PATTERN[I]<>EOL) THEN (* Don't go overboard! *) WHILE I > 0 DO BEGIN WRITE(output,chr(bss),' ',CHR(BSS)); I:=I-1; END; END ELSE if (ord= 'a') and (lch <= 'z') or (lch >= 'A') and (lch <= 'Z') then begin lch2 := chr(ord(lch2) mod (ord('a')-ord('A'))); lch := chr(ord(lch2) + ord('A')-1 ); lch2 := chr(ord(lch2) + ord('a')-1 ); end; WHILE CHTHERE AND(ch)>=32) then { only allow printable chars } BEGIN PATTERN[I]:=CH; I:=I+1 END; UNTIL (CH=DELIMITER) OR (I>=MAXSTRING); IF I>=MAXCHAR THEN BEGIN error('Pattern too long',fatalifstreaming); IF NOT JUST NOT THERE DO BEGIN 1: IF PTR>=PLENGTH THEN (* Possibly there *) begin LOC := SCAN(-PTR,=lch ,EBUF^[PTR]); if lch <> lch2 then loc := max(loc, SCAN(-PTR,=lch2,EBUF^[PTR])); end ELSE      1]=CHR(DLE) THEN BEGIN PTR:=NEXT; GOTO 1; END; IF OK(PTR) THEN THERE:=TRUE ELSE PTR:=NEXT; END END; END; PROCEDURE GOFORIT; PROCEDURE NEXTLINE; (* Given NEXTSTART, calcul,PLENGTH); IF PTR+PLENGTH > BUFCOUNT THEN FOUND:=FALSE ELSE IF NOT OK(PTR) THEN FOUND:=FALSE; END; END; (* In token mode make sure the first and last characters of the target arate the START and STOP for the next line *) BEGIN LASTPATTERN:=FALSE; START:=NEXTSTART; STOP:=MIN(TLENGTH-1,START+SCAN(TLENGTH-START,=EOL,TARGET[START])); IF STOP=TLENGTH-1 THEN BEGIN STOP:=MAX(STOP,0); LASTPATTERN:=TRUE; END; e on 'token boundaries' *) IF MODE=TOKEN THEN IF KIND[target[0]]=ORD('A') THEN IF FOUND THEN BEGIN IF ((COULDBE>2) AND (EBUF^[COULDBE-2]<>CHR(DLE))) OR (COULDBE<=2) THEN (* whew! *) IF KI LOC:=-PTR; IF LOC=-PTR THEN (* Not there! *) BEGIN CHTHERE:=FALSE; THERE:=FALSE END ELSE BEGIN PTR:=PTR+LOC; NEXT:=PTR-1; IF EBUF^[PTR-1]=CHR(DLE) THEN BEGIN  NEXTSTART:=STOP+1; END; PROCEDURE NEXTTOKEN; (* Given NEXTSTART, calculate START and STOP *) BEGIN LASTPATTERN:=FALSE; START:=NEXTSTART; (* Skip over leading kind3 characters *) WHILE (TARGET[START] IN [CHR(SP),EOL,CHR(HT)]) AND (START= 'a') and (lch <= 'z') or (lch >= 'nd3 characters *) NEXTSTART:=STOP+1; WHILE (TARGET[NEXTSTART] IN [EOL,CHR(SP),CHR(HT)]) AND (NEXTSTART0 THEN (* still stuff to scan *) begin LOC :=SCAN(MAXSCAN,=lch ,EBUF^[PTR]); if lch <> lch2 then loc := min(loc, SCAN(MAXSCAN,=lch2,EBUF^[PTR])); end ELSE :=STOP-START+1; IF DIRECTION='>' THEN SCANFORWARD ELSE SCANBACKWARD; IF THERE THEN BEGIN COULDBE:=PTR; FOUND:=TRUE; WHILE (NOT LASTPATTERN) AND FOUND DO BEGIN IF MODE=LITERAL THEN NEXTLINE ELS LOC:=MAXSCAN; (* Dummy up 'not found' condition *) IF LOC=MAXSCAN THEN BEGIN CHTHERE:=FALSE; THERE:=FALSE; END ELSE BEGIN PTR:=LOC+PTR; NEXT:=PTR+1; IF EBUF^[PTR-E NEXTTOKEN; PTR:=PTR+PLENGTH; SKIPKIND3(PTR); (* Go past the junk on the next line *) PLENGTH:=STOP-START+1; (* For the new line *) FILLCHAR(PAT[0],SIZEOF(PAT),' '); MOVELEFT(TARGET[START],PAT[0]     ND[EBUF^[COULDBE]]=KIND[EBUF^[COULDBE-1]] THEN FOUND:=FALSE; (* False find... don't count it. *) IF (PTR+PLENGTH<=BUFCOUNT-1) then if kind[ebuf^[ptr+plength-1]]=ord('A') then if (KIND[EBUF^[PTR+PLEN BUFCOUNT:=BUFCOUNT+SLENGTH-tokensize; CURSOR :=CURSOR +SLENGTH-tokensize; end; JUSTIN:=FALSE; updated := true; 1:END; BEGIN try JUSTIN:=TRUE; USEOLD:=FALSE; VERIFY:=FALSE; IF PAGEZERO.TOKDEF THEN MODE:=TOKEN ELSE MODE:=LITERAL;GTH-1]]=KIND[EBUF^[PTR+PLENGTH]]) THEN FOUND:=FALSE; (* Another false find *) END; UNTIL FOUND OR NOT THERE; END(* goforit *); PROCEDURE PUTPROMPT(LEFT,RIGHT:STRING80; REPEATFACTOR:INTEGER; LORT:BOOLEAN); BEGIN PROMPTLINE:= IF ECOMMAND=FINDC THEN PUTPROMPT(' Find','=>',REPEATFACTOR,TRUE) ELSE PUTPROMPT(' Repl',' V =>',REPEATFACTOR,TRUE); NEEDPROMPT:=TRUE; NEXTCH; SKIP; OPTIONS; IF NOT USEOLD THEN BEGIN PARSESTRING(TARGET,TLELEFT; EPROMPT; WRITE(output,'['); IF INFINITY THEN WRITE(output,'/') ELSE WRITE(output,REPEATFACTOR:1); WRITE(output,']: '); IF LORT THEN IF MODE=TOKEN THEN WRITE(output,'L') ELSE WRITE(output,'T'); WRITE(output,RIGHT) END; PROCEDURE REPLACENGTH); if tlength=0 then begin tdefined := false; goto 1; end else TDEFINED:=TRUE; END; IF ECOMMAND=REPLACEC THEN BEGIN NEXTCH; SKIP; USEOLD:=FALSE; OPTIONS; IF NOT UIT; LABEL 1; var tokensize : integer; savlastpat : integer; BEGIN IF VERIFY THEN BEGIN CENTERCURSOR(TRASH,MIDDLE,NOT JUSTIN); PUTPROMPT(' Rpl','<'+esckey+'> aborts,R replaces,'' '' doesn''t', REPEATFACTOR-I+2,FASEOLD THEN BEGIN PARSESTRING(SUBSTRING,SLENGTH); SDEFINED:=TRUE END END; HOME; ECLEARLINE(0); IF ((ECOMMAND=FINDC) AND TDEFINED) OR ((ECOMMAND=REPLACEC) AND SDEFINED AND TDEFINED) THEN BEGIN I:=1LSE); { 3.0 ITF fix 4/6/84 } SHOWCURSOR; CH:=GETCH; IF CH=CHR(ESCC) THEN BEGIN GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART); NEXTCOMMAND; escape(106); END; IF (CH<>'R; FOUND:=TRUE; IF (DIRECTION='<') AND (CURSOR>1) THEN { 3.0 BUG 2/16/84} PTR:=CURSOR-1 { 3.0 BUG 2/16/84} ELSE { 3.0 BUG 2/16/84} PTR:=CUR') AND (CH<>'r') THEN GOTO 1; END; (* Replace TARGET with SUBSTRING *) tokensize := cursor-lastpat; IF SLENGTH>tokensize THEN IF SLENGTH-tokensize+BUFCOUNT>BUFSIZE-200 THEN BEGIN error('Buffer full. Replace aborted',fatalifsSOR; { 3.0 BUG 2/16/84} WHILE ((I<=REPEATFACTOR) OR INFINITY) AND FOUND DO BEGIN GOFORIT; (* Find the target (handles token and literal mode) *) I:=I+1; IF FOUND THEN treaming); GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART); NEXTCOMMAND; escape(106); END ELSE MOVERIGHT(EBUF^[CURSOR],EBUF^[LASTPAT+SLENGTH],BUFCOUNT-CURSOR) ELSE IF SLENGTHtokensize THEN begin savlastpat := lastpat; READJUST(LASTPAT,SLENGTH-tokensize); lastpat := savlastpat;  END; IF DIRECTION='<' THEN { 3.0 BUG 2/16/84 } IF FOUND OR (I>2) THEN { 3.0 BUG 2/16/84 } CURSOR:=LASTPAT; { 3.0 BUG 2/16/84 } {SETS CURSOR ON FIRST CHAR OF PATTERN WHEN GOING BACKWARD}      showcursor; nextcommand; end; MACRODEFC: DEFMACRO; QUITC: ; (* EXIT HANDLED IN OUTER BLOCK *) REPLACEC: FIND; SETC: SETSTUFF; VERIFYC: VERIFY; XECUTEC: XMACRO; ZAPC: ZAPIT; EQUALC: BEGIN  begin recovering := true; eclearscreen; writeln(output); writeln (output,'Fatal error encountered.'); if updated then begin writeln (o CURSOR:=LASTPAT; GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART); CENTERCURSOR(TRASH,MIDDLE,FALSE); SHOWCURSOR; NEXTCOMMAND END; ADJUSTC,DELETEC,PARAC,UP,DOWN, utput,'Will try to save text file.'); do_out; if out then writeln (output,'Work file updated.') else writeln ('Work file not updated. Text wa IF NOT FOUND THEN IF NOT( INFINITY AND (I>2) ) THEN if not streaming then ERROR('Pattern not found.',NONFATAL) END ELSE error('No old pattern.',fatalifstreaming); CENTERCURSOR(TRASH,MIDDLE,NOT JUSTIN); GETLEADING; C LEFT,RIGHT,ADVANCE,TABB,SPACE: MOVEIT ; otherwise END (* BIG LONG CASE STATEMENT *); END (* COMMANDER *); BEGIN (* Editcore *) try NEXTCOMMAND; WHILE ECOMMAND<>QUITC DO COMMANDER recover if escapecode<>103 then escape(escapecode); END; prURSOR:=MAX(STUFFSTART,CURSOR); 1: SHOWCURSOR; NEXTCOMMAND; recover if escapecode<>106 then escape(escapecode); END; { 7 Apr 80 - MCh: added second prompt line } PROCEDURE NEXTCOMMAND; BEGIN IF NEEDPROMPT THEN BEGIN PROMPTLINE:=COMPROMPTocedure xeditor; label 1; BEGIN (* procedure XEDITOR *) try INITIALIZE recover if escapecode=101 then goto 1 else escape(escapecode); GETLEADING; CURSOR:=MAX(CURSOR,STUFFSTART); iflag:=false; (* WAH 1/18/80 *) recovering := false; ; {Made variable for screens of short width. MAB} if prompt2flag then promptline := prompt2; { MCh: second prompt line } EPROMPT; NEEDPROMPT:=FALSE; SHOWCURSOR END; CH:=GETCH; ECOMMAND:=MAPTOCOMMAND(CH); END(* NEXTCOMMAND * { 19 May 80 - MCh: default state } REPEAT CENTERCURSOR(TRASH,MIDDLE,TRUE); NEEDPROMPT:=TRUE; prompt2flag := false; { 7 Apr 80 - MCh: second prompt line } REPEAT HOME; ECLEARLINE(0); try EDITCORE; IF ECOMM); PROCEDURE COMMANDER; BEGIN INFINITY:=FALSE; { 7 Apr 80 - MCh: default to using first prompt unless have a '?' command } if ecommand <> dumpc then prompt2flag := false; IF ECOMMAND=SLASHC THEN BEGIN REPEATFACTOR:=1; INFINITY:=TAND=SETC THEN ENVIRONMENT ELSE IF ECOMMAND=COPYC THEN COPYFILE; recover begin { 19 May 80 - MCh: save text in case of fatal error } if escapecode=101 then goto 1; if escapecode = -20 then RUE; NEXTCOMMAND; END ELSE IF ECOMMAND=DIGIT THEN REPEATFACTOR:=GETNUM ELSE REPEATFACTOR:=1; CASE ECOMMAND OF ILLEGAL: BEGIN ERRWAIT; SHOWCURSOR; NEXTCOMMAND END; REVERSEC,FORWARDC: FIXDIRECTION; COPYC: COPY; DUMPC: be { user interruption (stop key) } begin if not updated then escape(-20) else begin if oktostop then escape(-20) else gin { MCh: toggle prompt lines } needprompt := true; prompt2flag := not prompt2flag; nextcommand; end; FINDC: FIND; INSERTC: INSERTIT; JUMPC: JUMP; LISTC: begin errwait;  begin centercursor(trash,middle,true); needprompt := true; end; end; end else begin if escapecode <> -1 then      s not saved.'); end; end; escape (escapecode) { get back to the system } end; end; UNTIL ECOMMAND=QUITC; try do_out; recover if (escapecode = -20) and updatedwill ever be written to create them. it also presumes that the funny sector in the file will only exist in files in LIF/HFS directories. } type catarray = array[1..catlimit] of catentry; catentryelement = record link : anyptr;  then out := oktostop else escape(escapecode); UNTIL OUT; SYSCOM^.MISCINFO.NOBREAK := FALSE; (* 28 SEPT 77*) 1: END; end; {edit2} import xeditor; BEGIN xeditor; END. { of EDTR }  element : catentry; end; catentryelementptr = ^catentryelement; tidelement = record link : anyptr; element : tid; eft : shortint; end; tidelementptr = ^tidelement; passarray = array[1..catli$copyright 'COPYRIGHT (C) 1985,1991 BY HEWLETT-PACKARD CO.'$ $def 1$ $ref 65$ $modcal$ $range OFF$ $ovflcheck OFF$ $iocheck off$ $debug OFF$ $list on $ $ALLOW_PACKED ON$ { JWS 4/10/85 } program flr(keyboard,input,output); $search 'MATCHSTR'$ import smit] of passentry; passarrayptr = ^passarray; passentryelt = record link : anyptr; pelement : passentry; end; passentryeltptr = ^passentryelt; dirstatus = (dneeded,dwanted,dontcare); control = record cysglobals, misc, iocomasm, fs, sysdevs, ci, matchstr, asm; var keyboard : text; esckey : string[6]; { 3.0 ITF fix 4/6/84 } (*************************************************fib : fib; path : integer; diropen : boolean; fileopen : boolean; useunit : boolean; mounted : boolean; cpvol : vid; cvol : vid; cfile : fid; dstatus : dirstatus; b***************************) { Now in MISC - no reason to declare it at all } { As of version 50.2 we don't use it at all } { It's been replaced by unit_is_srmux - JWH 11/12/90 } { function srm_is_srmux_unit(unum : unitnum) : boolean; external; } proceduradclose : closecode; goodclose : closecode; end; var ch : char; ordefault : char; symsaved : boolean; codesaved : boolean; heapinuse : boolean; ininfo : control; outinfo : control; savee commandlevel; type prompttype = string80; buftype = packed array[0..maxint] of char; bigptr = ^buftype; closecode = (keepit,purgeit,closeit); const filerid = '3.25'; sprompt1 = 'Filer: Chg Get Lst Mak New Qt Rmv Trns Fcpy Udr ?'io : integer; saveesc : integer; lheap : anyptr; screenwidth : shortint; screenheight : shortint; linecount : shortint; (****************************************************************************) procedure fixlock; sprompt2 = 'Filer: Hfs Ac Dup Bad Kch Pfx Vol Wht Sav Zro ? ['; lprompt1 = 'Filer: Change Get Ldir New Quit Remove Save Translate Vols What Access Udir ?'; lprompt2 = 'Filer: Hfs Bad-secs Ext-dir Krunch Make Prefix Filecopy Duplicate Zero ? ['; ; begin if locklevel<>0 then begin locklevel := 1; lockdown; end; end; { fixlock } (****************************************************************************) procedure printioerrmsg; var msg : string[80]; begin if ioresult<>ord(inoerror)  catlimit = 200; sh_exc = chr(27); bdat = -5791; { BDAT WORT #0 } bdat_500 = -5663; { fix bdat 500 file copy } { code in the FILER presumes that bdat files will never be created by the file system i.e. no AM then begin getioerrmsg(msg,ioresult); writeln('Error: ',msg,cteol); if streaming then escape(-1); end; end; { printioerrmsg } (****************************************************************************) procedure showprompt(p : prompt     ; ti : integer; instring : string[20]; begin readln(instring); goodio; i := changestr(instring,1,-1,' ',''); { squash blanks } if instring=sh_exc then badio(inoerror); if strlen(instring)>0 then try begin ti := 0; for **************************************************************) procedure promptread(p:prompttype; var answer:char; list:prompttype; default:char); var s1 : string[1]; done : boolean; begin if (default<>sh_exc) and streaming then answer:=defi:=1 to strlen(instring) do if (instring[i]<'0') or (instring[i]>'9') then badio(ibadvalue) else ti := ti * 10 + (ord(instring[i]) - ord('0')); int := ti; end; recover if escapecode=-4 then badio(ibadvalue) else escape(escapecode);ault else begin setstrlen(s1,1); write(p,cteol); repeat read(keyboard,answer); readcheck; upcchar(answer); if answer=sh_exc then begin writeln; badio(inoerror); end; s1[1] := answer; done := breakstr(s1,1,list)>0; type); begin write(homechar,p,cteol); end; (****************************************************************************) procedure showmove(var v1,f1,v2,f2 : string); begin if screenwidth<73 then begin writeln(' ',v1,':',f1,cteol); writeln('==> end; { readnumber } (****************************************************************************) function unitnumber(var fvid : vid):boolean; begin unitnumber := false; if strlen(fvid) > 1 then if fvid[1]='#' then begin if (fvid[2]',v2,':',f2,cteol); end else writeln(v1,':',f1,'':32-strlen(v1)-strlen(f1),' ==> ',v2,':',f2,cteol); end; { showmove } (****************************************************************************) procedure goodio; begin if ioresult<>ord(inoerror)>='0') and (fvid[2]<='9') then unitnumber := (spanstr(fvid, 2, '0123456789') = strlen(fvid)); end; end; { unitnumber } (****************************************************************************) function unit_is_hfs(un : unitnum):boolean; {quick  then escape(0); end; (****************************************************************************) procedure badio(iocode : iorsltwd); begin ioresult := ord(iocode); escape(0); end; (*********************************************************************check, is unit HFS? SFB} begin unit_is_hfs := FALSE; if h_unitable<>nil then if h_unitable^.tbl[un].is_hfsunit then unit_is_hfs := TRUE; end; (****************************************************************************) { Added 11/12/90 JWH : } *******) procedure badmessage(p : prompttype); begin writeln(p,cteol); if streaming then escape(-1) else badio(inoerror); end; { badmessage } (****************************************************************************) procedure badcommand(c:charfunction unit_is_srmux(un : unitnum):boolean; {quick check, SRM/UX ? JWH } { The SRMDAM has been modified to return ibadvalue for a setvolumename request if the unit is SRM/UX (instead of ibadrequest, which is what the SRMDAM used to return, and still ); begin writeln('bad command ''',c,''''); if streaming then escape(-1) else badio(inoerror); end; { badcommand } (****************************************************************************) procedure readcheck; begin if ioresult<>ord(inoerror)does, for SRM units. } var f : fib; begin unit_is_srmux := FALSE; with unitable^[un] do begin if letter = 'G' then { srm or srm/ux } begin call(dam,f,un,setvolumename); if ioresult = ord(ibadvalue) then unit_is_srmux := then begin saveio := ioresult; writeln; ioresult := saveio; escape(0); end; end; { readcheck } (****************************************************************************) procedure readnumber(var int : integer); var i : integer TRUE; { otherwise SRM } end; end; end; (****************************************************************************) procedure upcchar(var ch : char); begin if ('a'<=ch) and (ch<='z') then ch:=chr(ord(ch)-32); end; { upcchar } (**************      if not done and streaming then badcommand(answer); until done; writeln(answer); end; end; { promptread } (****************************************************************************) procedure promptyorn(p : prompttype; var answer :chaelse if cvol<>tempname then cfib.funit := 0; end; end; end; until cfib.funit>0; cfib.fvid := cvol; mounted := true; end; end; { mount volume } (****************************************************************************)r); begin promptread(p+' ? (Y/N) ',answer,'YN','Y'); end; { promptyorn } (****************************************************************************) procedure mountvolume(sd : prompttype ;var finfo : control); var answer : char; unit  procedure check; label 1; var i : integer; j : integer; begin for i := 1 to maxunit do with unitable^[i] do if strlen(uvid) > 0 then for j := i+1 to maxunit do if strlen(unitable^[j].uvid) > 0 then if uvid = unitable^[j] : integer; tempname : vid; begin with finfo do begin if streaming then begin writeln('Volume ',cpvol,' not online while streaming',cteol); escape(-1); end; tempname := cpvol; unit := findvolume(tempna.uvid then begin call(dam,uvid,i,getvolumename); if strlen(unitable^[i].uvid) > 0 then begin with unitable^[j] do call(dam,uvid,j,getvolumename); if uvid = unitable^[j].uvid then begin writeln(cteol); writeln('Warninme,false); { check for bad unit # } ioresult := ord(inoerror); {invalidate cache} if unit_is_hfs(cfib.funit) then call(h_unitable^.inval_cache_proc, cfib.funit); repeat { construct the prompt } write('Please mount',sd); g: More than one volume named ',uvid,':',cteol); writeln('It is not illegal but can be very dangerous.',cteol); goto 1; end; end; end; 1: end; { check } (************************************************************************* if strlen(cvol)>0 then write(' volume ',cvol); if ((strlen(sd)>0) or (strlen(cvol)>0)) and useunit then write(' in'); if useunit then write(' unit ',cpvol); writeln(cteol); promptread('''C'' continues, <'+esckey+'> aborts ',answer,***) function getwildcard(var pattern : fid) : char; begin if strpos('?',pattern) > 0 then getwildcard := '?' else if strpos('=',pattern) > 0 then getwildcard := '=' else getwildcard := ' '; end; { getwildcard } (****************************'C','C'); { 3.0 ITF fix 4/6/84 } if useunit then tempname := cpvol else tempname := cvol; cfib.funit := findvolume(tempname,true); if cfib.funit>0 then begin if ioresult=ord(inodirectory) then begin if dstatus<>dontca************************************************) procedure compatible(var p1, p2 : fid); var ptr, c1, c2 : integer; begin ptr:=0; c1:=-1; c2:=-1; repeat c1:=c1+1; ptr:=breakstr(p1,ptr+1,'=?'); until ptr=0; repeat c2:=c2+1; re then writeln('No directory on ',cpvol); setstrlen(tempname,0); case dstatus of dneeded: cfib.funit := 0; dwanted: begin promptyorn('Use current media',answer); if answer='N' then cfib.funit := 0 else dstatus  ptr:=breakstr(p2,ptr+1,'=?'); until ptr=0; if not ((c1 = c2) or (p2 = '$')) then badmessage('Invalid use of wildcards'); end; { compatible } (****************************************************************************) function match(n1 : fid;  := dontcare; end; otherwise end; { case dstatus } end else begin if ioresult<>ord(inoerror) then begin printioerrmsg; cfib.funit := 0; end else begin { found a directory } if cvol='' then cvol := tempname var p1 : fid):boolean; label 1,2; var ptr, ptr1, ptr2 : integer; mstring : fid; anchored : boolean; begin match := true; if (p1='=') or (p1='?') or (strlen(p1)=0) then goto 2; ptr1 := 1; ptr2 := 1; anchored := true; rep      := changestr(n2,1,1,'=','') else haveeq := true; end else begin if anchored then begin ptr1 := ptr; ptr2 := ptr; end else begin mstring := str(p1,ptr1,ptr-ptr1); ptr1 := ptr; if (ptr1>strlen(p1)) and (not a) and (day<=31) {RDQ 21MAR88 excluded 1Jan70 from valid dates} and not ((year=70) and (month=1) and (day=1)) then write(listfile,' ',day:2,'-',months[month],'-',year mod 100:2) else write(listfile,' ':10); end; { writedate } (***nchored) then ptr3 := beforestr(n1,ptr2,-1,mstring) else ptr3 := beforestr(n1,ptr2,1,mstring); ptr := changestr(n2,1,1,'=',str(n1,ptr2,ptr3-ptr2)); ptr2 := ptr3 + strlen(mstring); if ptr1>strlen(p1) then goto 1; haveeq := false; end; e*************************************************************************) procedure writetime(var listfile : text; var time : timerec); begin with time do if (hour>0) or (minute>0) or (centisecond>0) then write(listfile,' ',hour:2,'.eat ptr := breakstr(p1,ptr1,'=?'); if ptr=0 then ptr := strlen(p1)+1; if ptr=ptr1 then begin { begin unanchored matching } ptr1 := ptr1+1; if ptr1>strlen(p1) then goto 2 else anchored := false; end else beginnd; until false; 1:end; { makenewname } (****************************************************************************) procedure spacewait; var answer : char; begin promptread(' continues, <'+esckey+'> aborts ',answer,' ',' ');  { match characters } mstring := str(p1,ptr1,ptr-ptr1); ptr1 := ptr; if (ptr1>strlen(p1)) and (not anchored) then ptr := afterstr(n1,ptr2,-1,mstring) else ptr := afterstr(n1,ptr2,1,mstring); if ptr=0 then goto 1; if a { 3.0 ITF fix 4/6/84 } end; { spacewait } (****************************************************************************) function samedevice(unit1,unit2:unitnum):boolean; var u1p : ^unitentry; begin u1p := addr(unitable^[unit1]); with unitabnchored and (ptr<>(ptr2+strlen(mstring))) then goto 1; ptr2 := ptr; if ptr1>strlen(p1) then if ptr2>strlen(n1) then goto 2 else goto 1; end; until false; 1:match:=false; 2:end; { match } (*****************************************le^[unit2] do samedevice := (u1p^.sc=sc) and (u1p^.ba=ba) and (u1p^.du=du) and (u1p^.dv=dv) and (u1p^.letter=letter) and (u1p^.byteoffset=byteoffset); end; { samedevice } (*************************************************************************************************************) procedure makenewname(var p1,p2 : fid; n1 : fid; var n2:fid); label 1; var ptr, ptr1, ptr2, ptr3 : integer; anchored, haveeq : boolean; mstring : fid; begin if p2='$' then begin n2 := n1; goto 1; **) function bytestoblocks( bytes : integer; blocksize : integer):integer; begin bytestoblocks := bytes; if blocksize>0 then begin bytestoblocks := (bytes + blocksize - 1) div blocksize; end; end; { bytestoblocks } $IOCHECK ON$ {3end; { begin name generation } n2 := p2; ptr := changestr(n2,1,-1,'?','='); ptr1 := 1; ptr2 := 1; anchored := true; haveeq := false; repeat ptr := breakstr(p1,ptr1,'=?'); if ptr=0 then ptr := strlen(p1)+1;1JAN83 LOOKOUT FOR PRINTER TIMEOUTS} (****************************************************************************) procedure writedate(var listfile : text; var date : daterec); type string3 = string[3]; mnths = array [0..15] of string3; c if ptr=ptr1 then begin ptr1 := ptr1+1; if ptr1>strlen(p1) then begin mstring := str(n1,ptr2,strlen(n1)-ptr2+1); ptr := changestr(n2,1,1,'=',mstring); goto 1; end else anchored := false; if haveeq then ptronst months = mnths['???','Jan','Feb','Mar','Apr','May','Jun','Jul', 'Aug','Sep','Oct','Nov','Dec','???','???','???']; begin with date do {LAF 880101 added "mod 100" and changed test from "year>0"} if (1<=month) and (month<=12) and (1<=day     ',minute:2,'.',centisecond div 100:2) else write(listfile,' ':9); end; { writetime } (****************************************************************************) procedure showcatheader( long : boolean; order : boolean; *********) procedure showcatentry( long : boolean; var lcatentry : catentry; var listfile : text; var count : integer; unum : integer); var blocks : integer; nullpos : integer; beginvar dircatentry : catentry; var listfile : text; var count : integer; unum : integer); begin with dircatentry do begin write(listfile,cname,':','':17-strlen(cname)); writeln(listfile,' Directory type= ',cinfo); if not unit with lcatentry do begin nullpos := strpos (nullchar, cname); if nullpos <> 0 then setstrlen (cname, (nullpos - 1)); write(listfile,cname,'':16-strlen(cname)); write(listfile,' ',bytestoblocks(cpsize,cblocksize):10);{ physical si_is_srmux(unum) then if ccreatedate.year > 0 then begin write(listfile,'created'); writedate(listfile,ccreatedate); writetime(listfile,ccreatetime); writeln(listfile,' block size=',cblocksize:1); end; if (clastdateze } write(listfile,' ',clsize:10); { logical size } if long then begin { E type listing } if cstart>=0 then write(listfile,' ',bytestoblocks(cstart,cblocksize):10) else write(listfile,' ':11); if unit_is_srmux(unum) then w.year>0) then begin write(listfile,'changed'); writedate(listfile,clastdate); writetime(listfile,clasttime); end; if ((ccreatedate.year <= 0) or (unit_is_srmux(unum))) then begin writeln(listfile,' block size=',cblocrite(listfile,' '); writedate(listfile,clastdate); writetime(listfile,clasttime); if unit_is_srmux(unum) then writeln(listfile,cextra1:8) else writeln(listfile,cextra1:11); count := count + 1 + (79 div screenwidth); ksize:1); end; if order then write(listfile,' Alphabetic order') else write(listfile,' Storage order'); writeln(listfile); count := 3; end; write(listfile,'...file name.... # blks # bytes '); if long then begin if no { start line two } write(listfile,' ':17); case ckind of untypedfile : write(listfile,'Dir '); badfile : write(listfile,'Bad '); codefile : write(listfile,'Code '); textfile : write(listfile,'Text '); asciifile : write(lt unit_is_srmux(unum) then begin writeln(listfile,' start blk ....last change... extension1'); write(listfile,' ':17,'type t-code ..directory info...'); writeln(listfile,' ....create date... extension2'); end else beginistfile,'Ascii'); datafile : write(listfile,'Data '); sysfile : write(listfile,'Systm'); uxfile : write(listfile,'Hp-ux'); otherwise write(listfile,suffixtable^[ckind]:5); end; { case ckind } write(listfile,ceft:7); i writeln(listfile,' start blk ....last change... extension1'); write(listfile,' ':17,'type t-code ...directory info...'); writeln(listfile,' ...create date.. extension2'); end; count := count + 2 * (79 DIV SCREENWIDTH + 1);f not unit_is_srmux(unum) then write(listfile,' ',cinfo,'':19-strlen(cinfo)) else write(listfile,' ',cinfo,'':22-strlen(cinfo)); if not unit_is_srmux(unum) then begin if ccreatedate.year>0 then begin writedate(listfile,ccreatedate end else begin writeln(listfile,' last chng'); count := count + 1; end; writeln(listfile); { header separator line } count := count + 1; end; { showcatheader } (*******************************************************************); writetime(listfile,ccreatetime); end { good create date } else write(listfile,' ':19); end else write(listfile,' ':19); { SRM-UX - no create date available } if not unit_is_srmux(unum) then write(listfile,cextra2:11) else wri     tore pathid } call(unitable^[funit].dam,cfib,funit,closedirectory); diropen := false; lockdown; end; end; end; { closedir } (****************************************************************************) procedure opendir(filenamst command should always use FALSE. Commands using this routine to simply get a list of file names should use TRUE. } type listelement = record case boolean of true : (cat : catentryelement); false : (nam : tidelement); end; lise : fid; var searchname : fid; prompt : prompttype; var finfo : control; var dircatentry : catentry); var doparent : boolean; unit : integer; begin { opendir } ioresult := ord(inoerror); withtptr = ^listelement; var i : integer; catentries : catarray; currelement : listptr; prevelement : listptr; nextelement : listptr; procedure linkorder; var done : boolean; begin currelement^.nam.link := nte(listfile,cextra2:8); count := count + (79 div screenwidth); end { E type listing } else writedate(listfile,clastdate); { L type listing } writeln(listfile); count := count + 1; end; { with lcatentry } end; { sho finfo, cfib do try lockup; doparent := diropen; if doparent then closedir(finfo); diropen := false; lockdown; setupfibforfile(filename,cfib,cpvol); useunit := unitnumber(cpvol); dstatus := dneeded; if useunit then wcatentry } $IOCHECK OFF$ (****************************************************************************) procedure setupfibforfile(filename : fid; var lfib : fib; var vname : vid); var lkind : filekind; segs : intcvol := '' else cvol := cpvol; if (funit=0) or unitnumber(fvid) then mountvolume(prompt,finfo) else mounted := true; with unitable^[funit] do begin lockup; { lock keyboard } fwindow := addr(dircatentry); eger; begin segs := 0; ioresult := ord(inoerror); with lfib do if scantitle(filename,fvid,ftitle,segs,lkind) then begin vname := fvid; funit := findvolume(fvid,true); fkind := lkind; feft := efttablif doparent then call(dam,cfib,funit,openparentdir) else call(dam,cfib,funit,opendirectory); diropen := (ioresult=ord(inoerror)); if diropen then begin path := pathid; searchname := ftitle; cvol := dircatentry.cname;e^[lkind]; foptstring := nil; fbuffered := true; fpos := segs * 512; freptcnt := 0; fanonymous := false; fmodified := false; fbufchanged:= false; fstartaddress := 0; flastpos := -1; pa end; lockdown; { unlock keyboard } if not diropen then escape(0); { opendirectory failed } end recover if escapecode<>0 then escape(escapecode); end; { opendir } (*************************************************thid := -1; fnosrmtemp := true; flocked := true; feof := false; feoln := false; fb0 := false; fb1 := false; end else badio(ibadtitle); end; { setupfibforfile } (******************************************) procedure makenamelist(var f : fib; var searchname : fid; var nameptr : anyptr; bigelement : boolean; order : boolean; shortlist : boolean; var filecoun*************************************************************) procedure closedir(var finfo : control); begin with finfo, cfib do begin if diropen then begin lockup; { lock keyboard for this operation } pathid := path; { rest : integer); { The shortlist parameter has reversed and twisted logic. A FALSE value means to give a slower, but truthful answer. A TRUE value means to give a fast lie. The truth is the size of the file without the workstation header. The li     il; if nameptr=nil then nameptr := addr(currelement^) else begin prevelement := nil; nextelement := nameptr; done := false; repeat if currelement^.nam.element>=nextelement^.nam.element then begin prevelement := nextinoerror)); fwindow := nil; end; end; { makenamelist } (****************************************************************************) procedure editnamelist(var nameptr : tidelementptr; prompt : string80; wildcard : chaelement; nextelement := nextelement^.nam.link; if nextelement=nil then begin prevelement^.nam.link := currelement; done := true; end; end else begin if prevelement=nil then begin currelement^.nam.link := nameptr; nameptr := curreler); var currptr : tidelementptr; tailptr : tidelementptr; answer : char; count : integer; begin count := 0; currptr := nameptr; nameptr := nil; tailptr := nil; while (currptr<>nil) do begin if not streaming then write(prompment; end else begin currelement^.nam.link := prevelement^.nam.link; prevelement^.nam.link := currelement; end; done := true; end; until done; end; end; begin { makenamelist } prevelement := nil; nameptr := nilt,currptr^.element); if wildcard='?' then promptyorn('',answer); if (answer='Y') or (wildcard<>'?') then begin if tailptr=nil then nameptr := currptr else tailptr^.link := currptr; tailptr := currptr; end; currp; filecount := 0; with f, unitable^[funit] do begin fwindow := addr(catentries); fpos := 0; fpeof := catlimit; fb0 := shortlist; repeat call(dam,f,funit,catalog); if ioresult = ord(inoerror) then begtr := currptr^.link; if tailptr<>nil then tailptr^.link := nil; if (wildcard<>'?') and not streaming then writeln; if not streaming and (wildcard<>'?') and (currptr<>nil) then begin count := count + 1; if count=screenheigin filecount := filecount + fpeof; for i := 1 to fpeof do if match(catentries[i].cname,searchname) then begin if bigelement then begin new(currelement,true); currelement^.cat.element := catentries[i]; if order then liht - 2 then begin spacewait; count := 0; end; end; end; end; { editnamelist } (****************************************************************************) procedure inmount(swap : boolean); begin if not ininfo.mounted then with ininfonkorder else begin if nameptr=nil then nameptr := addr(currelement^); if prevelement<>nil then prevelement^.cat.link := currelement; prevelement := currelement; currelement^.cat.link := nil; end; end else begin , cfib do begin mountvolume(' SOURCE',ininfo); unitable^[funit].umediavalid := true; outinfo.mounted := not swap; end; end; { inmount } (****************************************************************************) procedure outmount(sw new(currelement,false); currelement^.nam.element := catentries[i].cname; currelement^.nam.eft := catentries[i].ceft; if order then linkorder else begin if nameptr=nil then nameptr := addr(currelement^); if pap : boolean); begin if not outinfo.mounted then with outinfo, cfib do begin mountvolume(' DESTINATION',outinfo); unitable^[funit].umediavalid := true; ininfo.mounted := not swap; end; end; { outmount } (***************************revelement<>nil then prevelement^.nam.link := currelement; currelement^.nam.link := nil; prevelement := currelement; end; end; end; if fpeof=catlimit then fpos := fpos + fpeof; end; until (fpeoford(*************************************************) procedure closeinfile; begin with ininfo ,cfib do begin if fileopen then begin lockup; fmodified := false; call(unitable^[funit].dam,cfib,funit,closefile); fileopen := f     >ord(inoerror) then ioresult := ord(inoerror) else begin { file exists } badclose := closeit; { set closeoption } lockdown; if not streaming then begin writeln(cvol,':',ftid,cteol); if allowover then promptread('exis= addr(bufptr^,strlen(bufrec^)); leftinbuf := leftinbuf - strlen(bufrec^) - 2; if strlen(bufrec^) = 255 then bufptr := addr(bufptr^,-1) else begin if strlen(bufrec^)=0 then begin { discard the length byte } bufptr := addr(bufrec^,-1); leftints ... Remove/Overwrite/Neither ? (R/O/N) ', answer,'RON',ordefault) else promptyorn('exists ... remove it',answer); end else answer := 'Y'; lockup; if (answer='Y') or (answer='R') then begin call(dam,cfib,funit,purgefile); saveiobuf := leftinbuf + {1} 2; { RQ/SFB 3/15/84 3.0 BUG} end; { check end of line/file } call(am,ffib,readbytes,bufptr^,1,fpos); if feoln then begin { end of line } bufptr^ := chr(1); feoln := false; LEFTINBUF := LEFTINBUF -1; alse; lockdown; end; end; end; { closeinfile } (****************************************************************************) procedure closeoutfile(position : integer; option : closecode); var coption : damrequesttype; begin with outin := ioresult; if ioresult<>ord(inoerror) then answer := 'N'; end; if (answer='N') or (answer='O') then begin call(dam,cfib,funit,closefile); outnotthere := answer='O'; {O or N} end; fileopen := false; badclose := oldopt; { restore closeofo, cfib do begin if fileopen then begin case option of keepit: begin fleof := position; fmodified := true; coption := closefile; end; purgeit: coption := purgefile; closeit: begin coption := closefilption } end; cfib := tempfib; { restore fib } lockdown; recover begin saveio := ioresult; saveesc := escapecode; closeoutfile(0,outinfo.badclose); ioresult := saveio; escape(saveesc); end; if saveio<>0e; fmodified := false; end; end; lockup; call(unitable^[funit].dam,cfib,funit,coption); fileopen := false; lockdown; end; end; end; { closeoutfile } (********************************************************* then begin ioresult := saveio; printioerrmsg; end; end; { with ... } end; { outnotthere } (****************************************************************************) procedure anytomem( ffib : fibp; anyvar buffer : big*******************) procedure closeall(position : integer); begin closeinfile; closeoutfile(position,outinfo.badclose); closedir(ininfo); closedir(outinfo); end; { closeall } (*******************************************************************ptr; maxbuf : integer); var bufrec : ^string255; bufptr : ^char; leftinbuf : integer; begin { anytomem } bufptr := addr(buffer^); bufptr^ := chr(0); { data comming } bufrec := addr(bufptr^,1); setstrlen(bufrec^,0); {*********) function outnotthere (var answer : char; allowover : boolean): boolean; var oldopt : closecode; tempfib : fib; begin with outinfo, cfib, unitable^[funit] do begin outnotthere := true; saveio := 0; lockup; { lock k zero length record } bufptr := addr(bufrec^,1); leftinbuf := maxbuf; with ffib^, unitable^[funit] do begin { BDAT WORT #1 stop translate request for bdat files } if (feft=bdat) or (feft= bdat_500) {fix bdat 500 file copy} then eyboard except for around prompt } try tempfib := cfib; { save fib } oldopt := badclose; { save closeoption } call(dam,cfib,funit,openfile); fileopen := (ioresult=ord(inoerror)); if ioresult<ioresult := ord(ibadrequest) else call(am,ffib,readtoeol,bufrec^,255,fpos); if ioresult=ord(ibadrequest) then buffer^[0] := chr(4) else begin { string reads } repeat goodio; { check ioresult from last readtoeol } bufptr :      { RQ/SFB 3/15/84 3.0 BUG} if ioresult = ord(ieof) then bufptr := addr(bufptr^,1); end; if ioresult=ord(ieof) then begin { end of file } bufptr^ := chr(2); ioresult := ord(inoerror); feof := true; end; goodio; ar root:string; var result: fid; default : filekind); var tempk : filekind; begin result := root; tempk := suffix(result); if tempk=codefile then begin setstrlen(result,strlen(result)-strlen(suffixtable^[codefile])); result := result + s { check ioresult from readbytes } end; if not ((leftinbuf < 259) or feof) then begin { setup for then read the next line } bufptr := addr(bufptr^,1); bufptr^ := chr(0); { data record } bufrec := addr(bufptr^,1); setstrlen(bufrec^,0uffixtable^[default]; end else if tempk<>default then fixname(result,default); end; { fixsrcfile } (****************************************************************************) procedure fixcodefile(var root:string; var result: fid); var lki); { zero length record } bufptr := addr(bufrec^,1); call(am,ffib,readtoeol,bufrec^,255,fpos); end; until (leftinbuf < 259) or feof; end; { string reads } bufptr := addr(bufptr^,1); bufptr^ := chr(3); { end buffer } end;nd : filekind; begin result := root; fixname(result,codefile); lkind := suffix(result); if lkind = datafile then result := result + '.' + suffixtable^[codefile] else if lkind <> codefile then begin { replace old suffix with CODE file } se end; { anytomem } (****************************************************************************) procedure memtoany(anyvar buffer : bigptr; FFIB : fibp); var bytes : integer; bufptr: ^char; begin bufptr := addr(buffer^); with ffib^, untstrlen(result,strlen(result)-strlen(suffixtable^[lkind])); result := result + suffixtable^[codefile]; end; end; { fixcodefile } (****************************************************************************) function domove(var inname,outname:stritable^[funit] do begin bytes := 0; repeat bufptr := addr(bufptr^,bytes); bytes := ord(bufptr^); bufptr := addr(bufptr^,1); case bytes of 0: begin { data bytes } bytes := ord(bufptr^); { record leing; source:boolean):boolean; { file --> file move } var lefttoxfer : integer; bufsize : integer; buf : ^buftype; position : integer; outsize : integer; dumwindow : windowp; overcreate : damrequesttype; ngth } bufptr:= addr(bufptr^,1); call(am,ffib,writebytes,bufptr^,bytes,fpos); end; 1: begin { end record } call(am,ffib,writeeol,bufptr^,bytes,fpos); bytes := 0; if uisinteractive and (uvid='CONSOLE') then begin answer : char; done : boolean; swap : boolean; docopy : boolean; filename : fid; fixedname : fid; filename2 : fid; dircatentry : catentry; save_fkind : filekind; save_feft : integer;  linecount:=linecount+1; if linecount=screenheight-1 then begin spacewait; write(upchar,cteol,eol); linecount:=0; end; end; end; 2: begin { end file } call(am,ffib,flush,bufptr^,bytes,fpos); bytes := -1; end; begin { domove } domove := false; swap := false; mark(lheap); heapinuse := true; ininfo.diropen := false; ininfo.fileopen := false; outinfo.diropen := false; outinfo.fileopen := false; outinfo.badclose := purgeit 3: bytes := -1; { end buffer } otherwise ioresult := ord(ibadrequest); end; goodio; until bytes<0; end; end; { memtoany } (****************************************************************************) procedure fixsrcfile(v; outinfo.goodclose := keepit; if (strlen(inname)=0) or (strlen(outname)=0) then badio(ibadtitle); if inname=outname then domove := true else try with ininfo, cfib do begin { open the input file } opendir(inname,filename,' SOURCE'     fleof) then badio(inoroom); end; outsize := outinfo.cfib.fpos; { remember the requested size } end; { with ininfo, cfib } bufsize := (memavail div 256) * 256 - 30 * 512 {save some for slop}; if bufsize<512 then escape(-2 end; goodio; if lefttoxfer=0 then begin closeinfile; closedir(ininfo); end; write(cteol); { write destination file } with outinfo, cfib do begin if not fileopen then begin { open destination file } if useunit); newwords(buf,bufsize div 2); done := false; if docopy and (ininfo.cfib.funit=outinfo.cfib.funit) and (ininfo.cfib.funit=sysunit) and not outinfo.useunit and (outinfo.cfib.fpos=ininfo.cfib.fleof) and (ininfo.cv and swap then swap := samedevice(funit,ininfo.cfib.funit) else swap := false; if not diropen then begin save_fkind := fkind; save_feft := feft; opendir(fixedname,cfile,' DESTINATION',outinfo,dircatentry); if not diropen,ininfo,dircatentry); if not diropen then escape(0); if (strlen(filename)=0) then badio(ibadrequest); lockup; newwords(dumwindow,1); { dummy window } finitb(cfib,dumwindow,-3); { setup for translate } col=outinfo.cvol) then begin {looks like destination is on sysvol so do changename } opendir(fixedname,filename2,' Destination',outinfo,dircatentry); if not outinfo.diropen then escape(0); if (strlen(filename2)=0) then badio(ibadreall(unitable^[funit].dam,cfib,funit,openfile); fileopen := (ioresult=ord(inoerror)); lockdown; goodio; feof := false; feoln := false; cfile := ftid; flastpos := -1; lefttoxfer := fleof; poquest); if getwildcard(filename2)<>' ' then badio(ibadtitle); { if still looks like sysvol then continue } if (ininfo.cvol=outinfo.cvol) and (outinfo.cvol=syvid) then begin if outnotthere(answer,false) then with ininfo, cfib do sition := 0; outsize := fleof; fpos := 0; swap := not unitable^[funit].uisfixed; { try to setup destination fib } if source then fixsrcfile(outname,fixedname,fkind) else fixcodefile(outname,fixedname); with obegin closeinfile; pathid := path; ftitle := filename; fwindow := addr(filename2); call(unitable^[funit].dam,cfib,funit,changename); goodio; showmove(cvol,cfile,cvol,outinfo.cfib.ftitle); inname := fixedname; closedir(ininfo); utinfo, cfib do begin setupfibforfile(fixedname,cfib,cpvol); if (funit>0) and unitable^[funit].uisfixed then begin useunit := false; cpvol := fvid; swap := false; end else useunit := unitnumber(cpvol); dstatus := dneeded; if useunit then done := true; end else badio(inoerror); { file exists & not removed } end; if done then closedir(outinfo); end; { do changename } if not done then repeat { do file move } { code files use copy, source file cvol := '' else cvol := cpvol; end; { unit number may not be known yet } if not source then begin outinfo.cfib.fkind := fkind; outinfo.cfib.feft := feft; end; outinfo.cfib.fstartaddress := fstartaddress; { cos must be translateable } { read source file } inmount(swap); write('Reading ....',chr(13)); if docopy then begin { do copy move } if bufsize>lefttoxfer then bufsize := lefttoxfer; with ininfo, cfib do begin call(unipy or translate ? } docopy := ininfo.cfib.feft=outinfo.cfib.feft; if docopy then begin { set destination file size } if outinfo.cfib.fpos=0 then outinfo.cfib.fpos := fleof else if (outinfo.cfib.fpos>0) and (outinfo.cfib.fpos<table^[funit].tm,addr(cfib),readbytes,buf^,bufsize,position); lefttoxfer := lefttoxfer - bufsize; end; end else begin { do translate move } anytomem(addr(ininfo.cfib),buf,bufsize); if ininfo.cfib.feof then lefttoxfer := 0;       then escape(0); if (strlen(cfile)=0) or (getwildcard(cfile)<>' ') then badio(ibadtitle); fkind := save_fkind; feft := save_feft; end; if swap then swap := samedevice(funit,ininfo.cfib.funit); ininfo.mounted := not swap;  : char; f2vol : vid; Tworkfid : fid; begin with userinfo^ do if symsaved and codesaved then if gotsym or gotcode then write('Workfile already saved',cteol) else write('No workfile to save',cteol) else begin  if outnotthere(answer,true) then begin { no file with same name } lockup; finitb(cfib,dumwindow,-3); if answer='O' then overcreate := overwritefile else overcreate := createfile; call(unitable^[funit].dam,cfib,funit,overcreate) try writeln(clearscr); symwassaved := false; codewassaved := false; Tworkfid := workfid; if strlen(Tworkfid)>0 then promptyorn('Save as '+Tworkfid,answer) else answer := 'N'; if answer<>'Y' then begin write('Save as what file ? ; fileopen := (ioresult=ord(inoerror)); lockdown; goodio; if (outsize>0) and (outsize>fpeof) then begin { try to stretch the file } fpos := outsize; call(unitable^[funit].dam,cfib,funit,stretchit); if out'); readln(Tworkfid); goodio; zapspaces(Tworkfid); if strlen(Tworkfid)=0 then badio(inoerror); end; if gotsym and not symsaved then begin if domove(symfid,Tworkfid,true) then begin symsaved := true; symwassaved := true; end size>fpeof then badio(inoroom); end; end else badio(inoerror); { file exists & not removed } fpos := 0; flastpos := -1; end; { open destination file } { write to the destination file } outmount(swap); write('Writing ....', else badio(inoerror); { move failed } end; if gotcode and not codesaved then begin if domove(codefid,Tworkfid,false) then begin codesaved := true; codewassaved := true; end else badio(inoerror); { move failed } end; chr(13)); if docopy then begin { do copy move } call(unitable^[funit].tm,addr(cfib),writebytes,buf^,bufsize,position); goodio; position := position + bufsize; end else begin { do translate move } memtoany(buf,addr(cfib)); if lefttoxworkfid := Tworkfid; if symwassaved then write('Source file saved '); if codewassaved then begin if symwassaved then write('& '); write('Code file saved '); end; recover begin saveesc := escapecode; printioerrmsg; if saveesc<>0 thefer=0 then position := fleof; end; if lefttoxfer=0 then begin { all done so close it now } closeoutfile(position,keepit); goodio; closedir(outinfo); done := true; showmove(ininfo.cvol,ininfo.cfile,cvol,cfile); end; end; { win escape(saveesc); end; end; { save files } end; { savework } (****************************************************************************) procedure newwork(showmsg : boolean; var answer : char); var f : fith outfib } until done; domove := true; release(lheap); heapinuse := false; recover begin lockup; saveio := ioresult; saveesc := escapecode; release(lheap); heapinuse := false; closeall(0); ioresult := sale of char; lvid : vid; lsegs : integer; lkind : filekind; ltitle : fid; begin answer := 'Y'; if not (symsaved and codesaved) then promptyorn('Throw away current workfile',answer); if answer='Y' then witveio; lockdown; printioerrmsg; escape(saveesc); end; end; { domove } (****************************************************************************) procedure savework; var symwassaved : boolean; codewassaved : boolean; answer h userinfo^ do begin lockup; ioresult := ord(inoerror); if scantitle(symfid,lvid,ltitle,lsegs,lkind) then if (lvid=syvid) and (ltitle='WORK.TEXT') then begin reset(f,'*WORK.TEXT'); if ioresult = ord(inoerror) then close(f,'pur     ); lockdown; end; end; end; { getwork } (****************************************************************************) procedure whatwork; begin with userinfo^ do begin if not(gotsym or gotcode) then write('No workfile') else nstring : string[255]; name : passtype; i, j : integer; begin setstrlen(inpass.pword,0); inpass.pbits := 0; write('password:attributes ? ',cteol); readln(instring); goodio; if instring=sh_exc then badio(inoerror); zapspaces(instri begin write('Workfile is '); if strlen(workfid) > 0 then write(workfid) else write('not named'); if not (symsaved and codesaved) then write(' (not saved)'); end; write(cteol); end; end; { whatwork } (***********************ng); {remove blanks and control characters} if strlen(instring)>0 then begin { get the password } j := beforestr(instring,1,1,':'); if (j=0) or (j>(passleng + 1)) then begin writeln('bad password',cteol); goto 2; end; inpass.pwordge'); end; if scantitle(codefid,lvid,ltitle,lsegs,lkind) then if (lvid=syvid) and (ltitle='WORK.CODE') then begin reset(f,'*WORK.CODE'); if ioresult = ord(inoerror) then close(f,'purge'); end; symsaved := true; codesaved := tru*****************************************************) procedure makepasslist(var f : fib; var passptr : anyptr; var count : integer); var passentries : passarray; current : passentryeltptr; prev : pase; gotsym := false; gotcode := false; setstrlen(symfid,0); setstrlen(codefid,0); setstrlen(workfid,0); if showmsg then writeln('Workfile cleared',cteol); lockdown; end;{ if yes with ... } end; { newwork } sentryeltptr; i : integer; begin prev := nil; count := 0; with f, unitable^[funit] do begin fwindow := addr(passentries); fpos := 0; fpeof := catlimit; passptr := nil; repeat call(dam,f,funit,catpassw(****************************************************************************) procedure getwork; var f : file of char; answer : char; Tworkfid, Tsymfid, Tcodefid : fid; begin newwork(false,answer); if answer='Y' then with userinfo^ do ords); goodio; for i := 1 to fpeof do begin count := count + 1; new(current); current^.link := nil; if passptr=nil then passptr := current; if prev<>nil then prev^.link := current; prev := current; current^.pelement.pbits := passe if not (gotsym or gotcode) then begin writeln(clearscr); showprompt('Get what file ? '); readln(Tworkfid); goodio; zapspaces(Tworkfid); if strlen(Tworkfid)>0 then begin lockup; fixsrcfile(Tworkfid,Tsymfid,textfilentries[i].pbits; current^.pelement.pword := passentries[i].pword; end; if fpeof=catlimit then fpos := fpos + fpeof; until fpeofnil do with list^.pelement do begin if (pword=src.pword) and (pbits<>0) thendefid := Tcodefid; end; if not (gotsym or gotcode) then write('No ') else begin workfid := Tworkfid; if gotsym then write('Source '); if gotsym and gotcode then write('and '); if gotcode then write('Code '); end; write('file loaded',cteol goto 1; list := list^.link; end; findpass := false; 1: end; { findpass } (****************************************************************************) procedure getpassdef(var inpass : passentry; opts : passarrayptr); label 1,2; var i      := str(instring,1,j - 1); j := j + 1; { skip : } { get the attributes } while j<=strlen(instring) do begin i := beforestr(instring,j,1,','); if i=0 then i := strlen(instring) + 1; name := str(instring,j,i - j); upc(name); { all(dam,cfib,funit,setpasswords); goodio; end; end; { putpass } (****************************************************************************) procedure access; var filename : fid; searchname : fid; dircatentry : catentry; passpuppercase the attribute } j := i + 1; if strlen(name)>0 then begin i := 1; while opts^[i].pbits<>0 do if name = opts^[i].pword then goto 1 else i := i + 1; writeln('bad attribute '''+name+'''',cteol); setstrlen(inpass.pword,tr : passentryeltptr; found : passentryeltptr; count : integer; lines : integer; option : char; answer : char; done : boolean; inpass : passentry; optsptr : passarrayptr; i0); goto 2; 1: inpass.pbits := ior(inpass.pbits,opts^[i].pbits); end; end; { get attributes } if inpass.pbits=0 then begin writeln('No attributes'); goto 2; end; end; 2: end; { getpassdef } (************************* : integer; begin writeln(clearscr); showprompt('Access codes for which file ? '); readln(filename); goodio; zapspaces(filename); if strlen(filename)>0 then with ininfo, cfib do begin setupfibforfile(filename,cfib,cpvol); { make***************************************************) function matchbits(var isubset,iset :integer):boolean; begin matchbits := iand(iset,isubset) = isubset; end; (****************************************************************************) procedure show sure that this operation is not performed on an HFS disc } { OR an SRM-UX unit - JWH 6/25/90 } if (unit_is_hfs(funit) or unit_is_srmux(funit)) then badio(ibadrequest); useunit := unitnumber(cpvol); dstatus := dneeded; if useunit then cpass(var entry:passentry; opts: passarrayptr); var i : integer; first : boolean; begin write(entry.pword,':'); first := true; i := 1; while opts^[i].pbits<>0 do begin if matchbits(opts^[i].pbits,entry.pbits) then begin if not fivol := '' else cvol := cpvol; if (funit=0) or unitnumber(fvid) then mountvolume('',ininfo); try mark(lheap); heapinuse := true; makepasslist(cfib,passptr,count); done := false; optsptr := addr(foptstring^); writeln(crst then write(','); first := false; write(opts^[i].pword); end; i := i + 1; end; writeln; end; { showpass } (****************************************************************************) function getpword(p :prompttype; var name learscr); repeat setupfibforfile(filename,cfib,cpvol); goodio; write(homechar,'Access: List, Make, Remove, Attributes, Quit ? ',cteol); read(keyboard,option); readcheck; upcchar(option); writeln(option); if option='L' then begin { Lis: passtype):boolean; var i : integer; begin write(p,' ? ',cteol); readln(name); goodio; if name=sh_exc then badio(inoerror); zapspaces(name); { remove spaces and control characters } getpword := strlen(name)>0; end; { getpword } (*t passwords } writeln(clearscr); found := passptr; lines := 2; while found<>nil do begin if found^.pelement.pbits<>0 then begin lines := lines + 1; if lines=screenheight - 5 then begin spacewait; writeln(c***************************************************************************) procedure putpass(var inpass:passentry; var f:fib); begin with ininfo, cfib, unitable^[funit] do begin fwindow := addr(inpass); fpos := 0; fpeof := 1; clearscr); writeln; lines := 3; end; showpass(found^.pelement,optsptr); end; found := found^.link; end; writeln(cfile,' has ',count:1,' passwords',cteol); option := 'q'; end; if option='M' then begin { Make password }      ss} (****************************************************************************) procedure bad; const blksize = 256; var filename : fid; buf : packed array [1..blksize] of char; badcount : integer; dispx : int+ 1; end; end { found bad sector } else escape(0); end; { found error } end; fgotoxy(output,dispx,dispy); if dispx<>0 then writeln; write(badcount:1,' bad sectors found.'); closeinfile; recover begin lockup; saveeger; dispy : integer; endblock : integer; i : integer; begin ininfo.fileopen := false; writeln(clearscr); showprompt('Bad sector scan of what directory ? '); readln(filename); goodio; zapspaces(filename); ifio := ioresult; saveesc := escapecode; closeinfile; ioresult := saveio; lockdown; printioerrmsg; if saveesc<>0 then escape(saveesc); end; end; end; end; { bad } (*********************************************************************** write('Make '); getpassdef(inpass,optsptr); found := passptr; if strlen(inpass.pword)>0 then begin if findpass(inpass,found) then begin promptyorn(inpass.pword+' exists ... replace it',answer); if answer='Y' then  strlen(filename)>0 then with ininfo, cfib do begin setupfibforfile(filename,cfib,cpvol); saveio := ioresult; with unitable^[funit] do begin try useunit := unitnumber(cpvol); dstatus := dontcare; if useunit then cvol := '' else begin putpass(inpass,cfib); found^.pelement.pbits := inpass.pbits; end; end else begin { add it to the list } putpass(inpass,cfib); count := count + 1; new(found); found^.link := passptr; found^cvol := cpvol; if ((funit=0) or unitnumber(fvid)) and (saveio<>ord(inodirectory)) then mountvolume('',ininfo); lockup; fbuffered := false; call(dam,cfib,funit,openvolume); fileopen := (ioresult=ord(inoerror)); lockdown; goodio; badcount :.pelement := inpass; passptr := found; end; end; option := 'q'; end; if option='A' then begin { list possible attributes } lines := 1; writeln(cteol); while optsptr^[lines].pbits<>0 do begin writeln(optsptr^[= 0; dispx := 0; dispy := 5; endblock := (fleof div blksize) - 1; fgotoxy(output,0,2); writeln('Scanning ',uvid,': from sector 0 to sector ',endblock:1,cteol); writeln('Scanning: ',cteol); writeln('Bad sectors: ',cteol); for i := 0 to elines].pword,cteol); lines := lines + 1; end; option := 'q'; end; if option='R' then begin { Remove password } if getpword('Remove password',inpass.pword) then begin found := passptr; if findpass(inpass,found) then begin ndblock do begin fgotoxy(output,9,3); {increased from 5. 12/23/88 - SFB} write(i:9,' '); { space is a message separation }{24jan83} {SFB} call(tm,addr(cfib),readbytes,buf,blksize,i*blksize); if ioresult <> ord(inoerror) then begin  found^.pelement.pbits := 0; count := count - 1; putpass(found^.pelement,cfib); end else writeln('Password not found',cteol); end; option := 'q'; end; if option='Q' then begin done := true; option := 'q'; writeln { found error } { 24jan83 allow other conditions besides zbadblock } if (ioresult = ord(zbadblock)) or (ioresult = ord(ztimeout)) or (ioresult = ord(znosuchblk)) or (ioresult = ord(znoblock)) then begin { found bad sector } (clearscr); end; if streaming and (option<>'q') then badcommand(option); until done; recover begin release(lheap); heapinuse := false; printioerrmsg; if escapecode<>0 then escape(escapecode); end; end; end; {acce badcount := badcount + 1; fgotoxy(output,dispx,dispy); write(i:9); {increased from 5. 12/23/88 - SFB} if dispx<39 then dispx := dispx + 9 {decreased from 42. 12/23/88 - SFB} else begin dispx := 0; dispy := dispy      *****) procedure krunch; var filename : fid; mounted : boolean; answer : char; begin try mounted := false; writeln(clearscr); showprompt('Crunch what directory ? '); readln(filename); goodio; zapspaces(filename); goodio; writeln('Directory ',cname,' made'); closedir(ininfo); end; end { make directory } else begin { zero directory } { allow existing directory } setupfibforfile(filename,cfib,cpvol); useunit := unitnumber(cpv); if strlen(filename)>0 then with ininfo, cfib do begin setupfibforfile(filename,cfib,cpvol); useunit := unitnumber(cpvol); if useunit then cvol := '' else cvol := cpvol; dstatus := dneeded; if (funit=0) or unitnumber(fol); if useunit then begin cvol := ''; dstatus := dontcare; end else begin cvol := cpvol; dstatus := dneeded; end; { make sure that this operation is not performed on an HFS disc } if unit_is_hfs(funit) then badio(ibadrequest); if not usevid) then mountvolume('',ininfo) else cvol := fvid; promptyorn('Crunch directory '+cvol,answer); if answer = 'Y' then begin writeln('Crunch of directory ',cvol,' in progress',cteol); writeln(' DO NOT DISTURB !!',cteol); callunit and (funit=0) then ioresult := ord(inounit); if (funit=0) or (ioresult<>ord(inoerror)) then begin saveio := ioresult; if saveio<>ord(inodirectory) then begin printioerrmsg; mountvolume('',ininfo); end; end; if (funit>0) and not unitnumbe(unitable^[funit].dam,cfib,funit,crunch); goodio; writeln('Crunch completed',cteol); end; end; recover printioerrmsg; end; { krunch } (****************************************************************************) procedure zero(MAKE : r(fvid) then begin { open directory to get defaults } opendir(filename,searchname,'',ininfo,dircatentry); if not diropen then escape(0); end; if diropen then begin closedir(ininfo); { directory does exist } if (strlen(searchname)>0) or boolean); var filename : fid; searchname : fid; dircatentry : catentry; answer : char; vsize : integer; begin { zero } ininfo.diropen := false; writeln(clearscr); if make then begin writeln(homechar,'Make d (cpsize<=0) then badio(ibadrequest); end else begin { no directory so setup } setstrlen(cname,0); cpsize := maxint; cextra1 := 0; end; unitable^[funit].ureportchange := false; vsize := ueovbytes(funit); unitable^[funit].urepirectory (valid only for HFS and SRM type units)'); write('Make what directory ? ') end else begin writeln(homechar,'Zero directory (NOT valid for HFS or SRM type units)'); write('Zero what volume ? '); end; readln(filename); goodortchange := true; if vsize0 then begin promptyorn('Destroy '+cname+':',answer); if answer<>'Y' then badio(inoerror); end else answer := 'Y'; if not streaming then begin write('Number of dirio; zapspaces(filename); if strlen(filename)>0 then with ininfo, cfib, dircatentry do begin try if make then begin { make directory } opendir(filename,searchname,'',ininfo,dircatentry); if not diropen then escape(0); if strleectory entries '); if cextra1>0 then write('(',cextra1:1,')'); write(' ? '); end; readnumber(cextra1); if not streaming then write('Number of bytes (',cpsize:1,') ? '); readnumber(cpsize); if cpsize=0 then badio(ibadvalue); if not streaming tn(searchname)=0 then badmessage('Directory already exists'); cname := searchname; promptyorn('Directory is '''+cname+''' correct',answer); if answer = 'Y' then begin fwindow := addr(dircatentry); call(unitable^[funit].dam,cfib,funit,makedirectoryhen write('New directory name? '); readln(cname); goodio; zapspaces(cname); if strlen(cname)=0 then badio(inoerror); if cname[strlen(cname)]=':' then setstrlen(cname,strlen(cname)-1); promptyorn(cname+': correct',answer); if answer = 'Y' then begin       (ioresult=ord(inoerror)); lockdown; goodio; closeoutfile(fpeof,keepit); goodio; writeln('File ',cvol,':',pathname,cfile,' made '); writeln('size is ',fpeof div 512:1,' blocks(512) or ',fpeof:1,' bytes'); end; recover begin if p>0 then begin if p>sizeof(filename1) then badio(ibadtitle) else filename1 := str(instring,1,p-1); if p>strlen(instring) then setstrlen(instring,0) else strdelete(instring,1,p); if getname2 then begin if (strlen(promptlockup; saveio := ioresult; saveesc := escapecode; closeoutfile(0,badclose); ioresult := saveio; lockdown; printioerrmsg; if saveesc <> 0 then escape(saveesc); end; end; { with } end; { make file } end; { make } (*****************2)>0) and (strlen(instring)=0) then begin write(prompt2,cteol); readln(instring); goodio; zapspaces(instring); end; if strlen(instring)>0 then begin p := strpos(',',instring); if p=0 then p := strlen(instring) + 1; if p>0 then setupfibforfile(filename,cfib,cpvol); fwindow := addr(dircatentry); call(unitable^[funit].dam,cfib,funit,makedirectory); goodio; writeln('Volume ',cname,' zeroed'); end; end; recover begin lockup; saveio := ior***********************************************************) procedure prefix(default:boolean); var dirname : fid; begin writeln(clearscr); if default then showprompt('Prefix to what directory ? ') else showprompt('Set unit to what direcesult; saveesc := escapecode; closedir(ininfo); ioresult := saveio; lockdown; printioerrmsg; if saveesc<> 0 then escape(saveesc); end; end; { with infib etc. } end; { zero } (*************************************tory ? '); readln(dirname); goodio; zapspaces(dirname); if strlen(dirname)>0 then with ininfo, cfib do begin lockup; try setupfibforfile(dirname,cfib,cpvol); if (funit=0) or unitnumber(fvid) then begin if default then be***************************************) procedure make; var filename : fid; answer : char; pathname : fid; begin outinfo.fileopen := false; outinfo.badclose := purgeit; write(clearscr); promptread('Make file or directory (gin if strlen(ftitle)>0 then badio(ibadtitle); dkvid := cpvol; ioresult := ord(inoerror); end else badmessage('Directory '+cpvol+' not online'); end else begin call(unitable^[funit].dam,cfib,funit,setunitprefix); if iorF/D) ? ',answer,'FD ',sh_exc); if answer=' ' then if streaming then badcommand(answer) else badio(inoerror); if answer='D' then zero(true) { 'make' a directory } else begin showprompt('Make what file ? '); readln(filename); goodio; esult<>ord(inoerror) then escape(0); if default then dkvid := unitable^[funit].uvid else writeln('Unit #',funit:0,' directory is ',unitable^[funit].uvid,cteol); end; lockdown; recover begin lockdown; printioerrmsg;  zapspaces(filename); if strlen(filename)>0 then with outinfo, cfib do begin try fstripname(filename,cpvol,pathname,cfile); setupfibforfile(filename,cfib,cpvol); useunit := unitnumber(cpvol); dstatus := dneeded; if useunit then cvol :end; end; { with } if default then writeln('Prefix is ',dkvid,':',cteol); end; { prefix } (****************************************************************************) procedure getfilenames(var instring : string255; var filename1 = '' else cvol := cpvol; if (funit=0) or unitnumber(fvid) then mountvolume('',outinfo) else cvol := fvid; if outnotthere(answer,false) then begin lockup; fstartaddress := 0; call(unitable^[funit].dam,cfib,funit,createfile); fileopen := : fid; var filename2 : fid; prompt2 : string80; getname2 : boolean); var p : integer; begin setstrlen(filename1,0); setstrlen(filename2,0); p := strpos(',',instring); if p=0 then p := strlen(instring) + 1;       begin if p>sizeof(filename2) then badio(ibadtitle) else filename2 := str(instring,1,p-1); if p>strlen(instring) then setstrlen(instring,0) else strdelete(instring,1,p); end; end; end; end; end; { getfilenames } (**********en badio(inotondir); if not samedevice(ininfo.cfib.funit,funit) then badio(ibadrequest); end; compatible(searchname,destname); if getwildcard(destname)='?' then wildcard := '?'; if wildcard<>' ' then writeln(clearscr); while nameptr<>nil do with n******************************************************************) procedure duplicate; var instring : string255; cprompt : prompttype; filename1 : fid; filename2 : fid; searchname : fid; destname : fid; dircatentrameptr^ do begin makenewname(searchname,destname,element,filename2); ftitle := element; answer := 'Y'; if wildcard = '?' then promptyorn(cprompt+ininfo.cvol+':'+ftitle,answer); if answer = 'Y' then begin outinfo.cfib.fty : catentry; nameptr : tidelementptr; lsegs : integer; lkind : filekind; wildcard : char; answer : char; purgeold : boolean; begin heapinuse := false; ininfo.diropen := false; outinfo.diitle := filename2; if outnotthere(answer,false) then begin fwindow := addr(outinfo.cfib); fpurgeoldlink := purgeold; call(unitable^[funit].dam,cfib,funit,duplicatelink); goodio; showmove(cvol,element,outinfo.cvoropen := false; outinfo.fileopen := false; cprompt := 'Dup_link '; writeln(clearscr); writeln(homechar,'Duplicate link (valid only for HFS and SRM type units)',cteol); promptread('Duplicate or Move ? (D/M) ',answer,'DM ',sh_exc); if answer=' 'l,filename2); end; end; if nameptr<>nil then nameptr := link; end; { while with nameptr } release(lheap); heapinuse := false; end; { with ininfo , cfib } closeall(0); recover begin lockup; saveio  then if streaming then badcommand(answer) else badio(inoerror); purgeold := answer='M'; if purgeold then cprompt := 'Move '; write(cprompt+'what file ? '); readln(instring); goodio; zapspaces(instring); while strlen(instring)>0 do  := ioresult; saveesc := escapecode; if heapinuse then release(lheap); heapinuse := false; closeall(0); ioresult := saveio; lockdown; printioerrmsg; if saveesc<>0 then escape(saveesc); s begin try getfilenames(instring,filename1,filename2,CPROMPT+'to what ? ',true); if not ((strlen(filename1)>0) and (strlen(filename2)>0)) then badio(inoerror); with ininfo, cfib do begin opendir(filename1,searchname,'',ininfo,detstrlen(instring,0); end; end; { while } end; { duplicate } (****************************************************************************) procedure change; var instring : string255; cprompt : prompttype; filename1 : fid; ircatentry); if not diropen then escape(0); if strlen(searchname)=0 then badio(inotondir); mark(lheap); heapinuse := true; wildcard := getwildcard(searchname); makenamelist(cfib,searchname,nameptr,false,false,true,lsegs); goodio; if nameptr=nil t filename2 : fid; searchname : fid; destname : fid; dircatentry : catentry; nameptr : tidelementptr; lsegs : integer; lkind : filekind; wildcard : char; answer : char; begin heapinuse hen begin if wildcard=' ' then badio(inofile); writeln('no files found',cteol); badio(inoerror); end; with outinfo, cfib do begin opendir(filename2,destname,'',outinfo,dircatentry); if not diropen then escape(0); if strlen(destname)=0 th := false; ininfo.diropen := false; outinfo.fileopen := false; cprompt := 'Change '; writeln(clearscr); showprompt(cprompt+'what file ? '); readln(instring); goodio; zapspaces(instring); while strlen(instring)>0 do begin try      le); mark(lheap); heapinuse := true; wildcard := getwildcard(searchname); makenamelist(cfib,searchname,nameptr,false,false,true,lsegs); goodio; if nameptr=nil then begin if wildcard = ' ' then badio(inofile); writeln('no filesxt; var listfile : text; dispfile : textptr; instring : string255; filename1 : fid; filename2 : fid; searchname : fid; dircatentry : catentry; nameptr : tidelementptr; count : integer; { line found'); badio(inoerror); end; compatible(searchname,filename2); if getwildcard(filename2)='?' then wildcard := '?'; if wildcard<>' ' then writeln(clearscr); while nameptr<>nil do with nameptr^ do begin makenewname(searchname,fil count } catentryptr : ^catentry; getname2 : boolean; listtofile : boolean; holes : boolean; order : boolean; blocks : boolean; wildcard : char; answer : char; blocksused : integer; holebl getfilenames(instring,filename1,filename2,CPROMPT+'to what ? ',true); if not ((strlen(filename1)>0) and (strlen(filename2)>0)) then badio(inoerror); with ininfo, cfib do begin if not scantitle(filename1,fvid,ftitle,lsegs,lkind) then ename2,element,destname); if element<>destname then {25jan83} begin ftitle := element; answer := 'Y'; if wildcard = '?' then promptyorn(cprompt+ininfo.cvol+':'+ftitle,answer); if answer = 'Y' then badio(ibadtitle); if strlen(ftitle)=0 then begin {change volume name} cpvol := fvid; useunit := unitnumber(cpvol); dstatus := dneeded; if useunit then cvol := '' else cvol := cpvol; funit := findvolume(fvid,true); if (funit=0) or uni begin outinfo.cfib := cfib; outinfo.cfib.ftitle := destname; outinfo.cvol := cvol; if outnotthere(answer,false) then begin fwindow := addr(destname); call(unitable^[funit].dam,cfib,funit,changename); goodio; shtnumber(fvid) then mountvolume('',ininfo) else cvol := fvid; if not scantitle(filename2,outinfo.cfib.fvid, outinfo.cfib.ftitle,lsegs,lkind) then badio(ibadtitle); if (strlen(outinfo.cfib.ftitle)<>0) or unitnumber(outinfo.cfib.fvid) owmove(cvol,element,cvol,destname); end; end; end { 25jan83} else showmove(cvol,element,cvol,element); { no change 25jan83} if nameptr<>nil then nameptr := link; end; { while with  then badio(ibadtitle); outinfo.cvol := outinfo.cfib.fvid; call(unitable^[funit].dam,outinfo.cvol,funit,setvolumename); goodio; writeln(cvol,':','':(vidleng-strlen(cvol)), ' ==> ',outinfo.cvol,':',cteol); end { change volume namenameptr } release(lheap); heapinuse := false; closedir(ininfo); {bugfix for FSDdt01111 11/28/88 SFB} end; { change file name(s) } end; { with ininfo , cfib } recover begin lockup; saveio := ioresult; } else begin { change file name(s) } { validate the new name } if (filename2[1]='*') or (filename2[1]='#') or (breakstr(filename2,1,':[')<>0) then badio(ibadtitle); opendir(filename1,searchname,'',ininfo,dircatentry); if not diropen saveesc := escapecode; if heapinuse then release(lheap); heapinuse := false; closeoutfile(0,outinfo.badclose); { outnotthere } closedir(ininfo); ioresult := saveio; lockdown; printioerrmsg;  then escape(0); if strlen(searchname)=0 then begin { may have SRM directory instead of file } opendir(filename1,searchname,'',ininfo,dircatentry); if not diropen then escape(0); end; if strlen(searchname)=0 then badio(ibadtit if saveesc<>0 then escape(saveesc); setstrlen(instring,0); end; end; { while } end; { change } (****************************************************************************) procedure listdir(extlist : boolean); type textptr = ^te     ock : integer; bighole : integer; totalholes : integer; filecount : integer; showcount : integer; my_count : integer; $IOCHECK ON$ {31JAN83 LOOKOUT FOR PRINTER TIMEOUTS} procedure showhole(temp : integer); begin  showcatheader(extlist,order,dircatentry,dispfile^,count,funit); while nameptr <> nil do with nameptr^ do begin catentryptr := addr(nameptr^.element); answer := 'Y'; if wildcard = '?' then begin count := count + 1;  if temp>0 then begin if extlist then begin count := count + 1; write(dispfile^,'< UNUSED > '); write(dispfile^,bytestoblocks(temp,dircatentry.cblocksize):16); writeln(dispfile^,bytestoblocks(holeblock,dircatentry.cblocksize):22);  promptyorn('List '+uvid+':'+catentryptr^.cname,answer); end; if (wildcard <> '?') or (answer = 'Y') then with catentryptr^ do begin blocksused := blocksused + cpsize; if holes and (cstart>=0) then begin if c end; if temp>bighole then bighole := temp; totalholes := totalholes + temp; end; end; $IOCHECK OFF$ {31JAN83 LOOKOUT FOR PRINTER TIMEOUTS} begin { listdir } ininfo.diropen := false; listtofile := false; if extlist start<>holeblock then showhole(cstart - holeblock); holeblock := cstart + cpsize; end; showcount := showcount + 1; showcatentry(extlist,catentryptr^,dispfile^,count,funit); end; nameptr := link; if (nameptr<>nil) and (then begin instring := 'List_ext ' ; end else begin instring := 'List '; end; writeln(clearscr); showprompt(instring+'what directory ? '); readln(instring); goodio; zapspaces(instring); while strlen(instring)>0 dnot listtofile) then if count>=screenheight-4 then begin spacewait; writeln(clearscr); showcatheader(extlist,order,dircatentry,dispfile^,count,funit); end; end; { while with } { show hole after last file } if holes then sho begin getfilenames(instring,filename1,filename2,'',true); if strlen(filename1)>0 then begin mark(lheap); heapinuse := true; try opendir(filename1,searchname,'',ininfo,dircatentry); if not ininfo.diropen then escape(0); oowhole(dircatentry.cpsize - holeblock - 1); {write summary info} count := count + 2 + (79 div screenwidth)*2; if not listtofile then if count>=screenheight-4 then begin spacewait; writeln(clearscr); showcatheader(extlist,order := ininfo.cfib.fpos<>0; blocks := ((searchname='') or (searchname='=')); holes := not order and blocks and (dircatentry.cstart>=0) and (dircatentry.cpsize>0); holeblock := dircatentry.cstart; totalholes := 0; blocksused := 0; showcount :rder,dircatentry,dispfile^,count,funit); end; if showcount=0 then writeln('...... file(s) not found ......'); $IOCHECK ON$ {31JAN83 LOOKOUT FOR PRINTER TIMEOUTS} write(dispfile^,'FILES shown=',showcount:1); with dircatentry do begin = 0; bighole := 0; wildcard := getwildcard(searchname); makenamelist(ininfo.cfib,searchname,nameptr,true,order,false,filecount); goodio; with ininfo, cfib, unitable^[funit] do begin if strlen(filename2)>0 then begin lockup; rewri write(dispfile^,' allocated=',filecount:1); if cextra1>0 then {mods for hfs "report unallocated" SFB} if not unit_is_hfs(funit) then {this unit is not an HFS so report unallocated old way SFB} write(dispfile^,' unallocated=',cexte(listfile,filename2); listtofile := (ioresult=ord(inoerror)); lockdown; goodio; dispfile := addr(listfile); end else dispfile := addr(output); if listtofile then writeln(ininfo.cvol,':',cteol) else writeln(clearscr); tra1-filecount:1) else {this is HFS, so cextra1=unallocated inodes, not total inodes SFB} write(dispfile^,' unallocated=',cextra1:1); writeln(dispfile^); if holes or (cextra2>=0) or blocks then begin write(dispfile^      : integer; begin { remove } ininfo.diropen := false; heapinuse := false; writeln(clearscr); showprompt('Remove what file ? '); readln(instring); goodio; zapspaces(instring); while strlen(instring)>0 do begin mark(lhecapecode; closedir(ininfo); ioresult := saveio; lockdown; printioerrmsg; if saveesc<>0 then escape(saveesc); setstrlen(instring,0); end; end; { while } end; { remove } (***************************************ap); heapinuse := true; try getfilenames(instring,filename1,filename2,'',false); if (strlen(filename1)>0) then begin { check if only fvid given } with ininfo, cfib do begin if not scantitle(filename1, fvid, ftitle, ls*************************************) procedure transfer(doformat:boolean); type fullname = string[vidleng+tidleng+1]; ipointer = ^integer; var tprompt : string[15]; instring : string255; filename1 : fid; filename2 : fid; ,'BLOCKS (',DIRCATENTRY.CBLOCKSIZE:1,' bytes)'); if blocks then write(dispfile^,' used=',bytestoblocks(blocksused,cblocksize):1); if cextra2>=0 then write(dispfile^,' unused=',bytestoblocks(cextra2,cblocksize):1) else if holes theegs, lkind) then badio(ibadtitle); if strlen(ftitle) = 0 then badio(ibadrequest); end; opendir(filename1,searchname,'',ininfo,dircatentry); if not ininfo.diropen then escape(0); if strlen(searchname)=0 then begin { may have SRM directon write(dispfile^,' unused=',bytestoblocks(totalholes,cblocksize):1); if holes then write(dispfile^,' largest space=',bytestoblocks(bighole,cblocksize):1); end; end; { with dircatentry } writeln(dispfile^); $IOCHECK OFF$ {31JAN8ry try opening parent directory} opendir(filename1,searchname,'',ininfo,dircatentry); if not ininfo.diropen then escape(0); if strlen(searchname)=0 then badio(ibadrequest); end; ininfo.cvol := dircatentry.cname; wildcard := getwildcard(sear3 LOOKOUT FOR PRINTER TIMEOUTS} if listtofile then close(listfile,'lock'); end; { with ininfo, cfib etc. } release(lheap); heapinuse := false; recover begin lockup; saveio := ioresult; saveesc := escapecode; release(lheap); heapinusechname); makenamelist(ininfo.cfib,searchname,nameptr,false,false,true,filecount); goodio; answer := 'N'; if nameptr<>nil then begin if wildcard<>' ' then begin writeln(clearscr); editnamelist(nameptr,'Remove ',wildcard); if namept := false; closedir(ininfo); if listtofile then close(listfile,'lock'); ioresult := saveio; lockdown; printioerrmsg; if (saveesc <> 0) and (saveesc<>-10) then escape(saveesc) {31jan83} else ioresult := ord(inoerror); setstrlen(instring,0);r<>nil then promptyorn('Proceed with remove',answer); end else answer := 'Y'; end; if answer='Y' then begin with ininfo, cfib, unitable^[funit] do while nameptr<>nil do with nameptr^ do begin ftitle := element; call(d end; end;{ if name to list } closedir(ininfo); end; { while instring .. } end; { listdir } (****************************************************************************) procedure remove; var instring : string255; filename1 am,cfib,funit,purgename); if ioresult<>ord(inofile) then begin { don't show missing files } goodio; writeln(cvol,':',element,' removed',cteol); end; nameptr := link; end; { with nameptr^ while with lfib ...} end else wr : fid; filename2 : fid; searchname : fid; dircatentry : catentry; nameptr : tidelementptr; getname2 : boolean; wildcard : char; answer : char; filecount : integer; lkind : filekind; lsegs iteln('No files removed',cteol); end;{ namestring <> nil } release(lheap); heapinuse := false; closedir(ininfo); recover begin lockup; release(lheap); heapinuse := false; saveio := ioresult; saveesc := es     searchname : fid; destname : fid; dircatentry : catentry; nameptr : tidelementptr; filemoved : boolean; done : boolean; swap : boolean; format : boolean; wildcard : char; answer : d; { write bdat funny } procedure permission2(sunit,dunit : integer; var answer: char); begin answer := 'Y'; if not format and unitable^[sunit].uisblkd {source is blocked device} and not unitable^[dunit].uisblkd {destination is uchar; i : integer; instate : integer; outstate : integer; segs : integer; buf : bigptr; position : integer; movesize : integer; bufsize : integer; lefttoxfer : integer; saveionblocked device} then if not streaming then begin writeln('Translate should be used for serial devices'); promptyorn('continue Filecopy',answer); end; end; { permission2 } procedure permission(var answer: char); var tempv : result : integer; saveesc : integer; lkind : filekind; dumwindow : windowp; outsize : integer; outfkind : filekind; outeft : shortint; outfstarta : integer; overcreate : damrequesttype; bdatoffsevid; {adjustedfkind generates "UX" (or the FKIND7 suffix) instead of "FKIND7" for the source file type iff suffixtable^[FKIND7] <> ''. It actually generates upc(suffix) for all fkinds >= FKIND7, if the suffix is non nil. SFB} functt : integer; { BDAT WORT #2 offset for funny sector } infunny,outfunny : boolean; { funny record present/not present } { BDAT WORT #3 create and writeout funny sector } { this is realy a cancer !! } pos : integer; {for "dion adjustedfkind(fk : filekind) : string255; {SFB} var tmp : string255; pos : integer; begin tmp:=''; if (fk < fkind7) or (suffixtable^[fk] = '') then strwrite(tmp,1,pos,fk) else begin strwrite(tmp,1,pos,suffixtabestroy EVERYTHING" message. SFB} procedure writebdatfunny; type twowords = record case boolean of true :(long : integer); false :(word1 : shortint; word2 : shortint); end; rec = record eofsector : integer; eofble^[fk]); upc(tmp); end; adjustedfkind := tmp; end; begin with ininfo do begin if strlen(cvol)=0 then tempv := cpvol else tempv := cvol; write('Can''t Translate ',tempv,':',cfile); {if strlen(cfile)>0 then writyte : integer; nrecs : integer; pad : array[0..60] of integer; end; var recword : twowords; i : integer; funny : rec; begin with ininfo.cfib do begin for i:=0 to 60 do funny.pad[i] := 0; eln(' (type ',cfib.fkind,')',cteol) SFB} if strlen(cfile)>0 then writeln(' (type ',adjustedfkind(cfib.fkind),')',cteol) {SFB} else writeln(' (type unit)',cteol); end; with outinfo do begin if strlen(cvol)=0 then tempv := cpvfunny.eofsector := fleof div 256; funny.eofbyte := fleof mod 256; recword.long := fstartaddress; recword.long := recword.word2 * 2; if recword.long<1 then recword.long := 1; { feb83 zero is realy 1 } funny.nrecs :=ol else tempv := cvol; write(' to ',tempv,':',cfile); {if strlen(cfile)>0 then writeln(' (type ',suffix(cfile),')',cteol) {SFB} if strlen(cfile)>0 then writeln(' (type ',adjustedfkind(suffix(cfile)),')',cteol) else w (outinfo.cfib.fpeof-256) div recword.long; if ((outinfo.cfib.fpeof-256) mod recword.long)>0 then funny.nrecs := funny.nrecs + 1; end; with outinfo, cfib do call(unitable^[funit].tm,addr(cfib),writebytes,funny,256,0); goodio; enriteln(' (type unit)',cteol); end; if streaming then escape(-1); promptyorn('Do Filecopy',answer); end; { permission } function has_related_hfs_unit(un:unitnum) : integer; {SFB} var i : integer; my_base_unum : integer; begin     eyboard } fbuffered := false; fkind := untypedfile; feft := efttable^[fkind]; call(unitable^[funit].dam,cfib,funit,openvolume); fileopen := (ioresult=ord(inoerror)); lockdown; { unlock the keyboard } goodiininfo, cfib do repeat case instate of 1: begin { open the file } inmount(swap); ftitle := cfile; if doformat then finitb(cfib,dumwindow,-3); pathid := path; lockup; call(unitable^[funit]o; outsize := fpeof; lefttoxfer := fpeof; outfkind := datafile; outeft := efttable^[outfkind]; outfstarta := fstartaddress; position := 0; searchname := ''; instate := 2; { ready to read } .dam,cfib,funit,openfile); fileopen := ioresult=ord(inoerror); lockdown; if ioresult=ord(inotondir) then begin { skip this file } writeln('Can''t copy/translate a directory'); done := true; filemoved := true; has_related_hfs_unit:=0; if h_unitable<>NIL then begin my_base_unum:=h_unitable^.tbl[un].base_unum; for i:=maxunit downto 1 do with h_unitable^.tbl[i] do if is_hfsunit and (base_unum=my_base_unum) then has_related_hfs_un wildcard := ' '; nameptr := nil; ftid := ''; end else begin { file -> x } opendir(filename1,searchname,' SOURCE',ininfo,dircatentry); if not diropen then escape(0); { BDAT WORT #4 can the funny recoit:=i; end; end; procedure endearly; begin done := true; filemoved := true; closeinfile; end; begin { transfer } if doformat then tprompt := 'Translate ' else tprompt := 'Filecopy '; writeln(clearscr); showprompt(tprompt+rd exist } if strlen(dircatentry.cinfo)>=4 then infunny := (str(dircatentry.cinfo,1,4)='LIF ') or (str(dircatentry.cinfo,1,4)='HFS ') ; if strlen(searchname)=0 then badio(inotondir); makenamelist(cfib,searchname,nameptr,false,false,'what file ? '); readln(instring); goodio; zapspaces(instring); while strlen(instring)>0 do begin getfilenames(instring,filename1,filename2,tprompt+'to what ? ',true); if (strlen(filename1)>0) and (strlen(filename2)>0) then true,segs); goodio; wildcard := getwildcard(searchname); if nameptr=nil then begin if wildcard=' ' then badio(inofile); writeln('no files found',cteol); badio(inoerror); end; end; cfile := ''; swap := begin with ininfo do begin diropen := false; fileopen := false; mounted := false; end; with outinfo do begin diropen := false; fileopen := false; mounted := false; badclose := purgeit; goodclose := keepit; end; outstate := 1; mark(lheap); not unitable^[funit].uisfixed; end; { with ininfo, cfib } bufsize := (memavail div 256) * 256 - 30 * 512; {save some for slop} if bufsize<512 then escape(-2); { not enough room } newwords(buf,bufsize div 2); { allocate buffer s heapinuse := true; newwords(dumwindow,1); { dummy window for file translate } try with ininfo, cfib do begin { OPEN THE INPUT DIRECTORY/VOLUME } setupfibforfile(filename1,cfib,cpvol); if strlen(ftitle)=0 then begin { volume -> x }pace } writeln(clearscr); repeat { find next input file } with ininfo do begin if nameptr<>nil then cfile := nameptr^.element; if wildcard='?' then promptyorn(tprompt+cvol+':'+cfile,answer) else answer := 'Y';  useunit := unitnumber(cpvol); dstatus := dwanted; if useunit then cvol := '' else cvol := cpvol; mounted := (funit>0) and not(unitnumber(fvid)); if mounted then cvol := fvid else inmount(true); lockup; { lock the k end; if answer='Y' then begin { try the transfer } filemoved := false; format := doformat; if ininfo.diropen then instate := 1; { open the file first } repeat { move the file } done := false; with       end else begin goodio; feof := false; feoln := false; instate := 2; flastpos := -1; fpos := 0; outsize := fpeof; { same size as input } outfkind := fkind; outeft := feswap; if strlen(ftitle)=0 then begin { setup for x->volume } fkind := outfkind; feft := outeft; dstatus := dontcare; { is the volume/device mounted already } if useunit then mounted := ((ioresult=ord(inoerft; outfstarta := fstartaddress; lefttoxfer := fleof; position := 0; linecount:=0; end; end; 2: begin { read the file } inmount(swap); write('Reading ....',chr(13)); if format thror)) or (ioresult=ord(inodirectory))) and ( not swap or not samedevice(funit,ininfo.cfib.funit)) else begin { volname given } if funit>0 then mounted := not samedevice(funit,ininfo.cfib.funit) elsen begin { formated transfer } anytomem(addr(cfib),buf,bufsize); if buf^[0]=chr(4) then format := false else begin done := true; if feof then lefttoxfer := 0; goodio; end; end else e mounted := false; end; if mounted and (ioresult=ord(inoerror)) then cvol := fvid; swap := not mounted and swap; outmount(swap); if swap then begin { is destination now on the source device ? } swap := samedevice(funi begin { unformated transfer } if bufsize>lefttoxfer then movesize := lefttoxfer else movesize := bufsize; call(unitable^[funit].tm,addr(cfib),readbytes, buf^,movesize,position); goodio; lefttoxfer := lefttoxfer - mot,ininfo.cfib.funit); ininfo.mounted := not swap; end; if format and unitable^[funit].uisblkd then badmessage('Can''t Translate to blocked volume'); { don't ask permission for blocked volume to volume } if (format<>doformavesize; done := true; end; if lefttoxfer = 0 then begin { close the input file } closeinfile; goodio; end; write(cteol); end; end; { case instate } until done; done := false; ift) and not (not ininfo.diropen and unitable^[funit].uisblkd) then permission(answer) else answer := 'Y'; if answer='Y' then begin { carry on } if (unitable^[funit].uisblkd and (strlen(cvol)>0)) or (has_related not filemoved then with outinfo, cfib do repeat case outstate of 1: begin { OPEN THE DESTINATION DIRECTORY } if not scantitle(filename2,fvid,ftitle,segs,lkind) then badio(ibadtitle); cpvol := fvid; cfile := ''; _hfs_unit(funit)<>0) then begin { have existing directory or HFS on another unit on same medium. SFB} if cvol='' then {then create a name. SFB} strwrite(cvol,1,pos,'#',funit:1,':'); promptyorn('Destroy EVERYTH if segs<>0 then begin { check size specification } segs := segs * 512; if (segs0) and not format then badio(inoroom); outsize := segs; end else if format then outsizING on volume '+cvol,answer); if answer<>'Y' then badio(inoerror); { can't rely on name for next mount call } cvol := ''; if not useunit then begin setstrlen(cpvol,0); strwrite(cpvol,1,i,'#',funit:1); e := 0; useunit := unitnumber(cpvol); if useunit then cvol := '' else cvol := cpvol; funit := findvolume(fvid,true); if funit>0 then { always true for unblocked units } swap := not unitable^[funit].uisfixed and  useunit := true; end; end; lockup; badclose := closeit; goodclose := closeit; fbuffered := false; call(unitable^[funit].dam,cfib,funit,openvolume); fileopen := ioresult=ord(inoerror); lockdown;       outstate := 3; { need to open the file } cvol := dircatentry.cname; end; { setup for x->file } compatible(searchname,destname); if getwildcard(destname)='?' then begin if wildcard<>'?' then with ininf else call(unitable^[funit].tm,addr(cfib),writebytes, buf^,movesize,position); goodio; position := position + movesize; end; done := true; if lefttoxfer=0 then begin { close the output file } o do begin { no ? in source so prompt now } promptyorn(tprompt+cvol+':'+cfile, answer); if answer='N' then endearly; end; wildcard := '?'; end; { check blocked vol to unblocked vol } permission2(ininfo.cf { BDAT WORT #7 adjust eof } if (feft=bdat) or (feft=bdat_500) then {fix bdat 500 file copy} if (bdatoffset=-256) then position := outsize else position := position + bdatoffset; closeoutfile(position,goodclose); goodio; if ini goodio; if fpeofvolume } ib.funit,funit,answer); if answer<>'Y' then badio(inoerror); end; { open the directory } 2: begin { write to the file } outmount(swap); write('Writing ....',chr(13)); if format then begin  else begin { setup for x->file } dstatus := dneeded; if not ininfo.diropen then begin { vol->file} if useunit then mounted := (ioresult=ord(inoerror)) and (not swap or not samedevice(funit,ininf { formated transfer } memtoany(buf,addr(cfib)); if lefttoxfer=0 then position := fleof; end else begin { unformated transfer } { BDAT WORT #6 watch out for funny sector } if (feft=bdat) or (feft=bdat_500) theno.cfib.funit)) else begin { volname given } if funit>0 then mounted := not samedevice(funit,ininfo.cfib.funit) else mounted := false; end; swap := not mounted and swap; end { vol->file } else  {fix bdat 500 file copy} begin if position=0 then begin { bdat at first sector } if not infunny and outfunny then begin { from ? to LIF/HFS } writebdatfunny; { invent a record } bdatoffset : begin { file->file } if useunit then mounted := (ioresult=ord(inoerror)) and (not swap or not samedevice(funit,ininfo.cfib.funit)) else mounted := funit>0; if not mounted then begin { mount then= 256; call(unitable^[funit].tm,addr(cfib),writebytes, buf^,movesize,position+bdatoffset); end else if infunny and not outfunny then begin { from LIF/HFS to ? } bdatoffset := -256; { skip 2 check for swapping } outmount(swap); swap := samedevice(funit,ininfo.cfib.funit); end else swap := false; end; { file->file } ininfo.mounted := not swap; outmount(swap); opendir(filename2,destname,' DESTINAT56 bytes } call(unitable^[funit].tm,addr(cfib),writebytes, buf^[256],movesize-256,position); end else begin { directory types are the same maybe } call(unitable^[funit].tm,addr(cfib),writebytes, ION',outinfo,dircatentry); if not diropen then escape(0); { BDAT WORT #5 must the funny record exist } if strlen(dircatentry.cinfo)>=4 then outfunny := (str(dircatentry.cinfo,1,4)='LIF ') or (str(dircatentry.cinfo,1,4)='HFS ');buf^,movesize,position); bdatoffset := 0; end; end else { bdat and not at first sector } call(unitable^[funit].tm,addr(cfib),writebytes, buf^,movesize,position+bdatoffset); end { end BDAT WORT #6 }      nfo.cvol='' then ininfo.cvol := ininfo.cpvol; if cvol='' then cvol := cpvol; showmove(ininfo.cvol,ininfo.cfile,cvol,cfile); filemoved := true; if diropen then outstate := 3; end; end; { write to the file } 3: begdio; end; fpos :=0; flastpos := -1; outstate := 2; end; end; end else endearly; end; end; { case outstate } until done; until filemoved; end; if nameptr<>nil then nameptr := nameptrin { open the file } makenewname(searchname,destname,nameptr^.element,ftitle); cfile := ftitle; pathid := path; { fix the pathid } fkind := outfkind; feft := outeft; fpos := outsize^.link; until nameptr=nil; release(lheap); heapinuse := false; closeall(position); recover begin lockup; release(lheap); heapinuse := false; saveioresult := ioresult; saveesc := escapecode; closeall(position); ; fstartaddress := outfstarta; if (format<>doformat) then if (suffix(cfile)<>fkind) and (destname<>'$') and (destname<>'=') and (destname<>'?') then permission(answer) else answer := 'Y'; if answer='Y ioresult := saveioresult; lockdown; printioerrmsg; if saveesc<>0 then escape(saveesc); setstrlen(instring,0); end; end; end; end; { transfer } (****************************************************************************) ' then begin outmount(swap); if not outnotthere(answer,true) then endearly else begin { CONTINUE THE TRANSFER } if format then begin finitb(cfib,dumwindow,-3); fkind := suffix(ftitle); { set destinatiprocedure volumes; label 1; var un : unitnum; col : shortint; row : shortint; base : integer; sym : string[3]; done : boolean; begin done := false; base := 1; repeat writeln(clearscr); writeln('Volumes on-line:'); on fkind } feft := efttable^[fkind]; end; { BDAT WORT #8 adjust the file size } if (feft=bdat) or (feft=bdat_500) then {fix bdat 500 file copy} begin if not infunny and outfunny and (fpos>0) then fpos := fpos + 25 col := 0; row := 2; for un := base to maxunit do with unitable^[un] do begin call(dam, uvid, un, getvolumename); if (ioresult=ord(inoerror)) and (strlen(uvid) > 0) then begin fgotoxy(output,col,row); if uvid = syvid 6; if infunny and not outfunny then begin fpos := (ipointer(buf)^)*256+ipointer(addr(buf^,4))^; outsize := fpos; end; end; lockup; if answer='O' then overcreate := overwritefile else overcreate := c then sym := ' * ' else if uisblkd then sym := ' # ' else sym := ' '; write(un:3, sym, uvid, ':'); row := row + 1; if row = (screenheight - 4) then begin row := 2; col := col + 26; if ((col + 24) > screenwidth)reatefile; call(unitable^[funit].dam,cfib,funit,overcreate); fileopen := ioresult=ord(inoerror); lockdown; if ioresult=ord(ibadtitle) then begin writeln('Bad filename ',cfile); endearly; end else begin good and (un < maxunit) then begin fgotoxy(output,0,screenheight - 4); spacewait; base := un + 1; goto 1; end; end; end; end; done := true; 1:; until done; if col<>0 then row := screenheight - 4io; if (outsize>0) and (outsize>fpeof) then begin { try to stretch the file } fpos := outsize; call(unitable^[funit].dam,cfib,funit,stretchit); if outsize>fpeof then ioresult := ord(inoroom); goo; fgotoxy(output,0,row); write('Prefix is - ', dkvid, ':'); end; { volumes } (****************************************************************************) procedure fixuserinfo; var lvid : vid; lsegs : integer; lkind      *********************************************************************) function octalmode(decmode: integer): integer; { octalmode converts a decimal number to a 3-digit octal number } begin octalmode := (decmode mod 8) + ((decmode div 8) mod 8) cat_info : h_catpasswd_ids; nameptr : tidelementptr; dircatentry : catentry; searchname : fid; segs : integer; old_uid : ushort; old_gid : ushort; old_per : ushort; new_uid : ushort; new_g * 10 + ((decmode div 64) mod 8) *100; end; {octalmode} (****************************************************************************) function destructive ( old_uid : ushort; new_uid : ushort) : boolean; const confirm = 'Are you id : ushort; new_per : ushort; cmd : string[6]; save_pathid : integer; change_root : boolean; procedure do_umask; { Note - we don't maintain a umask value for SRM-UX units. } { This is for true hfs units only } begin  : filekind; ltitle : fid; begin with userinfo^ do begin if scantitle(symfid,lvid,ltitle,lsegs,lkind) then { do nothing }; symsaved := (ltitle <> 'WORK.TEXT') or not gotsym; if scantitle(codefid,lvid,ltitle,lsegs,lkinSURE you want to proceed? (Y/N) '; var answer : char; begin destructive := false; if new_uid <> old_uid then begin { ownership is changing issue a major warning } writeln; writeln ('The OWNERSHIP of the file/directory is cd) then { do nothing }; codesaved := (ltitle <> 'WORK.CODE') or not gotcode; end; end; { fixuserinfo } (****************************************************************************) procedure promptforchar(pl : prompttype; var chhanging.'); writeln ('You will lose the right to change any attributes'); writeln ('of the file/directory in the future. '); writeln ('You may lose ALL access to the file/directory '); writeln ('depending on the permissions, you ha : char); begin showprompt(pl); read(keyboard,ch); readcheck; if ch=sh_exc then ch := ' '; if ch=' ' then write(clearscr) else begin write(homechar,cteol); upcchar(ch); end; end; { promptforchar } (*ve set. '); writeln; promptread ( confirm, answer, 'YN', 'N' ); writeln; if answer = 'Y' then destructive := false else destructive := true; end; end ; { function destructive } procedure hfs_access; { Th***************************************************************************) procedure read_ushort(var ushort_num : ushort); var i : integer; ti : ushort; instring : string[20]; begin readln(instring); goodio; i := changestr(instrine error conditions that this routine expects and can handle gracefully are : inofile : file does not exist ifilenotdir : when a path component is not a directory inopermission : when access permissions fail on the path or file All other erg,1,-1,' ',''); { squash blanks } if instring=sh_exc then badio(inoerror); if strlen(instring)>0 then try begin ti := 0; for i:=1 to strlen(instring) do if (instring[i]<'0') or (instring[i]>'9') then badio(ibadvalue) else ti := ti rors are unexpected and can not be gracefully handled. } const max_uid = 65535; max_gid = 65535; max_mode = 511; var filename : fid; count : integer; lines : integer; option : char; answer : char; wi* 10 + (ord(instring[i]) - ord('0')); $range on$ ushort_num := ti; $range off$ end; recover if (escapecode = -4) or (escapecode = -8) then badio(ibadvalue) else escape(escapecode) else badio(inoerror); end; { read_ushort} (ldcard : char; done : boolean; quit : boolean; uid : ushort; gid : ushort; mode : string[5]; imode : ushort; info : h_setpasswd_entry; open_info : h_setpasswd_entry;      writeln (clearscr); showprompt ('For which unit ? '); readln (filename); zapspaces(filename); if strlen(filename) = 0 then begin release(lheap); heapinuse := false; escape(0); end; write ('Enter new umask number '); readln (ame); if strlen(filename) = 0 then badio(inoerror); end; mark (lheap); heapinuse := TRUE; open_info.new_value := 0; open_info.command := hfs_open; case option of 'O' : begin write ('Enter new owner number '); mode); goodio; if mode <> '' then begin try imode := utloctal (mode); if (imode > max_mode) then escape (-8); recover begin if (escapecode = -4) or (escapecode = -8) then begin badmessage ('New umask not in range read_ushort(uid); info.new_value := uid; info.command := hfs_chown; cmd := ' owner'; end; 'G' : begin write ('Enter new group number '); read_ushort(gid); info.new_value := gid; info.command := hfs_chgrp; cmd := ' group';  0 - 0777 octal'); end; end; info.new_value := imode; info.command := hfs_umask; cmd := 'umask '; {doing the action} with ininfo, cfib do begin setupfibforfile(filename,cfib,cpvol); fwindow := addr(info);  end; 'M' : begin write ('Enter new mode '); readln (mode); goodio; if mode = '' then badio(inoerror); try imode := utloctal (mode); if (imode > max_mode) then escape(-8); recover begin if (escapecode = -4) or (e fpos := 0; fpeof := 1; if unit_is_hfs(funit) then begin {check if volume name} if ftitle <> '' then badio(ibadrequest); call(unitable^[funit].dam, cfib, funit, setpasswords); goodio; end else badio(ibadrequest)scapecode = -8) then begin badmessage ('New mode not in range 0 - 0777 octal'); end; end; info.new_value := imode; info.command := hfs_chmod; cmd := ' mode'; end; 'U' : begin do_umask; badio(inoerror); end;; end; end else {no mode given indicates to show the umask of filename} with ininfo, cfib do begin setupfibforfile(filename,cfib,cpvol); fwindow := addr(cat_info); fpos := 0; fpeof := 1; if unit_is_hfs(funit) then begin { 'Q' : begin badio(inoerror); end; otherwise begin if option <> ' ' then if streaming then badcommand (option); badio(inoerror); end; end ; { option case } { part 2 : set up the filename(s) now that tcheck if volume name} if ftitle <> '' then badio(ibadrequest); call(unitable^[funit].dam, cfib,funit, catpasswords); goodio; writeln('Umask is ', octalmode(cat_info.cat_umask):3); end else badio(ibadrequest); end; enhe info is in } with ininfo, cfib do begin change_root := false; diropen := false; { working on a file not a unit } opendir (filename, searchname, '', ininfo, dircatentry); if not diropen then escape(0); { Changed; {do_umask} begin writeln (clearscr); repeat try { part 1 : get user inputs before doing any work } {showprompt ('HFS Access: Owner, Group, Mode, Umask, Quit '); read (keyboard,option); readcheck; upcchar (option)d for SRM-UX : } if ((str ( dircatentry.cinfo, 1, 4 ) <> 'HFS ' ) and ( str ( dircatentry.cinfo, 1, 6 ) <> 'SRM/UX' )) then begin badio(ibadrequest); end; if strlen (searchname) = 0 then { filename is a directory }; writeln;} promptforchar ('HFS Access: Owner, Group, Mode, Umask, Quit ', option); if option in ['G', 'M', 'O'] then begin writeln (clearscr); showprompt ('For which file ? '); readln (filename); goodio; zapspaces(filen begin save_pathid := pathid; {try open parent directory} opendir(filename,searchname,'',ininfo,dircatentry); if not ininfo.diropen then escape(0); if save_pathid = pathid then { try to change the id of '/' } change_root :     s); goodio; { now make the change for the file } fwindow := addr(info); fpos := 0; fpeof := 1; call (dam, cfib, funit, setpasswords); goodio; writeln (cvol+':'+nameptr^.element+cmd + ' changed if screenwidth<80 then promptforchar(sprompt2+filerid+']',ch) else promptforchar(lprompt2+filerid+']',ch); end; writeln; case ch of 'A': access; 'B': bad; 'C': change; { change name } 'D': duplicate; { duplic'); nameptr := nameptr^.link end { not SRM-UX unit } else begin { Try to do it with one call } pathid := save_pathid; ftitle := nameptr^.element; fpos := 0; fpeof := 1; fwindow := addr(info); { writeln('from the ate link } 'E': listdir(true); 'F': transfer(false); { file copy } 'G': getwork; 'H': hfs_access; 'K': krunch; 'L': listdir(false); 'M': make; { make file/directory } 'N': newwork(true,ch); 'P': prefix(true); { default director= true; end; save_pathid := pathid; ininfo.cvol := dircatentry.cname; wildcard := getwildcard (searchname); if change_root then begin new(nameptr); nameptr^.element := ''; nameptr^.link := NIL; end else FILER, the info fields contain : '); writeln('command : ',info.command); writeln('new value : ',info.new_value); } call (dam, cfib, funit, setpasswords); goodio; writeln (cvol+':'+nameptr^.element+cmd + ' changed'); nameptr := nameptr^.li begin makenamelist (cfib, searchname, nameptr, false, false, true, segs); goodio; if nameptr = NIL then badmessage('No files changed'); end; cfile := ''; end; { with ininfo, cfib } { Part 3: loop over the non-emptnk; end; end; { with } end; {while} end {answer = 'Y'} else writeln('No files changed'); release (lheap); heapinuse := false; closedir (ininfo); recover begin release(lheap); heapinuse := false; priny filename list doing the action } { Notes: fpeof is the number of items in the list pointed to by fwindow. fpos is always zero for the *password dam calls. } answer := 'N'; if wildcard <> ' ' then begin writeln(clearsctioerrmsg; if escapecode<>0 then escape(escapecode); end; until option = 'Q'; end; {hfs_access} (****************************************************************************) begin {commandlevel} if kbdtype = itfkbd then r); editnamelist (nameptr,'Change'+cmd+' on ', wildcard); if nameptr <> nil then promptyorn ('Proceed with change of'+cmd, answer); end else answer := 'Y'; if answer = 'Y' then begin if option = 'O' then  { 3.0 ITF fix 4/6/84 } esckey:='esc' { 3.0 ITF fix 4/6/84 } else { 3.0 ITF fix 4/6/84 } esckey:='sh_exc'; { 3.0 ITF fix 4/6/84 } if ( destructive ( paws_uid, uid )) then begin ioresult := ord (inoerror); escape (0); end ; while ( nameptr <> NIL) do begin { use setpassword open call to set up the fib } with ininfo, cfib, unitable^[fun fixuserinfo; fixlock; with ininfo do begin diropen := false; fileopen := false; end; with outinfo do begin diropen := false; fileopen := false; end; heapinuse := false; ioresult := ord(inoerror); ordefault := 'R'; { overwrite/reit] do begin if not unit_is_srmux(funit) then begin pathid := save_pathid; ftitle := nameptr^.element; fwindow := addr(open_info); fpos := 0; fpeof := 1; call (dam, cfib, funit, setpasswordplace default } with syscom^.crtinfo do begin screenwidth:=width; screenheight:=height; end; repeat try check; if screenwidth<80 then promptforchar(sprompt1,ch) else promptforchar(lprompt1,ch); if ch = '?' then begin     y } 'Q': ; 'R': remove; 'S': savework; 'U': prefix(false); { unit directory } 'V': volumes; 'W': whatwork; 'T': transfer(true); { translate } 'Z': zero(false); { zero a directory } otherwise if (ch<>' ') and (ch<>'?') then if  s3:stringarg):integer; src function breakstr(s1:stringarg; src c :integer; src s2:stringarg):integer; src function spanstr(s1:stringarg; src c :integer; src streaming then badcommand(ch); end; { case } fixlock; recover begin lockup; if heapinuse then release(lheap); heapinuse := false; saveio := ioresult; saveesc := escapecode; closeinf s2:stringarg):integer; src src function utloctal(s:stringarg): integer; src src end; * * UTLOCTAL added 3/30/87 by jws -- removed dependecy on REALS library * def matchstr_matchstr matchstr_matchstr equ * rts afunc eqile; closeoutfile(0,outinfo.badclose); closedir(ininfo); closedir(outinfo); ioresult :=saveio; if (saveesc<>0) and (saveesc<>-10) then ioresult := ord(inoerror); lockdown; printioerrmsg; fixlock; ifu 26 ams1 equ 24 as1 equ 20 ac equ 16 an equ 12 as2 equ 8 aargs equ 18 def matchstr_afterstr dc.w 0 matchstr_afterstr equ * link a6,#0 clr.l afunc(a6) func:=0 movea.l as1(a6),a0 saveesc<>0 then escape(saveesc) else ch := ' '; end; until ch = 'Q'; end {commandlevel} ; (****************************************************************************) begin writeln(clearscr); writeln; writeln; writeln; writeln; writel a0:=^s1 moveq #0,d0 move.b (a0),d0 d0:=strlen(s1) move.l an(a6),d2 if n>=0 blt.s after1 then * * count * move.l ac(a6),d3 d3:=c ble.s aret check cursor<=0 movea.l as2(a6),a1 a1:=^s1 moveq #0,d1 move.n('Copyright Hewlett-Packard Company, 1982,1991'); writeln(' All rights are reserved.'); writeln; writeln; commandlevel; end. b (a1)+,d1 d1:=strlen(s2) beq.s after0 bsr.s scan agood move.l d3,afunc(a6) bra.s aret * * count but no string * after0 add.l d2,d3 c:=c+n sub.l d3,d0 addq.l #1,d0 c :: len(s1)+1 bne agood bra aret * * match pack * nosyms sprint mname matchstr src module matchstr; src export src src type src stringarg=string[255]; src ttable =packed array[0..0] of 0..255; src src function afterstr(var s1:string; src  else * no count given * after1 movea.l as2(a6),a1 moveq #0,d1 move.b (a1)+,d1 bne.s after2 * * no count no string * addq.l #1,d0 func:=d0+1 move.l d0,afunc(a6) aret unlk a6 end movea.l (sp)+,a0 add c :integer; src n :integer; src s2:stringarg):integer; src function beforestr(var s1:string; src c :integer; src n :integera.w #aargs,sp jmp (a0) * * no count with string * after2 moveq #1,d2 count 1 move.l ac(a6),d3 ble aret cursor out of range? bsr.s scan beq aret must match at least once after3 move.l d3,afunc(a6) moveq #1,d2 reset cou; src s2:stringarg):integer; src function changestr(var s1:string; src c :integer; src n :integer; src s2:stringarg; src nt bsr.s scan bne after3 bra aret * scan equ * subq.l #1,d2 pre decriment count * scan1 movem.l d0-d2/a0-a1,-(sp) save for next call bsr scanloop movem.l (sp)+,d0-d2/a0-a1 beq.s scanx dbra d2,scan1 scanx rts scanloo     string * moveq #1,d0 func:=1 move.l d0,afunc(a6) bra aret * * no count with string * before2 moveq #1,d2 count 1 move.l ac(a6),d3 ble aret cursor out of range? bsr scan beq aret must match at least once before bra chgncnt1 * no count no s2 chgnil1 movea.l ms3(a6),a2 tst.b (a2) beq.s chgnil2 * no count only s3 * replace rest of s1 with s3 move.b d4,(a0) chop s1 to cursor subq.b #1,(a0) bra chgzcnt add s3 * * no count no s3 move.l d3,afunc(a6) sub.l d1,afunc(a6) move to front of match moveq #1,d2 reset count bsr scan bne before3 bra aret mf equ 30 ms1m equ 28 ms1 equ 24 mc equ 20 mk equ 16 ms2 equ trings * delete remainder of s1 chgnil2 move.b d4,(a0) set s1 length subq.b #1,(a0) move.l d4,mf(a6) set func value bra chgret * have count no s2 * replace count bytes with s3 chgcnil1 sub.l d5,d0 d0 is #bytes after deletp equ * sub.l d3,d0 addq.l #1,d0 blt sfexit pos in range ? sub d1,d0 is str2 longer than blt sfexit remaining str1 ? tst.w d1 beq.s ssexit2 str2 is null so match movea.l a0,a2 save str1 ptr adda.w d3,a0 st 12 ms3 equ 8 mr equ 22 def matchstr_changestr dc.w 0 matchstr_changestr equ * link a6,#0 clr.l mf(a6) function result 0 move.l mc(a6),d4 cursor ble chgret movea.l ms1(a6),a0 moveq #0,d0 move.b (a0art source compare move.b (a1)+,d6 first character subq #2,d1 scl1 cmp.b (a0)+,d6 scl2 dbeq d0,scl1 bne.s sfexit found it ? movea.l a0,a3 temp str1 movea.l a1,a4 temp str2 move.w d1,d5 remaining str2 bytes blt.s ),d0 sub.l d4,d0 addq.l #1,d0 blt chgret cursor in range ? move.l mk(a6),d5 counter beq chgzcnt ble chgncnt * have count value movea.l ms2(a6),a1 tst.b (a1) beq chgcnil1 * have count and s2 and maybe s3  ssexit str2 is 1 char scl3 cmpm.b (a3)+,(a4)+ dbne d5,scl3 bne scl2 ssexit move.l a3,d3 sub.l a2,d3 rts ssexit2 move.l d3,d3 set condition code rts sfexit moveq #0,d3 cursor to zero rts * def matchstr_beforestr dc.w * replace the next n occurences of s2 with s3 bra.s chgl2 chgl1 movem.l d5,-(sp) save count bsr chgflds movem.l (sp)+,d5 get count move.l d4,mf(a6) set func beq chgret chgl2 dbra d5,chgl1 bra chgret *  0 matchstr_beforestr equ * link a6,#0 clr.l afunc(a6) func:=0 movea.l as1(a6),a0 a0:=^s1 moveq #0,d0 move.b (a0),d0 d0:=strlen(s1) move.l an(a6),d2 if n>=0 blt.s before1 then * * count * move.l ac(a6),d3 count but no s2 * replace next count chars with s3 moveq #0,d0 move.b (a0),d0 move.l d0,d3 final length of s1 sub.l d5,d3 movea.l ms3(a6),a2 moveq #0,d2 move.b (a2),d2 add.l d2,d3 blt chgret count is too big * co d3:=c ble aret check cursor<=0 movea.l as2(a6),a1 a1:=^s1 moveq #0,d1 move.b (a1)+,d1 d1:=strlen(s2) beq.s before0 bsr scan beq.s bgood sub.l d1,d3 move to front of match bgood move.l d3,afunc(a6) bra unt is zero * insert s3 at cursor nilstr dc.w 0 * make ms2 a dummy nilstring chgzcnt move.l #nilstr,ms2(a6) bsr.s chgflds move.l d4,mf(a6) bra chgret * * no count * chgncnt movea.l ms2(a6),a1 tst.b (a1) beq.s  aret * * count but no string * before0 sub.l d2,d3 c:=c-n ble aret c :: 0 bra bgood * else * no count given * before1 movea.l as2(a6),a1 moveq #0,d1 move.b (a1)+,d1 bne.s before2 * * no count no  chgnil1 * no count but has s2 might have s3 * replace all occurences of s2 with s3 bsr.s chgflds move.l d4,mf(a6) beq chgret must change at least one chgncnt1 bsr.s chgflds move.l d4,mf(a6) set func value beq chgret       e blt chgret movea.l ms3(a6),a2 addr and size of s3 moveq #0,d2 move.b (a2)+,d2 moveq #0,d3 move.b (a0),d3 will it fit sub d5,d3 add d2,d3 final size of s1 cmp.b ms1m(a6),d3 bhi chgret move.l d5,d7 apparent size osuba.w d7,a4 subq.w #1,d0 chgdel1 move.b (a3)+,(a4)+ dbra d0,chgdel1 bra chgcpy1 chgins equ * movea.l a0,a3 bra chgf1 bf equ 20 bs1 equ 16 bc equ 12 bs2 equ 8 bargs equ 12 def matchstf s2 adda d4,a0 cursor addr lea 0(a0,d5.w),a3 after delete bsr chgf1 do it move.l d4,mf(a6) bra chgret chgbad moveq #0,d4 cursor to zero rts * * do one change * chgflds movea.l ms1(a6),a0 source string moveq r_breakstr dc.w 0 matchstr_breakstr equ * link a6,#0 clr.l bf(a6) set func to 0 move.l bc(a6),d4 cursor pos ble.s bsret movea.l bs1(a6),a0 movea.l a0,a4 save addr of s1 moveq #0,d0 move.b (a0),d0 length #0,d0 move.b (a0),d0 s length move.l d0,d3 final length of s sub.l d4,d0 addq.l #1,d0 blt chgbad pos in range ? movea.l ms2(a6),a1 old string moveq #0,d1 move.b (a1)+,d1 old lenght move.l d1,d7 save it for lats1 beq.s bsret sub.l d4,d0 blt.s bsret movea.l bs2(a6),a1 list addr moveq #0,d1 move.b (a1)+,d1 list length beq.s bsret adda.l d4,a0 start scan subq.w #1,d1 bloop0 move.b (a0)+,d2 char to test movea.l a1,a2 cer movea.l ms3(a6),a2 new string moveq #0,d2 move.b (a2)+,d2 new length sub d1,d3 add d2,d3 cmp.b ms1m(a6),d3 will it all fit ? bhi chgbad adda.w d4,a0 start source compare tst.b d1 beq chgins opy list addr move.w d1,d3 copy list length bloop1 cmp.b (a2)+,d2 dbeq d3,bloop1 beq.s bsxit dbra d0,bloop0 bra.s bsret bsxit suba.l a4,a0 calc func value subq.l #1,a0 move.l a0,bf(a6) bsret unlk a6 movea.l (sp)+,a0  0 length so match sub d1,d0 is old longer than blt chgbad remaining source ? move.b (a1)+,d6 first character subq #2,d1 chg1 cmp.b (a0)+,d6 chg2 dbeq d0,chg1 bne.s chgret found it ? movea.l a0,a3 temp sourc adda.w #bargs,sp jmp (a0) def matchstr_spanstr dc.w 0 matchstr_spanstr equ * link a6,#0 clr.l bf(a6) zero function value move.l bc(a6),d4 cursor position ble.s bsret movea.l bs1(a6),a0 string addr movea.l ae movea.l a1,a4 temp old move.w d1,d5 remaining old bytes blt.s chgf0 old is 1 char chg3 cmpm.b (a3)+,(a4)+ dbne d5,chg3 bne chg2 chgf0 subq.l #1,a0 chgf1 movea.l ms1(a6),a4 string s move.b d3,(a4) tst.w d0 beq0,a4 moveq #0,d0 move.b (a0),d0 string length beq.s bsret sub.l d4,d0 blt.s bsret movea.l bs2(a6),a1 list addr moveq #0,d1 move.b (a1)+,d1 list length beq.s bsret adda.l d4,a0 start scan subq.w #1,d1 sloo chgcpy1 sub.w d2,d7 beq.s chgcpy1 bgt.s chgsml * new string is greater than old lea 1(a4,d3.w),a4 end s + 1 lea 0(a4,d7.w),a3 source subq.w #1,d0 count chgins1 move.b -(a3),-(a4) dbra d0,chgins1 bra.s chgcpy1 chgp0 move.b (a0)+,d2 movea.l a1,a2 copy list addr move.l d1,d3 copy list length sloop1 cmp.b (a2)+,d2 dbeq d3,sloop1 bne bsxit dbra d0,sloop0 bra bsxit ********************************************************************* * *cpy move.b (a2)+,(a0)+ chgcpy1 dbra d2,chgcpy suba.l ms1(a6),a0 move.l a0,d4 new cursor value rts chgret unlk a6 movea.l (sp)+,a0 adda.w #mr,sp jmp (a0) * * new string is smaller than old chgsml equ * movea.l a3,a4  utloctal added 3/30/87 by jws * -- removed dependecy of FILER on REALS library * ********************************************************************* * refa sysglobals def matchstr_utloctal matchstr_utloctal movea.l 4(sp),a0 address of string      olorado *) $MODCAL,debug off,iocheck off,range off,ovflcheck off$ $ref 60$ $ALLOW_PACKED ON$ {JWS 3/31/87} program linker(input, output, keyboard); import sysglobals,fs,loader,ldr,asm,sysdevs,ci,misc; const pagelines = 63; n ires := ioresult; fgotoxy(output, 0, 22); write(bellchar, cteol); end; procedure ioerror; begin write(' ioresult = ',ires:1); escape(123); end; procedure getcommandchar(s:string80; var c:char); begin fgotoxy(output,0,23); write(s,cteol); read(keybo pageblocks = 2; entrysize = 26; type address = integer; point = ^integer; var keyboard: text; todaysdate: daterec; linkerdate: daterec; tempstring: string[12]; gvaluestring: string80; copyright, listfilename: string8ard,c); fgotoxy(output,0,22); writeln(cteol);write(cteol); if (c>='a') and (c<='z') then c:= chr(ord(c)-32); end; procedure writedate(var f: text; date: daterec); type months = packed array[0..35] of char; const monthname = months['JanFebMarAprMayJu clr.l d0 result move.b (a0)+,d2 length of string beq.s error {sb} oct@l1 clr.l d1 move.b (a0)+,d1 cmpi.b #32,d1 ord(' ') = 32 bne.s oct@l2 subq.b #1,d2 bgt.s oct@l1 bra.s error {sb0; listing: text; pagenum, linenum: shortint; linking,booting, outopen, verifying,defsout, printopen, printeron: boolean; commandchar: char; startgvr: addrec; startgvrmod: moddescptr; modsave: moddescptr; inf} oct@l5 clr.l d1 move.b (a0)+,d1 oct@l2 subi.w #48,d1 ord('0') = 48 blt.s tstblk cmpi.w #7,d1 bgt.s error move.l d0,d3 andi.l #$E0000000,d3 bne.s error asl.l #3,d0 add.l d1,d0 subq.b #1,d2 bgt.s oct@l5 oct@l4 movost: addrec; ires: integer; {saved ioresult} errors: integer; esccode: integer; lowheap0,highheap0: addrec; infilename: string80; vmodnum: shortint; {output file information: } outdirectory: addrec; {new libe.l d0,8(sp) put function result on the stack move.l (sp)+,(sp) move the return address up rts tstblk addi.w #48,d1 tstblk0 cmpi.b #32,d1 test for trailing blanks bne.s error subq.b #1,d2 ble.s oct@l4 move.b (a0)+,d1 bra.s tstblkrary directory pointer} outfile: phyle; {file being written} firstoutblock, outblock: integer; {next block within library to write} nextblock: integer; {next block within module to write} outfilename: string0 error move.w #-8,sysglobals-2(a5) trap #10 value range error end 80; outmodnum: integer; {number of modules created so far} outdirectsize, maxmodules: integer; {linker information: } totalpatchspace: integer; {bytes of patch space} patchbytes: integer; backwardpatches, forwardpatches: (* (c) Copyright Hewlett-Packard Company, 1985,1991. All rights are reserved. Copying or other reproduction of this program except for archival purposes is prohibited without the prior written consent of Hewlett-Packard Company. RESTR moddescptr; newmodname: addrec; {new name for linked module} infostart: addrec; {pointer to bottom of linker memory} newexttable: address; {location of new EXT table} newextsize: integer; {size in bytes ofICTED RIGHTS LEGEND Use, duplication, or disclosure by the Government is subject to restrictions as set forth in paragraph (b) (3) (B) of the Rights in Technical Data and Computer Software clause in DAR 7-104.9(a). HEWLETT-PACKARD COMPANY Fort Collins, C EXT table} newdirectory: addrec; {pointer to new module directory} loadgvr: gvrptr; modulepc: integer; { module body entry point } procedure dobeep; begin beep;if streaming then escape(-1); end; procedure errorline; begi!     nJulAugSepOctNovDec']; var i,j: shortint; begin with date do begin {LAF 880101 added "mod 100" and removed test for "year<100"} if (month in [1..12]) and (day>0) then begin { Valid date } write(f, day:2, '-'); j := (month - 1) * 3; fo,'Gbase'); end; general: begin done := false; repeat with rpp(g)^ do begin if adr=0 then if op=addit then Rcount := Rcount + 1 else Rcount := Rcount - 1 else if adr=1 then begin sign(op=subit); sappend(gvaluestring,r i := j to j+2 do write(f, monthname[i]); write(f, '-',year mod 100:2); end else write(f, ''); { Invalid date } end; end; {datestring} procedure gbytes(var p: integer; size: integer); begin p := lowheap.a; lowheap.a := lowhea'Gbase'); end else begin sign(op=subit); if newmods^.unresbits.bmp^[adr] or nores then sappend(gvaluestring,symbolptr(newexttable+4*adr)^) else sappend(gvaluestring,symbolptr(point(newexttable+4*adr)^)^); end; done := last; p.a + size; if lowheap.a > highheap.a then escape(112); end; procedure blockwrite(anyvar f: fib; anyvar obj: window; blocks,block: integer); begin call (f.am, addr(f), writebytes, obj, blocks*fblksize, block*fblksize); if ioresult <> ord(inoerror) th g := gvrptr(integer(g)+sizeof(referenceptr)); end; until done; end; {general} end; {primarytype cases} if not pcrel then gvp := g; end; {with g^} pcrel := not pcrel; until pcrel; while Rcount <> 0 do begin sign(Rcount<0); sapen escape(113); end; procedure readblocks(var f: fib; anyvar obj: window; size, block: integer); begin call (f.am, addr(f), readbytes, obj, size, block*fblksize); if ioresult <> ord(inoerror) then escape(-10); end; procedure gvrstring(var gvp:gvrptr;pend(gvaluestring,'Rbase'); if Rcount < 0 then Rcount := Rcount + 1 else Rcount := Rcount - 1; end; if (val <> 0) or (strlen(gvaluestring)=0) then begin if val >= 0 then sign(false); strwrite(gvaluestring,strlen(gvaluestring)+1,i,val:1); end;  var val:integer; pcrel,nores: boolean); (*advances g past the GVR, adds any absolute part to VAL, and constructs a string representing the GVR in gvaluestring *) type rpp = ^referenceptr; var Rcount: shortint; done: booleaend; {gvrstring} procedure printheader(var f: text); var time: timerec; begin write(f,'Librarian [Rev. 3.25 '); if ioresult <> 0 then begin printopen := false; printeron := false; escape(118); end; writedate(f, linkerdate); write(f,'n; g: gvrptr; i: integer; procedure sign(sub: boolean); begin if sub then sappend(gvaluestring,'-') else if strlen(gvaluestring)>0 then sappend(gvaluestring,'+'); end; begin {gvrstring} gvaluestring := ''; Rcount := 0; ]',' ':7); writedate(f, todaysdate); systime(time); with time do write(f, hour:4,':',minute:2,':',centisecond div 100:2); if pagenum > 0 then write(f,'page ':10,pagenum:1); writeln(f); writeln(f); end; procedure pageeject; var i: integer; begin if  repeat if pcrel then g := loadgvr else g := gvp; if g <> NIL then with g^ do begin if longoffset then g:=gvrptr(integer(g)+sizeof(generalvalue,true)) else g:=gvrptr(integer(g)+sizeof(generalvalue,false)); if valueextend then beginlinenum > 0 then page(listing); linenum := 0; end; procedure list; begin if linenum >= pagelines then pageeject; if linenum = 0 then begin pagenum := pagenum + 1; printheader(listing); linenum := linenum + 2; end; linenum := lin if not pcrel then val:= val + veptr(g)^.value; g:=gvrptr(integer(g)+sizeof(valueextension,sint)); end; case primarytype of absolute: {no more value}; relocatable: Rcount := Rcount + 1; global: begin sign(false); sappend(gvaluestringenum + 1; end; procedure listln; begin writeln(listing); linenum := linenum + 1; end; procedure quit; var ch: char; begin if (outopen and (outmodnum>0)) or (booting and (outblock>0)) then begin errorline; if booting then writeln('WARNING: Y!     pmod} dumped := true; with mp^,directory.drp^ do begin pageeject; textstep.a:=directory.a+sizeof(moduledirectory); list; write(listing,'MODULE '); modulepc := -2; { rdq } { no module body } modulename := textstep.syp^; { rdq } if strle list; writeln(listing,' Global base ',globalbase, ' Size ',globalsize,' bytes'); if extsize <= 8 then extsize := 0; list; writeln(listing,' EXT block ',extblock:3,' Size ',extsize, ' bytes'); list; writeln(listing,' DEF n(modulename) = 0 then write(listing,'(no name)') else begin write(listing,modulename); modulepc := -1; end; modulename := modulename+' '+modulename; { rdq } { make module entrypoint symbol } write(listing,' Created '); writedate block ',defblock:3,' Size ',defsize, ' bytes'); list; if (defsize>0) and (modulepc>-2) then {RDQ} begin { find the module entry point } def:=defaddr; done:=false; REPEAT if def.a >= defaddr.a + defsize then done:=tou didn''t finish booting') else writeln('WARNING: You didn''t ''Keep'' the output file.'); if streaming then escape(123) else begin write('Are you sure you want to quit? (type Y if yes) '); read(keyboard, ch); if (ch<>'y') and (ch(listing, date); writeln(listing); list; write(listing,'NOTICE: '); if strlen(notice)=0 then writeln(listing,'(none)') else writeln(listing,notice); fortranflag := (producer = 'F'); case producer of 'M': producername := 'Modcal Compile<>'Y') then commandchar := ' '; end; end; end; function readint(var value: integer): boolean; var s: string80; i: integer; begin readln(s); strread(s,1,i,value); if ioresult<>ord(inoerror) then if i <= strlen(s) then escape(124); rear'; 'P': producername := 'Pascal Compiler'; 'L': producername := 'Librarian'; 'F': producername := 'FORTRAN Compiler'; 'B': producername := 'BASIC Compiler'; 'A': producername := 'Assembler'; 'C': producername := '''C'' Compiler'; dint := ioresult=ord(inoerror); end; procedure unassemble; type hex = 0..15; htoctyp = array[0..15] of char; decodestatetype = (consts,code,abscode,startcase,casetable, endofproc,quittype,notype,phdr); const htoc = htoctyp['0','1','2','3',' 'D': producername := 'Ada Compiler'; otherwise producername := '" "'; producername[2] := producer; end; list; write(listing,' Produced by ', producername, ' of '); writedate(listing,revision); writeln(listing); if systemid = 0 then4','5','6','7','8','9','A','B','C','D','E','F']; var nilgvr: gvrptr; dumped: boolean; fortranflag: boolean; rangetype: (norange, pcrange, linerange); lowrange, highrange, lastline: integer; decodestate,oldstate: decodestatetype;  systemid := 1; list; writeln(listing,' Revision number ',systemid:1); list; writeln(listing,' Directory size ',directorysize:6,' bytes'); list; writeln(listing,' Module size ',modulesize:6,' bytes'); junkint:=strlen(textstep.syp^); textste PC,tablePC,casecodestart: integer; codecount: integer; {bytes left in current inbuf} codeindex: integer; {next byte of code in inbuf} instrsize: 0..22; {byte count of current instruction} refgvr: addrec; reflim,refloc: address; inbuf,refpp.a := textstep.a+junkint+2-ord(odd(junkint)); if executable then begin startgvr := textstep; junkint := 0; modulepc := -2; { rdq executable so no 'module body' } gvrstring(textstep.gvp,junkint,false,false); list; writeln(listing,tr: addrec; procedure dumpmod (mp:moddescptr); var junkint: integer; producername: string[30]; textstep: addrec; modulename: string255; { rdq } def : addrec; { rdq } done : boolean; { rdq } begin {dum' Execution address ',gvaluestring); end else begin startgvr.gvp:=NIL; list; writeln(listing,' Module NOT executable'); end; list; writeln(listing,' Code base ',relocatablebase, ' Size ',relocatablesize,' bytes'); "     rue else begin if def.syp^=modulename then begin { foundit now get its value } done:=true; def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^))); junkint:=0; gvrstring(def.gvp,junkint,false,false); strread(gvaluestringray [0..15] of boolean); 6: (bf_bit : 0..1; bf_reg : 0..7; bf_Do : boolean; bf_offset : 0..31; bf_Dw : boolean; bf_width : 0..31); 7: (exDAbit1 : 0..1; exRn1 : 0..7; expad1 : 0..7; exDu1 : 0..7; expad2 : 0..7; exDc1 ,7,junkint,modulepc); end else begin { advance to the next symbol } def.a := def.a + strlen(def.syp^)+2-ord(odd(strlen(def.syp^))); def.a := def.a + def.gvp^.short; end; end; UNTIL done; end; if sourcesize <> 0 then writeln(lis: 0..7; exDAbit2 : 0..1; exRn2 : 0..7; expad3 : 0..7; exDu2 : 0..7; expad4 : 0..7; exDc2 : 0..7); 8: (fopclas : 0..7; frx : 0..7; fry : 0..7; case integer of 0: (fextension : 0..127); 1: (fext : 0..15; sincosreg : ting,' EXPORT block ',sourceblock:3,' Size ', sourcesize,' bytes') else writeln(listing,' No EXPORT text'); list; writeln(listing,' There are ',textrecords,' TEXT records'); listln; listln; end; {with mp^,directory^} end; {dumpmod0..7); 2: (Kfactor : -64..63); 3: (KDreg : 0..7; zeros : 0..15)); end; const opsize = opsizetype['.b ','.w ','.l ']; var hexout: packed array[0..10,0..3] of hex; firstline: boolean; { 1st line of current instruction? } } procedure prepunassem; var i: integer; begin modsave := newmods; newmods := NIL; infost := lowheap; loadinfo(vmodnum, true, true); with newmods^,directory.drp^ do begin newexttable := extaddr.a; gbytes(unresbits.a, ((extsize div 4 + bytesleft: 0..22; { to be listed in current instr } instrbuf: string[255];{ alpha form of instruction } instr: packed record case integer of 1: (opcode: 0..15; case integer of 1: (cond: 0..15; displ: -128..127); 2: (reg1: r15) div 16)*2); for i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false; for i := 2 to listsize-1 do unresbits.bmp^[listaddr^[i] div 4] := true; end; if not dumped then dumpmod(newmods); end; procedure nextref; begin if refgvr.a < reflim egrange; opmode: 0..7; eamode: 0..7; eareg: regrange); 3: (dummy: 0..7; bit8: boolean; size: siz; fpredicate: 0..63) ); 3: (w: shortint); 4: (lb, rb: byte); end; {instr} ext: exttype; prothen if refgvr.gvp^.longoffset then refloc:=refloc+refgvr.gvp^.long else refloc:=refloc+refgvr.gvp^.short; end; procedure listinstruction; type regtype = (D,A); regrange = 0..7; siz = (bytesiz,wordsiz,longsiz,invalid); opsizetype = arcedure emitint(val: integer); var i: integer; begin strwrite(instrbuf, strlen(instrbuf)+1, i, val:1); end; procedure comma; begin sappend(instrbuf, ','); end; procedure space; begin sappend(instrbuf, ' '); end; procedure printinstrray[bytesiz..longsiz] of string[3]; exttype = packed record case integer of 1: (uwordext: 0..65535); 2: (wordext: shortint); 3: (longext: integer); 4: (regclass: regtype; reg: regrange; long: boolean; scale : 0..3; case fuword; var k: integer; begin write(listing,' '); for k := 0 to 3 do write(listing,htoc[hexout[(instrsize-bytesleft) div 2,k]]); bytesleft := bytesleft-2; end; procedure getinstrbytes(size: shortint); begin if codecount < size thenllindex : boolean of false: (case integer of 1: (byteext: -128..127); 2: (ubyteext: 0..255)); true: (exbs : boolean; exis : boolean; exbdsize : 0..3; expadbit : boolean; exindirect : 0..7)); 5: (mask: packed ar escape(121); moveleft(inbuf.stp^[codeindex],ext,size); moveleft(ext,hexout[instrsize div 2],size); instrsize := instrsize+size; codeindex := codeindex+size; codecount := codecount-size; end; procedure getinstruction; begin instrsize := "     t := 0; gvrstring(refgvr.gvp,offset,false,false); nextref; end; getinstrbytes(2); offset := ext.ubyteext; if refloc=PCtemp then begin gvrstring(refgvr.gvp,offset,false,false) ; nextref; end else gvrstring(nilgvr,offset,falsot ext.fullindex then if ext.scale = 0 then begin extend(1,pcrel,0); sappend(instrbuf, '('); with instr, ext do begin if not pcrel then begin emitdir(A, eareg); comma; end; emitdir(regclass,reg); if long then sappend(instrbuf,'.l)e,false); sappend(instrbuf,gvaluestring); end; procedure decode; label 1,2; type opndtype = (source,dest); regsymtype = array[regtype] of string[1]; extsiztype = array[bytesiz..longsiz] of 1..4; arithoptype = array[8..13] o') else sappend(instrbuf,'.w)'); end; end else begin sappend(instrbuf,'('); extend(1,pcrel,0); if pcrel then sappend(instrbuf,',') else strwrite(instrbuf,strlen(instrbuf)+1,I,',a',instr.eareg:1,','); emitdir(ext.regclass,ext.reg);0; getinstrbytes(2); instr.w := ext.wordext; end; procedure defineword; begin instrbuf := 'dc.w '; with instr do begin emitint(w); while strlen(instrbuf) < 11 do space; sappend(instrbuf,' or dc.b '); emitint(lb); commf string[3]; condcodetype = array[0..15] of string[2]; const SP = 7; regsym = regsymtype['d','a']; extsize = extsiztype[1,2,4]; condcode = condcodetype['t','f','hi','ls','cc','cs','ne','eq', 'vc','vs','pl','mi','ge','lt','ga; emitint(rb); while strlen(instrbuf) < 30 do space; sappend(instrbuf,' or dc.b '' '''); if (lb >= 32) and (lb < 127) then instrbuf[43] := chr(lb); if (rb >= 32) and (rb < 127) then instrbuf[44] := chr(rb); end; end; procedure t','le']; arithop = arithoptype['or','sub','','cmp','and','add']; var tempint,I : integer; bf_reg : 0..7; bf_Do : boolean; bf_offset : 0..31; bf_Dw : boolean; bf_width : 0..32; procedure osize; var size: siz; begextend(size: integer; pcrel: boolean; fudge: integer); var offset, location, PCtemp: integer; begin location := PC+instrsize; if size = 1 then {byte extension} begin PCtemp := location + 1; size := 2; end else PCtemp := locatiin size := instr.size; if size = invalid then goto 2; sappend(instrbuf, opsize[size]) end; procedure emitdir(regclass: regtype; reg: regrange); begin if (regclass = A) and (reg = SP) then sappend(instrbuf,'sp') else begin saon; while (refgvr.a 0 then sappend(instrbuf,'([') else sappend(instrbuf,'('); saveext := ext; case saveext.exbdsize of 0: goto 2; 1: ; 2: extend(2,pcrel and (not saveext.exbs),-2); 3: extend(4,pcre: siz); begin with instr do case eamode of 0: emitdir(D,eareg); 1: emitdir(A,eareg); 2: emitardef(eareg); 3: emitpostincr(eareg); 4: emitpredecr(eareg); 5: emitardisp(eareg); 6: emitindx(false); 7el and (not saveext.exbs),-2); end; if not saveext.exbs then begin if not pcrel then begin if (instrbuf[strlen(instrbuf)] <> '(') and (instrbuf[strlen(instrbuf)] <> '[') then comma; strwrite(instrbuf,strlen(instrbuf)+1,I,': case eareg of 0: extend(2,false,0); 1: extend(4,false,0); 2: extend(2,true,0); 3: emitindx(true); 4: immediate(fsize); 5..7: goto 2; end; {case eareg} end; {case eamode} end; {emitea} procedure opcode0; { bit, MOVEP, immediaa',instr.eareg:1); end else if (saveext.exbdsize = 1) { suppress displacement ? } then sappend(instrbuf,'PC'); end else if pcrel then begin if (instrbuf[strlen(instrbuf)] <> '(') and (instrbuf[strlen(instrbuf)] <> '[') then te, MOVES } type bitoptype = array[siz] of string[5]; immoptype = array[0..6] of string[4]; const bitop = bitoptype['btst ','bchg ','bclr ','bset ']; immop = immoptype['ori','andi','subi','addi','','eori','cmpi']; var I : integer; comma; sappend(instrbuf,'ZPC') end; if saveext.exindirect in [5,6,7] then sappend(instrbuf,']'); if not saveext.exis then begin if (instrbuf[strlen(instrbuf)] <> '(') and (instrbuf[strlen(instrbuf)] <> '[') then comma; emitdir( regsave : 0..7; begin { opcode0 } with instr do if bit8 then if eamode = 1 then begin if odd(opmode) then instrbuf := 'movep.l ' else instrbuf := 'movep.w '; if opmode <= 5 then begin emitardisp(eareg); saveext.regclass,saveext.reg); if saveext.long then sappend(instrbuf,'.l') else sappend(instrbuf,'.w'); case saveext.scale of 0: ; 1: sappend(instrbuf,'*2'); 2: sappend(instrbuf,'*4'); 3: sappend(instrbuf,'*8'); end; end; if saveexcomma; emitdir(D,reg1); end else begin emitdir(D,reg1); comma; emitardisp(eareg); end; end else begin {dynamic bit} instrbuf := bitop[size]; emitdir(D,reg1); comma; emitea(bytesiz); end else if reg1=4 then t.exindirect in [1,2,3] then sappend(instrbuf,']'); case saveext.exindirect of 0,1,4,5: ; 2,6: begin if (instrbuf[strlen(instrbuf)] <> '(') and (instrbuf[strlen(instrbuf)] <> '[') then comma; extend(2,false,0); end; 3, begin instrbuf := bitop[size]; immediate(bytesiz); comma; emitea(bytesiz {invalid}); end else { NOT bit8 } if ord(size) = 3 then if (reg1 > 4) {bit 11 on} then if (eamode = 7) and (eareg = 4) then {cas2} begin case re7: begin if (instrbuf[strlen(instrbuf)] <> '(') and (instrbuf[strlen(instrbuf)] <> '[') then comma; extend(4,false,0); end; end; sappend(instrbuf,')'); end; end; procedure emitimm(val: integer); beg1 of 5: instrbuf := 'cas2.b '; 6: instrbuf := 'cas2.w '; 7: instrbuf := 'cas2.l '; otherwise ; end; getinstrbytes(4); strwrite(instrbuf,strlen(instrbuf),I, ' d',ext.exDc1:1,':d',ext.exDc2:1, ',d',ext.exDu1:1,':d',#     d else { ord(size) <> 3 } begin if reg1=7 then begin { moves } instrbuf:='moves'; osize; getinstrbytes(2); if ext.long then begin emitdir(ext.regclass,ext.reg); comma; emitea(size); end else begin emitea1'} open, {have seen a lone '1'} cont); {at least two consecutive '1's} j,k,bitcount: integer; procedure transition(b: boolean); var states: shortint; begin if b then if optype = source then states := 6 else states := 5; (size); comma; emitdir(ext.regclass,ext.reg); end; end else begin instrbuf := immop[reg1]; if (eamode=7) and (eareg=4) then begin space; immediate(wordsiz); comma; if size = bytesiz then sappend(instrbuf, 'ccr')  case state of start: if b then begin state := open; sappend(regstring,regmasksym[bitcount]); end; open : if b then begin state := cont; sappend(regstring,'-'); end else begin state := start; sappend(regstring,'/'); ext.exDu2:1,',('); if ext.exDAbit1 = 0 then sappend(instrbuf,'d ') else sappend(instrbuf,'a '); strwrite(instrbuf,strlen(instrbuf),I,ext.exRn1:1,'):('); if ext.exDAbit2 = 0 then sappend(instrbuf,'d ') else sappend(instrbuf, else sappend(instrbuf, 'sr'); end else begin osize; immediate(size); comma; emitea(size); end; end; end; end; {opcode0} procedure move; { opcodes 1..3: move byte,long,word } var lsize: siz; begin with inst'a '); strwrite(instrbuf,strlen(instrbuf),I,ext.exRn2:1,')'); end else {cas} begin case reg1 of 5: instrbuf := 'cas.b d '; 6: instrbuf := 'cas.w d '; 7: instrbuf := 'cas.l d '; otherwise ; end; getinstr do begin case opcode of 1: lsize := bytesiz; 2: lsize := longsiz; 3: lsize := wordsiz; end; instrbuf := 'move'; if opmode=1 then sappend(instrbuf,'a'); sappend(instrbuf,opsize[lsize]); emitea(lsize); comma; if (opmode=7) and (rbytes(2); strwrite(instrbuf,strlen(instrbuf),I,ext.exDc1:1,',d', ext.exDu1:1,','); emitea(bytesiz); end else if reg1 < 3 then {chk2 cmp2} begin getinstrbytes(2); if ext.long then instrbuf := 'chk2' else ireg1>1) then goto 2; {kluge to make emitea emit destination} eamode := opmode; eareg := reg1; emitea(lsize {invalid}); end; end; {move} procedure opcode4; type miscoptype = array[0..7] of string[5]; unoptype = array[0..5] of strinnstrbuf := 'cmp2'; case reg1 of 0: sappend(instrbuf,'.b '); 1: sappend(instrbuf,'.w '); 2: sappend(instrbuf,'.l '); end; regsave := ext.reg; if ext.regclass = D then begin emitea(bytesiz); strwrg[4]; const predecr = 4; { eamode for predecrement } miscop = miscoptype['reset','nop','stop','rte','rtd','rts','trapv','rtr']; unop = unoptype['negx', 'clr', 'neg', 'not', '', 'tst']; var regstring: string80; I : integer; Dl, Dh : site(instrbuf,strlen(instrbuf)+1,I,',d',regsave:1); end else begin emitea(bytesiz); strwrite(instrbuf,strlen(instrbuf)+1,I,',a',regsave:1); end; end else if eamode <= 1 then begin if eamode = 0 then hortint; variantrec : packed record case boolean of true: (w1,w2: shortint); false: (i : integer); end; procedure emitreglist (optype: opndtype; predecr: boolean; var regstring: string80); { emit register list to 'regstring' acinstrbuf := 'rtm d ' else instrbuf := 'rtm a '; strwrite(instrbuf,strlen(instrbuf),I,eareg:1); end else begin instrbuf := 'callm '; sappend(instrbuf,'#'); unsigned_byte_extend; comma; emitea(bytesiz); encording to mask } type regmasksymtype = array[0..15] of string[2]; const regmasksym = regmasksymtype ['d0','d1','d2','d3','d4','d5','d6','d7', 'a0','a1','a2','a3','a4','a5','a6','a7']; var state: (start, {waiting for a '$      end; cont : if not b then begin state := start; sappend(regstring,regmasksym[bitcount-1]); sappend(regstring,'/'); end; end; {case} end; {transition} begin {emitreglist} getinstrbytes(2); if ext.wordext = 0 then regstring := '(n 12/22/89 } else if byteext = 7 then sappend(instrbuf,'srp') { JWH 12/22/89 } else goto 2; end; end; end; procedure jmpstates; begin with instr do case eamode of 2,5,6:; 7: if eareg>3 then goto 2; otherwise goto 2; one) ' else begin state := start; bitcount := 0; regstring := ''; if not predecr then for j := 1 downto 0 do begin for k := 7 downto 0 do begin transition(ext.mask[k+j*8]); bitcount := bitcount+1; end; transition( end; end; begin {opcode4} with instr do if bit8 then if ord(size) = 2 then begin instrbuf := 'chk '; emitea(wordsiz); comma; emitdir(D,reg1); end else if ord(size) = 0 then begin instrbuf := 'chkfalse); end else for j := 0 to 1 do begin for k := 0 to 7 do begin transition(ext.mask[k+j*8]); bitcount := bitcount+1; end; transition(false); end; end; if optype = source then regstring[strlen(regstri.l '; emitea(longsiz); comma; emitdir(D,reg1); end else if eamode = 0 then begin instrbuf := 'extb.l '; emitdir(D,eareg); end else begin instrbuf := 'lea '; emitea(invalid); comma; emitdir(Ang)] := ',' else setstrlen(regstring, strlen(regstring)-1); end; {emitreglist} procedure emitunop; begin with instr do begin instrbuf := unop[reg1]; osize; emitea(size {invalid}); end; end; procedure emitsreg; ,reg1); end else { NOT bit8 } case reg1 of 0: if size=invalid then begin instrbuf := 'move sr,'; emitea(wordsiz); end else emitunop; 1: if size=invalid then begin instrbuf := 'move ccr,'; emitea(wordsiz); end  begin with ext do begin if (scale <> 0) or (fullindex) then goto 2; if not long then begin if byteext=0 then sappend(instrbuf,'sfc') else if byteext=1 then sappend(instrbuf,'dfc') else if byteext = 2 then sappend(instrbuf,'cacr')else emitunop; 2: if size = invalid then begin instrbuf := 'move '; emitea(wordsiz); sappend(instrbuf, ',ccr'); end else emitunop; 3: if size = invalid then begin instrbuf := 'move '; emitea(wordsiz); sappend(instr else if byteext = 3 then sappend(instrbuf,'tc') { JWH 12/22/89 } else if byteext = 4 then sappend(instrbuf,'itt0') { JWH 12/22/89 } else if byteext = 5 then sappend(instrbuf,'itt1') { JWH 12/22/89 } else if byteext = 6 then sappend(instrbuf,'dbuf, ',sr'); end else emitunop; 4: case ord(size) of 0: if eamode = 1 then begin instrbuf := 'link.l '; emitdir(A,eareg); comma; immediate(longsiz); end else begin instrbuf := 'nbcd '; emittt0') { JWH 12/22/89 } else if byteext = 7 then sappend(instrbuf,'dtt1') { JWH 12/22/89 } else goto 2; end else begin if byteext=0 then sappend(instrbuf,'usp') else if byteext=1 then sappend(instrbuf,'vbr') else if byteext = 2 then sea(bytesiz {invalid}); end; 1: if eamode = 0 then begin instrbuf := 'swap '; emitdir(D,eareg); end else if eamode = 1 then begin instrbuf := 'bkpt # '; strwrite(instrbuf,strlen(instrbuf),I,eareg:1); append(instrbuf,'caar') else if byteext = 3 then sappend(instrbuf,'msp') else if byteext = 4 then sappend(instrbuf,'isp') else if byteext = 5 then sappend(instrbuf,'mmusr') { JWH 12/22/89 } else if byteext = 6 then sappend(instrbuf,'urp') { JWH end else begin instrbuf := 'pea '; emitea(invalid); end; 2,3: if eamode = 0 then begin instrbuf := 'ext'; sappend(instrbuf,opsize[pred(size)]); emitdir(D,eareg); end else begi$      else case eamode of 0,1: begin instrbuf := 'trap '; emitimm(eareg+8*eamode); if eareg + 8*eamode = 9 then begin comma; immediate(wordsiz); comma; extend(4,true,0); end else if eareg + 8*eamoe['asr','lsr','roxr','ror','asl','lsl','roxl','rol']; begin with instr do if size = invalid then begin instrbuf := shiftop[4*ord(bit8)+reg1]; space; emitea(bytesiz {invalid}); end else begin instrbuf := shiftop[4*ord(bit8)+eamodede = 1 then begin sappend(instrbuf,',# '); getinstrbytes(2); if ext.wordext > 0 then begin variantrec.w1 := ext.wordext; getinstrbytes(2); variantrec.w2 := ext.wordext; variantrec.i := -(variantrec.i - 1073741824);  mod 4]; osize; if eamode div 4 = 1 then begin emitdir(D,reg1); comma; end else quick; emitdir(D,eareg); end; end; {shift} procedure mc68881; var I,j,k : integer; saveext : exttype; procedure en instrbuf := 'movem'; sappend(instrbuf,opsize[pred(size)]); emitreglist(source,eamode=predecr,regstring); sappend(instrbuf,regstring); emitea(invalid); end; end; {case size} 5: if instr.w = 19196 {he strwrite(instrbuf,strlen(instrbuf),I,variantrec.i:1) end else strwrite(instrbuf,strlen(instrbuf),I,ext.wordext:1); end else if eareg + 8*eamode = 0 then begin comma; getinstrbytes(2); lastline := ext.uwordext; ex('4AFC')} then instrbuf := 'illegal' else if size = invalid then begin instrbuf := 'tas '; emitea(bytesiz {invalid}); end else emitunop; 6: if size ext.byteext) and (size <> bytesiz)) then Dh := ext.byteext else Dh := -1; emitea(longsiz); comma; if (Dh >= nstrbuf := miscop[eareg]; if (eareg=2) or (eareg=4) then {stop}{rtd} begin space; immediate(wordsiz); end; end; 7: begin { movec } if ord(size)<>1 then goto 2; instrbuf := 'movec '; getinstrbytes(2); if eareg=0) and (Dh <= 7) then begin emitdir(D,Dh); sappend(instrbuf,':'); end; emitdir(D,Dl); end else begin instrbuf := 'movem'; sappend(instrbuf,opsize[pred(size)]); emitreglist(dest,false,regstring); emitea(invalid)2 then begin emitsreg; comma; emitdir(ext.regclass,ext.reg); end else if eareg=3 then begin emitdir(ext.regclass,ext.reg); comma; emitsreg; end else goto 2; end; end; {case eamode} end; {case reg1} ; comma; sappend(instrbuf,regstring); end; 7: if ord(size) = 2 then begin instrbuf := 'jsr '; jmpstates; emitea(invalid); end else if ord(size) = 3 then begin instrbuf := 'jmp '; jmpstates; emitea(invalid); end end; {opcode4} procedure quick; begin with instr do if reg1 = 0 then emitimm(8) else emitimm(reg1); comma; end; procedure shift; type shiftoptype = array[0..7] of string[4]; const shiftop = shiftoptyp%     mitfdir(reg: regrange); begin sappend(instrbuf,'fp '); instrbuf[strlen(instrbuf)] := htoc[reg]; end; procedure emitfea(size: integer); type hexarray = array[0..15] of char; const hex = hexarray['0','1','2','3','4'd record case boolean of true: (b: byte); false:(a: packed array[0..7] of boolean); end; regnum, bitnum, lastbit : integer; function makestring(c: char): string1; var s: string1; begin setstrlen(s,1); s[1] := c; mak,'5','6','7','8','9', 'a','b','c','d','e','f']; var j,l : integer; variantrec : packed record case integer of 0: (i: integer); 1: (h: packed array[1..24] of 0..15); 2: (i1,i2,i3: integer); 3: (r : longreestring := s; end; procedure hithit; forward; procedure hitmiss; forward; procedure hithithit; begin if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantral); end; begin if (instr.eamode = 7) and (instr.eareg = 4) then { Immediate } case size of 0: {L} immediate(longsiz); 1: {S} begin sappend(instrbuf,'#'); getinstrbytes(4); variantrec.i := ext.longext; sappend(instrbufec.a[bitnum] then hithithit else begin sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1))); hitmiss; end else sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum-1))); end; procedure misshit; begin sappe,'$'); for j := 1 to 8 do strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]); end; 2,3: {X,P} begin sappend(instrbuf,'#'); getinstrbytes(4); variantrec.i1 := ext.longext; getinstrbytes(4); variantrec.i2 := ext.longext; nd(instrbuf,'/fp' + makestring(chr(ord('0')+regnum))); if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then hithit else hitmiss; end; procedure h getinstrbytes(4); variantrec.i3 := ext.longext; sappend(instrbuf,'$'); for j := 1 to 24 do strwrite(instrbuf,strlen(instrbuf)+1,I,hex[variantrec.h[j]]); end; 4: {W} immediate(wordsiz); 5: {D} begin sappend(instrbuf,'#'); getinstrbyitmiss; begin if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then misshit else hitmiss; end; procedure hithit; begin if zfirst then bitnum :=tes(4); variantrec.i1 := ext.longext; getinstrbytes(4); variantrec.i2 := ext.longext; try if variantrec.r > 0 then strwrite(instrbuf,strlen(instrbuf)+1,i,variantrec.r:21) else strwrite(instrbuf,strlen(instrbuf)+1,i,varia bitnum + 1 else bitnum := bitnum - 1; regnum := regnum + 1; if (bitnum = lastbit) then begin sappend(instrbuf,'-fp' + makestring(chr(ord('0')+regnum-1))); end else if not variantrec.a[bitnum] then begin sappend(instrbuf,'-fp' + makesntrec.r:22) recover if escapecode = -18 { bad arg in real/BCD conversion} then begin sappend(instrbuf,'$'); for j := 1 to 16 do strwrite(instrbuf,strlen(instrbuf)+1,i,hex[variantrec.h[j]]); end else tring(chr(ord('0')+regnum-1))); hitmiss; end else begin sappend(instrbuf,'-'); hithithit; end; end; procedure firsthit; begin sappend(instrbuf,'fp' + makestring(chr(ord('0')+regnum))); if zfirst then bitnum := bitnum + 1 eescape(escapecode); end; 6: {B} immediate(bytesiz); otherwise goto 2; end {case} else emitea(bytesiz); end; procedure dumpfregbits(reglist : byte; zfirst : boolean); type string1 = string[1]; var variantrec : packelse bitnum := bitnum - 1; regnum := regnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then hithit else hitmiss; end; procedure firstmiss; begin if zfirst then bitnum := bitnum + 1 else bitnum := bitnum - 1; regnum := r%     append(instrbuf,'ngl'); 26: sappend(instrbuf,'nle'); 27: sappend(instrbuf,'nlt'); 28: sappend(instrbuf,'nge'); 29: sappend(instrbuf,'ngt'); 30: sappend(instrbuf,'sne'); 31: sappend(instrbuf,'st'); otherwise goto 2; end; end; begin {r,'); 6: sappend(instrbuf,'fpcontrol/fpstatus,'); 7: sappend(instrbuf,'fpcontrol/fpstatus/fpiaddr,'); end; {case} emitea(bytesiz); end; end else if (ext.fopclas = 2) and (ext.frx = 7) then { FMOVECR } begin instrbuf : mc68881 } with instr do begin if opmode = 0 then begin getinstrbytes(2); if ext.fopclas >= 6 then { FMOVEM } begin instrbuf := 'fmovem '; if ext.fopclas = 6 then { move to FP data registers } begin saveext := ext; = 'fmovecr # '; strwrite(instrbuf,strlen(instrbuf),I,ext.fextension:1,','); emitfdir(ext.fry); end else { general } begin case ext.fextension of 0: instrbuf := 'fmove'; 1: instrbuf := 'fint'; 2: instrbuf := 'fsinh'; 3: iegnum + 1; if bitnum <> lastbit then if variantrec.a[bitnum] then firsthit else firstmiss; end; begin variantrec.b := reglist; if zfirst then begin bitnum := 0; lastbit := 8; end else begin bitnum := 7; lastbit := emitea(bytesiz); comma; if saveext.frx = 6 then { D reg } emitdir(D,saveext.KDreg) else if saveext.frx = 4 then { register mask } dumpfregbits(saveext.ubyteext,true) else goto 2; end else { move from FP data regi -1; end; regnum := 0; if variantrec.a[bitnum] then firsthit else firstmiss; end; procedure appendfloatsize(size : integer); begin case size of 0: sappend(instrbuf,'.l '); 1: sappend(instrbuf,'.s '); 2: sappesters } begin if (ext.frx = 2) or (ext.frx = 6) then emitdir(D,ext.KDreg) else if (ext.frx = 0) or (ext.frx = 4) then if ext.frx = 0 then dumpfregbits(ext.ubyteext,false) else dumpfregbits(ext.ubyteext,true) else gnd(instrbuf,'.x '); 3,7: sappend(instrbuf,'.p '); 4: sappend(instrbuf,'.w '); 5: sappend(instrbuf,'.d '); 6: sappend(instrbuf,'.b '); otherwise goto 2; end; {case} end; procedure appendfloatcondition(predicate : integer); begin oto 2; comma; emitea(bytesiz); end; end else if ext.fopclas >= 4 then { FMOVE sysreg } begin if ext.frx in [1,2,4] then instrbuf := 'fmove ' else instrbuf := 'fmovem '; if ext.fopclas = 4 then { move to sysregs }  case predicate of 0: sappend(instrbuf,'f'); 1: sappend(instrbuf,'eq'); 2: sappend(instrbuf,'ogt'); 3: sappend(instrbuf,'oge'); 4: sappend(instrbuf,'olt'); 5: sappend(instrbuf,'ole'); 6: sappend(instrbuf,'ogl'); 7: sappend(instrbuf,'or begin saveext := ext; emitea(longsiz); case saveext.frx of 0: sappend(instrbuf,',-'); 1: sappend(instrbuf,',fpiaddr'); 2: sappend(instrbuf,',fpstatus'); 3: sappend(instrbuf,',fpstatus/fpiaddr'); 4: sappe'); 8: sappend(instrbuf,'un'); 9: sappend(instrbuf,'ueq'); 10: sappend(instrbuf,'ugt'); 11: sappend(instrbuf,'uge'); 12: sappend(instrbuf,'ult'); 13: sappend(instrbuf,'ule'); 14: sappend(instrbuf,'neq'); 15: sappend(instrbuf,'t'); 16: sappend(innd(instrbuf,',fpcontrol'); 5: sappend(instrbuf,',fpcontrol/fpiaddr'); 6: sappend(instrbuf,',fpcontrol/fpstatus'); 7: sappend(instrbuf,',fpcontrol/fpstatus/fpiaddr'); end; {case} end else { move from sysregs } begin strbuf,'sf'); 17: sappend(instrbuf,'seq'); 18: sappend(instrbuf,'gt'); 19: sappend(instrbuf,'ge'); 20: sappend(instrbuf,'lt'); 21: sappend(instrbuf,'le'); 22: sappend(instrbuf,'gl'); 23: sappend(instrbuf,'leg'); 24: sappend(instrbuf,'nleg'); 25: s case ext.frx of 0: escape(0); 1: sappend(instrbuf,'fpiaddr,'); 2: sappend(instrbuf,'fpstatus,'); 3: sappend(instrbuf,'fpstatus/fpiaddr,'); 4: sappend(instrbuf,'fpcontrol,'); 5: sappend(instrbuf,'fpcontrol/fpiadd&     nstrbuf := 'fintrz'; (* LAF 861204 *) 4: instrbuf := 'fsqrt'; 6: instrbuf := 'flognp1'; 8: instrbuf := 'fetoxm1'; 9: instrbuf := 'ftanh'; 10:instrbuf := 'fatan'; 12:instrbuf := 'fasin'; 13:instrbuf := 'fatanh'; 14(ext.fextension < 32)) then { Do not display second op for FTST or "single op" instructions } else begin comma; if ext.fext = 6 then { FSINCOS } begin emitfdir(ext.sincosreg); sappend(instrbuf,':'); end; emit:instrbuf := 'fsin'; 15:instrbuf := 'ftan'; 16:instrbuf := 'fetox'; 17:instrbuf := 'ftwotox'; 18:instrbuf := 'ftentox'; 20:instrbuf := 'flogn'; 21:instrbuf := 'flog10'; 22:instrbuf := 'flog2'; 24:instrbuf := 'fabs'; fdir(ext.fry); end; end else if ext.fopclas = 2 then { source is } begin appendfloatsize(ext.frx); saveext := ext; emitfea(saveext.frx); if saveext.fextension <> 58 {FTST} then begin comma;  25:instrbuf := 'fcosh'; 26:instrbuf := 'fneg'; 28:instrbuf := 'facos'; 29:instrbuf := 'fcos'; 30:instrbuf := 'fgetexp'; 31:instrbuf := 'fgetman'; 32:instrbuf := 'fdiv'; 33:instrbuf := 'fmod'; 34:instrbuf := 'fad if saveext.fext = 6 then { FSINCOS } begin emitfdir(saveext.sincosreg); sappend(instrbuf,':'); end; emitfdir(saveext.fry); end; end else if ext.fopclas = 3 then { dest is } begin { FMOVE from MC68881 } instrbufd'; 35:instrbuf := 'fmul'; 36:instrbuf := 'fsgldiv'; 37:instrbuf := 'frem'; 38:instrbuf := 'fscale'; 39:instrbuf := 'fsglmul'; 40:instrbuf := 'fsub'; 48..55:instrbuf := 'fsincos'; 56:instrbuf := 'fcmp'; 58:instr := 'fmove'; appendfloatsize(ext.frx); emitfdir(ext.fry); comma; saveext := ext; emitea(bytesiz); if saveext.frx = 3 {size P} then strwrite(instrbuf,strlen(instrbuf)+1,I,'{#',saveext.Kfactor:1,'}') else if saveext.buf := 'ftst'; 64:instrbuf := 'fsmove'; { JWH 12/21/89 } 65:instrbuf := 'fssqrt'; { JWH 12/21/89 } 68:instrbuf := 'fdmove'; { JWH 12/21/89 } 69:instrbuf := 'fdsqrt'; { JWH 12/21/89 } 88:instrbuf := 'fsabs'; { JWH 12/21/89 } frx = 7 {size P} then strwrite(instrbuf,strlen(instrbuf)+1,I,'{d',saveext.KDreg:1,'}'); end else goto 2; end; end else case opmode of 1: { FScc, FDBcc, FTRAPcc } begin if eamode = 1 then instrbuf := 'fdb'  90:instrbuf := 'fsneg'; { JWH 12/21/89 } 92:instrbuf := 'fdabs'; { JWH 12/21/89 } 94:instrbuf := 'fdneg'; { JWH 12/21/89 } 96:instrbuf := 'fsdiv'; { JWH 12/21/89 } 98:instrbuf := 'fsadd'; { JWH 12/21/89 } 99:instrbuf := 'fs else if (eamode = 7) and (eareg = 4) then instrbuf := 'ftrap' (* LAF 861204 *) else if (eamode = 7) and ((eareg = 2) or (eareg = 3)) then instrbuf := 'ftrap' (* LAF 861204 *) else instrbuf := 'fs'; gemul'; { JWH 12/21/89 } 100:instrbuf := 'fddiv'; { JWH 12/21/89 } 102:instrbuf := 'fdadd'; { JWH 12/21/89 } 103:instrbuf := 'fdmul'; { JWH 12/21/89 } 104:instrbuf := 'fssub'; { JWH 12/21/89 } 108:instrbuf := 'fdsub'; { JWH 12/tinstrbytes(2); appendfloatcondition(ext.ubyteext); if eamode = 1 then begin if instrbuf = 'fdbf' then instrbuf := 'fdbra ' else sappend(instrbuf,' '); emitdir(D,eareg); comma; extend(2,tru21/89 } otherwise ; end; {case} if ext.fopclas = 0 then { source is Freg } begin sappend(instrbuf,' '); emitfdir(ext.frx); if (ext.fextension = 58 {FTST}) or ((ext.frx = ext.fry) and (ext.fextension <> 0 {FMOVE}) and e,0); end else if (eamode = 7) and (eareg = 4) then { FTcc } else if (eamode = 7) and (eareg = 2) then begin { FTPcc.W } sappend(instrbuf,'.w '); immediate(wordsiz); end else if (eamode = 7)&     nd; { my_type } var see_it : move16_type; var see_ex : my_type; begin { So far we've seen first 7 bits of instruction } see_it.w := instr.w; { see it as a move16 } instrbuf := 'move16 '; with see_it do begin if tn if the_op <> 244 { hex('F4') } then begin defineword; goto 1; end; { Seen 8 bits now } if which_instr = 0 then begin { CINV } case scope of 0 : begin defineword; goto 1; end; { ILLEGAL } 1 : instrbuf := 'cinvl '; 2 : instrbufhe_op <> 246 { hex('F6') } then begin defineword; goto 1; end; { First 8 bits } if which > 1 then begin defineword; goto 1; end; { First 11 bits } if which = 1 then { have post increment format } begin if mode_16 <> 0 then { gotta be for this  := 'cinvp '; 3 : instrbuf := 'cinva '; otherwise ; end; { case } case which_caches of 0 : strappend(instrbuf,'NONE'); { NOOP, NOT ILLEGAL } 1 : strappend(instrbuf,'DC'); 2 : strappend(instrbuf,'IC'); 3 : strappend(instrbuf,'DC/IC'); and (eareg = 3) then begin { FTPcc.L } sappend(instrbuf,'.l '); immediate(longsiz); end else begin sappend(instrbuf,' '); emitea(bytesiz); end; end; 2,3: { Revearse assemble FBformat } begin defineword; goto 1; end; { First 13 bits } getinstrbytes(2); if ext.exDAbit1 <> 1 then begin defineword; goto 1; end; { First 17 bits } see_ex.w := ext.wordext; if ((see_ex.nib2 <> 0) or (see_ex.byte_it <> 0)) then F *+2 as FNOP } begin moveleft(inbuf.stp^[codeindex],ext,2); if (instr.fpredicate = 0) and (opmode = 2) and (ext.wordext = 0) then begin { FNOP } instrbuf := 'fnop'; getinstrbytes(2); end else begin { FBcc begin defineword; goto 1; end; { First 32 bits } { Have a valid move16 of this format if we get this far } emitpostincr(reg_ax); comma; emitpostincr(ext.exRn1); end { which = 1 , post increment format } else { which = 0, have absolute } if instr.fpredicate = 15 {FBT} then instrbuf := 'fbra' else begin instrbuf := 'fb'; appendfloatcondition(instr.fpredicate); end; if opmode = 3 then begin sappend(instrbuf,'.l '); extend(4,true,0); en format } begin { Have a valid move16 of this format if we get here. } case mode_16 of 0 : begin emitpostincr(reg_ax); comma; extend(4,false,0); end; 1 : begin extend(4,false,0); comma; emitpostincr(reg_ax); end; 2 : begin emitardefd else begin sappend(instrbuf,' '); extend(2,true,0); end; end; end; 4,5: { FSAVE, FRESTORE } begin if opmode = 4 then instrbuf := 'fsave ' else instrbuf := 'frestore '; emitea(byte(reg_ax); comma; extend(4,false,0); end; 3 : begin extend(4,false,0); comma; emitardef(reg_ax); end; otherwise ; { this really can't happen } end; { case } end; { which = 0, absolute format } end; { with see_it } 1: end; { move16siz); end; otherwise goto 2; end {case}; end {with instr}; end; { mc68881 } { Added 12/22/89 JWH : } procedure move16; { Handle the '040 move16 instruction } LABEL 1; type move16_type = packed record case integer of  } { Added 12/22/89 JWH : } procedure cinv_cpush; { Handle '040 CINV and CPUSH instructions } LABEL 1; type cache_40_type = packed record case integer of 1: (the_op : byte; which_caches : 0..3; which_instr : 0..1; scope : 0..3;  1: (the_op : byte; which : 0..7; mode_16 : 0..3; reg_ax : regrange); 2: (w : shortint); end; { move16_type } type my_type = packed record case integer of 1: ( nib1,nib2 : 0..15; byte_it : byte) ; 2: (w : shortint); e reg_ax : regrange); 2: (w : shortint); end; { cache_40_type } var see_it : cache_40_type; begin { Have seen the first seven bits of the instruction } see_it.w := instr.w; { see it as a cinv or cpush } with see_it do begi'      otherwise ; end; { case } if ((scope = 1) or (scope = 2)) then { CINVL or CINVP .. } begin { get the reg ... } comma; emitardef(reg_ax); end; { CINVL or CINVP } end { CINV } else begin { CPUSH } case scope of 0 : begin defid else if eareg = 3 then { .l } begin sappend(instrbuf,'.l '); immediate(longsiz); end; end; end else begin if bit8 then instrbuf := 'subq' else instrbuf := 'addq'; osize; quick; emitea(sineword; goto 1; end; { ILLEGAL } 1 : instrbuf := 'cpushl '; 2 : instrbuf := 'cpushp '; 3 : instrbuf := 'cpusha '; otherwise ; end; { case } case which_caches of 0 : strappend(instrbuf,'NONE'); { NOOP, NOT ILLEGAL } 1 : strappend(instrze {invalid}); end; 6: begin instrbuf := 'b'; if cond = 0 then sappend(instrbuf,'ra') else if cond = 1 then sappend(instrbuf,'sr') else sappend(instrbuf,condcode[cond]); if displ = -1 then { 32 bit displ } begin buf,'DC'); 2 : strappend(instrbuf,'IC'); 3 : strappend(instrbuf,'DC/IC'); otherwise ; end; { case } if ((scope = 1) or (scope = 2)) then { CPUSHL or CPUSHP .. } begin { get the register ... } comma; emitardef(reg_ax); end; { CPUSHL  sappend(instrbuf,'.l '); extend(4,true,0); end else if displ = 0 then begin sappend(instrbuf,'.w '); extend(2,true,0); end else begin sappend(instrbuf,'.s '); ext.longext :=or CPUSHP } end; { CPUSH } end; { with see_it } 1 : end; { cinv_cpush } begin {decode} with instr do case opcode of 0: opcode0; 1,2,3: move; 4: opcode4; 5: if size = invalid then begin if eamode = 1 then  pc + 2 + displ; tempint := ext.longext; gvrstring(nilgvr,tempint,true,false); sappend(instrbuf,gvaluestring); end; end; 7: begin instrbuf := 'moveq '; emitimm(displ); comma; emitdir(D,reg1); end; 8,9 begin instrbuf := 'db'; if cond = 1 then sappend(instrbuf,'ra') else sappend(instrbuf,condcode[cond]); space; emitdir(D, eareg); comma; extend(2,true,0); end else if (eamode < 7) or ((eamode = 7) and ,11,12,13: begin instrbuf := arithop[opcode]; if size=invalid then begin if odd(opcode) then begin sappend(instrbuf,'a'); if bit8 then begin sappend(instrbuf, opsize[longsiz]); emitea(longsiz); end (eareg <= 1)) then begin instrbuf := 's'; sappend(instrbuf,condcode[cond]); space; emitea(bytesiz {invalid}); end else { trapcc } begin case cond of 0: instrbuf := 'trapt'; 1: instrbuf := else begin sappend(instrbuf,opsize[wordsiz]); emitea(wordsiz); end; comma; emitdir(A,reg1); end else begin if opcode = 8 then instrbuf := 'div' else instrbuf := 'mul'; if bit8 then sappend(instrbuf,'s ')'trapf'; 2: instrbuf := 'traphi'; 3: instrbuf := 'trapls'; 4: instrbuf := 'trapcc'; 5: instrbuf := 'trapcs'; 6: instrbuf := 'trapne'; 7: instrbuf := 'trapeq'; 8: instrbuf := 'trapvc'; 9: instrbuf := 'trapvs'; 10:instrbuf := 'trap else sappend(instrbuf,'u '); emitea(wordsiz); comma; emitdir(D,reg1); end end else if (not bit8) or (eamode > 1) or (opcode = 11) then begin if opcode = 11 then if bit8 then if eamode = 1 then begipl'; 11:instrbuf := 'trapmi'; 12:instrbuf := 'trapge'; 13:instrbuf := 'traplt'; 14:instrbuf := 'trapgt'; 15:instrbuf := 'traple'; end; if eareg = 2 then { .w } begin sappend(instrbuf,'.w '); immediate(wordsiz); enn sappend(instrbuf,'m'); osize; emitpostincr(eareg); comma; emitpostincr(reg1); goto 1; end else instrbuf := 'eor'; osize; if bit8 then begin emitdir(D,reg1); comma; emitea(size); end else begin emitea(size); com'      emitdir(D,bf_reg); comma; end; emitea(bytesiz); sappend(instrbuf,'{'); if bf_Do then sappend(instrbuf,'d'); strwrite(instrbuf,strlen(instrbuf)+1,I,bf_offset:1); sappend(instrbuf,':'); if bf_Dw then strwrit writeln(listing); end; {printprocboundary} begin {decodestuff} 1: case decodestate of consts: begin getinstruction; if (PC=MODULEPC) { MODULE BODY ADDRESS } then begin decodestate := code; decode; if (rangetype = norange) ore(instrbuf,strlen(instrbuf)+1,I,'d',bf_width:1) else begin if bf_width = 0 then bf_width := 32; strwrite(instrbuf,strlen(instrbuf)+1,I,bf_width:1); end; sappend(instrbuf,'}'); if cond in [9,11,13] then begi ((rangetype = pcrange) and (PC >= lowrange) and (PC < highrange)) or ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange)) then printprocboundary; end else { check for dc.w even,0 or 1} if (not odma; emitdir(D,reg1); end; end else begin if odd(opcode) then begin sappend(instrbuf,'x'); osize; end else if opcode = 8 then if size = bytesiz then instrbuf := 'sbcd ' else if size = wordsiz then instrbuf :=n comma; emitdir(D,bf_reg); end; end else shift; 15: if reg1 = 1 then mc68881 { Next two lines JWH 12/22/89 : } else if reg1 = 2 then cinv_cpush else if ((reg1 = 3) and (instr.opmode = 0)) then move16  'pack ' else { size = longsiz } instrbuf := 'unpk ' else if size = bytesiz then instrbuf := 'abcd ' else begin instrbuf := 'exg '; if eamode = 0 then begin emitdir(D,reg1); comma; emitdir(D,eareg) end else if opmo else goto 2; otherwise goto 2; end; {case} goto 1; 2: begin defineword; if decodestate <> abscode then decodestate := consts; end; 1: end; {decode} procedure definecaseword; var savepc: integer; begin instrsize := 0; ide = 5 then begin emitdir(A,reg1); comma; emitdir(A,eareg) end else begin emitdir(D,reg1); comma; emitdir(A,eareg) end; goto 1; end; if eamode = 0 then begin emitdir(D,eareg); comma; emitdir(D,reg1); end else begnstrbuf := 'case jump '; savepc := pc; pc := tablepc; extend(2, true,0); pc := savepc; end; procedure decodestuff; label 1; var temp: integer; procedure printprocboundary; label 1; var defaddr,deflimit,len,gvrbase: integer; in emitpredecr(eareg); comma; emitpredecr(reg1); end; if (opcode = 8) and (size >= wordsiz) then { pack unpk } begin comma; immediate(wordsiz); end; end; end; 14: if (ord(size) = 3) and (reg1 >=  veloc: addrec; begin defaddr:=newmods^.defaddr.a; deflimit:=defaddr+newmods^.defsize; while defaddr < deflimit do begin len:=strlen(symbolptr(defaddr)^); len:=len+2-ord(odd(len)); gvrbase:=defaddr+len; with gvrptr(gvrba4) then { bit field op } begin case cond of 8: instrbuf := 'bftst '; 9: instrbuf := 'bfextu '; 10: instrbuf := 'bfchg '; 11: instrbuf := 'bfexts '; 12: instrbuf := 'bfclr '; 13: instrbuf := 'bfffo '; 14: inse)^ do if primarytype = loadgvr^.primarytype then begin veloc.a:=gvrbase+sizeof(generalvalue,false); if veloc.vep^.value = PC then goto 1; end; defaddr:=defaddr+len+ord(symtableptr(defaddr)^[len+1]); end; listln; 1: strbuf := 'bfset '; 15: instrbuf := 'bfins '; end; getinstrbytes(2); bf_reg := ext.bf_reg; bf_Do := ext.bf_Do; bf_offset := ext.bf_offset; bf_Dw := ext.bf_Dw; bf_width := ext.bf_width; if cond = 15 then begin  list; if MODULEPC = PC then write(listing,'- * module body * -') else write(listing,'- - - - - - - - - -'); write(listing,' - - - - - - - - - - - - - - - - '); if defaddr < deflimit then write(listing,symbolptr(defaddr)^); (     d(instr.lb) and (instr.rb<2)) then begin defineword; decodestate := phdr; end else if (instr.w = 20217) {JMP long abs} or (instr.w = 24576) {BRA 16 bit} then decode else defineword; end; phdr:begin getinstruction; getype = linerange) and (lastline >= lowrange) and (lastline < highrange)) then repeat list; if firstline then write(listing,PC:8,' ') else write(listing,'':9 {17} ); printinstrword; if bytesleft>0 then printinstrword else  if (instr.w = 20054) {LINK A6} or (instr.w = 18446) {LINK.L A6} or (instr.w = 20033) {TRAP #1} or (PC=MODULEPC) {MODULE BODY ADDRESS } then begin decodestate := code; decode; if (rangetype = norange) or ((rangetype = if firstline then write(listing,'':5); if firstline then begin writeln(listing,'':9,instrbuf); firstline := false end else writeln(listing); until bytesleft = 0; PC:=PC + instrsize; end; {listinstruction} procedure getcodeblocks; var pcrange) and (PC >= lowrange) and (PC < highrange)) or ((rangetype = linerange) and (lastline >= lowrange) and (lastline < highrange)) then printprocboundary; end else if (instr.w = 20217) {JMP long abs} or (instr.w = 24576) { junkint: integer; pclimit: integer; textstep: addrec; textrecctr: {shortint} INTEGER {SFB}; begin with newmods^,directory.drp^ do begin textstep.a:=directory.a+sizeof(moduledirectory); junkint:=strlen(textstep.syp^); textstep.a :=BRA 16 bit} then begin decode; decodestate:=consts; end else begin defineword; if not (not odd(instr.lb) and (instr.rb<2)) then decodestate := consts; end; end; abscode, code: begin getinstruction; decode;  textstep.a+junkint+2-ord(odd(junkint)); if executable then textstep.a := textstep.a + textstep.gvp^.short; textrecctr:=textrecords; while textrecctr > 0 do with textstep.tdp^ do begin textrecctr:=textrecctr-1; list; writeln(listing if decodestate <> abscode then if instr.w = 20062 {UNLK A6} then decodestate := endofproc else if instr.w = 20219 {JMP pc indexed} then begin oldstate := code; decodestate := startcase end; end; startcase: begin tablePC := PC; ,'TEXT RECORD #', textrecords-textrecctr, ' of ''', fdirectory^[vmodnum].dtid, ''':'); list; writeln(listing,' TEXT start block ',textstart:4, ' Size ',textsize,' bytes'); list; writeln(listing,' REF start block ',refstart: definecaseword; casecodestart:=ext.wordext+PC; decodestate := casetable; end; casetable: begin if PC = casecodestart then begin decodestate := oldstate; goto 1 end else begin definecaseword; if not fortranflag then beg4, ' Size ',refsize,' bytes'); textstep.a :=textstep.a+sizeof(textdescriptor); PC := 0; loadgvr := textstep.gvp; gvrstring(textstep.gvp,PC,false,false); gbytes(inbuf.a,textsize); readblocks(filefib.fbp^, inbuf.p^in temp:=ext.wordext+tablePC; if temp= lowrange) and (PC < highrange)) or ((ran; pclimit := PC + textsize; list; writeln(listing,' LOAD address ',gvaluestring); listln; while PC < pclimit do listinstruction; listln; listln; lowheap := inbuf; end; end; {with newmods^,directory^} end; {getcod(     ) div pagesize; for i := 0 to pages-1 do begin readsize := sourcesize - i*pagesize; { scs 1/17/83 } if readsize > pagesize then readsize := pagesize; { scs 1/17/83 } readblocks(filefib.fbp^,textbuf.p^,readsi; end; 'P': begin rangetype := pcrange; decodestate := abscode; getbounds; disassemble; end; 'L': begin rangetype := linerange; decodestate := consts; getbounds; disassemble; end; 'T': listtext; 'D': listdefs; 'E': listexze, { scs 1/17/83 } fileblock+sourceblock+i*pageblocks); ptr := textbuf; linestart := true; repeat case ptr.cp^ of chr(etx), nullchar: ptr.a := textbuf.a + pagesize; otherwise dochar(ptr.cp^); ts; otherwise dobeep; end; until decodestate = quittype; end; {unassemble} procedure makenewgvr(var oldptr: addrec; modptr: moddescptr); var refsize: shortint; lastptr, firstptr, vptr, gptr: addrec; proeblocks} procedure listdefs; var len,val: integer; lim,p1: addrec; begin prepunassem; with newmods^ do begin list; writeln(listing,' DEF table of ''', fdirectory^[vmodnum].dtid, ''':'); listln; p1 := defaddr; lim.a := p1.a + def end; ptr.a := ptr.a + 1; until ptr.a >= textbuf.a + pagesize; if not linestart then dochar(eol); end; end; listln; newmods := modsave; lowheap := infost; end; procedure disassemble; begin prepunassem; nilgvr := NIL; getcodeblocks; newmsize; while p1.a < lim.a do begin len:=strlen(p1.syp^); list; write(listing,'':5,p1.syp^,'':(30-len)); p1.a := p1.a + len+2-ord(odd(len)); val := 0; gvrstring(p1.gvp,val,false,false); writeln(listing,gvaluestring); end; ods := modsave; lowheap := infost; end; procedure getbounds; begin lastline := -1; fgotoxy(output, 0,13); write('lower bound? '); if readint(lowrange) then begin write('upper bound? '); if not readint(highrange) then highraend; listln; newmods := modsave; lowheap := infost; end; procedure listexts; var i: integer; p1: addrec; begin prepunassem; with newmods^ do begin list; writeln(listing,' EXT table of ''', fdirectory^[vmodnum].dtid, ''':'); nge := maxint; end else begin lowrange := minint; highrange := maxint; end; end; begin {unassemble} fortranflag := false; decodestate := notype; dumped := false; repeat fgotoxy(output, 0,2); writeln('Q Q listln; for i:=2 to listsize-1 do if listaddr^[i] <> 0 then begin p1.a := extaddr.a + listaddr^[i]; list; writeln(listing,'':5,p1.syp^); end; end; listln; newmods := modsave; lowheap := infost; end; procedure listtext; const pageuit',cteos); writeln('S Stop unassembling'); writeln('T print import Text'); writeln('E print Ext table'); writeln('D print Def table'); writeln('A unassemble all (Assembler conventions)'); writeln('C unassemble all (Compiler size = pageblocks * blocksize; var textbuf,ptr: addrec; i,j,pages: integer; readsize: integer; linestart: boolean; procedure dochar(c: char); begin if linestart then list; linestart := (c = eol); if linestart then writeln(list conventions)'); writeln('P PC range (Assembler conventions)'); writeln('L Line range (Compiler conventions)', cteos); getcommandchar('unassemble option?',commandchar); if commandchar <> ' ' then case commandchar of ing) else write(listing, c); end; begin prepunassem; gbytes(textbuf.a, pagesize); with newmods^, directory.drp^ do begin list; writeln(listing,' DEFINE SOURCE of ''', fdirectory^[vmodnum].dtid, ''':'); listln; pages := (sourcesize + (pagesize-1)'S': decodestate := quittype; 'Q': begin decodestate := quittype; quit; end; 'A': begin rangetype := norange; decodestate := abscode; disassemble; end; 'C': begin rangetype := norange; decodestate := consts; disassemble)     cedure runlist(var oldptr: addrec; modptr: moddescptr; sub: boolean); var done: boolean; defptr: addrec; procedure addref(add: shortint; sub: boolean); var iptr,jptr,tp: addrec; notdone, notcancels: boolean; begin if  if modptr = NIL then begin modptr := newmods; done := false; repeat with modptr^ do if patchmod then modptr := link else if oldptr.a < defaddr.a then modptr := link else if oldptr.a > defaddr.a + defsize then modptr := link else dadd = 0 then if sub then vptr.vep^.value := vptr.vep^.value - modptr^.relocdelta else vptr.vep^.value := vptr.vep^.value + modptr^.relocdelta else if add = 1 then if sub then vptr.vep^.value := vptr.vep^.value - modptr^.globaldeltaone := true; until done; end; case primarytype of relocatable: addref(0, sub); global: addref(1, sub); general: begin done := false; repeat with oldptr.rpp^ do begin defptr := modptr^.extaddr.ptp^[adr];  else vptr.vep^.value := vptr.vep^.value + modptr^.globaldelta; iptr := lastptr; notdone := true; notcancels := true; while (iptr.a > firstptr.a) and notdone do begin iptr.a := iptr.a - sizeof(referenceptr); with iptr.rpp^ if modptr^.unresbits.bmp^[adr] then addref(defptr.rp.adr, sub <> (op = subit)) else begin defptr.a := defptr.a + strlen(defptr.syp^) + 2 - ord(odd(strlen(defptr.syp^))); runlist(defptr, NIL, sub <> (op = subit)); end;  do if adr <= add then begin if adr = add then notcancels := (op = subit) = sub; iptr.a := iptr.a + sizeof(referenceptr); notdone := false; end; end; if notcancels then begin gbytes(jptr.a, sizeof(referenceptr));  oldptr.a := oldptr.a + sizeof(referenceptr); done := last; end; until done; end; {general} end; {case} end; {primarytype <> absolute} end; {with} end; {runlist} begin {makenewgvr} gbytes(gptr.a, sizeof(generalvalue)); gpt lastptr := lowheap; while jptr.a > iptr.a do begin tp.a := jptr.a - sizeof(referenceptr); jptr.rpp^ := tp.rpp^; jptr := tp; end; with iptr.rpp^ do begin adr := add; last := false; if sub then op := subit else op := addit; end; er.gvp^ := oldptr.gvp^; with gptr.gvp^ do begin if not longoffset then lowheap.a := lowheap.a - (sizeof(generalvalue) - sizeof(generalvalue, false)); gbytes(vptr.a, sizeof(valueextension, sint)); vptr.vep^.value := 0; valuend else begin tp.a := iptr.a - sizeof(referenceptr); while iptr.a < lastptr.a do begin tp.rpp^ := iptr.rpp^; tp := iptr; iptr.a := iptr.a + sizeof(referenceptr); end; lastptr.a := lastptr.a - sizeof(referenceptr); lowextend := true; end; firstptr := lowheap; lastptr := firstptr; runlist(oldptr, modptr, false); with gptr.gvp^ do begin refsize := lastptr.a - firstptr.a; if refsize = 0 then primarytype := absolute else begin if refheap := lastptr; end; end; begin {runlist} with oldptr.gvp^ do begin if longoffset then oldptr.a := oldptr.a+sizeof(generalvalue, true) else oldptr.a := oldptr.a+sizeof(generalvalue, false); if valueextend then begin size = sizeof(referenceptr) then with firstptr.rpp^ do if adr <= 1 then if op = addit then begin if adr = 0 then primarytype := relocatable else primarytype := global; lastptr := firstptr; lowheap := lastptr; refsize := 0; end;  if sub then vptr.vep^.value := vptr.vep^.value - oldptr.vep^.value else vptr.vep^.value := vptr.vep^.value + oldptr.vep^.value; oldptr.a := oldptr.a + sizeof(valueextension, sint); end; if primarytype <> absolute then begin  if refsize > 0 then begin firstptr.a := lastptr.a - sizeof(referenceptr); firstptr.rpp^.last := true; end; end; short := lastptr.a - gptr.a; {even if it is long variety} end; end; procedure compressgvr(gvptr: addrec); var vpt)      := mrbase + relocatablesize + ord(odd(relocatablesize)); globase := mgbase; globaldelta := mgbase - globalbase; mgbase := mgbase - globalsize - ord(odd(globalsize)); gbytes(unresbits.a, ((extsize div 4 + 15) div 16)*2); n ext := symbolptr(extaddr.a + listaddr^[N]); i := sortlen; minindex := ilist.ilp^[i]; repeat if i >= listlen then done := true else if ext^ <= slist^[ilist.ilp^[i+1]].ext^ then done := true else begin ilist.ilp^[i] := ilist.ilp^[i+1]; ifor i := 2 to extsize div 4 - 1 do unresbits.bmp^[i] := false; unresbits.bmp^[0] := true; unresbits.bmp^[1] := true; extaddr.ptp^[0].rp.w := 0; extaddr.ptp^[1].rp.w := 4; sp := directory; sp.a := sp.a+sizeof(moduledire := i + 1; end; until done; ilist.ilp^[i] := minindex; end; until done; sortlen := sortlen - 1; end; if listlen > 0 then begin strptr.syp := slist^[ilist.ilp^[1]].ext; len := strlen(strptr.syp^) + 4 - strlen(str: addrec; begin with gvptr.gvp^ do if valueextend then begin if longoffset then vptr.a := gvptr.a + sizeof(generalvalue, true) else vptr.a := gvptr.a + sizeof(generalvalue, false); with vptr.vep^ do if value = 0 then begin lowheap.a :ctory); if newmodname.syp = NIL then newmodname := sp; if startgvr.p = NIL then if executable then begin startgvrmod := modptr; startgvr.a := sp.a+strlen(sp.syp^)+2-ord(odd(strlen(sp.syp^))); end; end; modptr := link; = lowheap.a - sizeof(valueextension, sint); fastmove(point(vptr.a + sizeof(valueextension, sint)), vptr.p, lowheap.a - vptr.a); valueextend := false; short := short - sizeof(valueextension, sint); end; end; end; procedure rsolve; var m end; totalreloc := mrbase - startreloc; totalglobal := startglobal - mgbase; end; {rsolve} procedure mergeexts; var ilist: addrec; slist: sortlistptr; sptr: addrec; listlen: shortint; sortlen: shortint; odptr, lastptr, nextptr: moddescptr; mrbase,mgbase: integer; sp: addrec; len: shortint; i: shortint; begin modptr := newmods; lastptr := NIL; {reverse the pointers} while modptr <> NIL do with modptr^ do minindex: shortint; modptr: moddescptr; len, i: integer; done: boolean; strptr, newstrptr: addrec; begin slist := lowheap.slp; listlen := 0; modptr := newmods; while modptr <> NIL do with modptr^ do begin nextptr := link; link := lastptr; lastptr := modptr; modptr := nextptr; end; newmods := lastptr; startgvr.p := NIL; startgvrmod := NIL; modptr := newmods; totalpatchspace := 0; forwardpatches:=NIL; backwardpatches:=NIL; begin if not patchmod then if not resolved then begin listlen := listlen + 1; gbytes(sptr.a, sizeof(sortdesc)); with sptr.sdp^ do begin modp := modptr; N := 0; end; end; modptr := link; end; gbytes(ilist.a, mrbase := startreloc; mgbase := startglobal; while modptr <> NIL do with modptr^ do begin if patchmod then begin patchbase := mrbase; mrbase := mrbase + patchsize; totalpatchspace := totalpatchspace + patchsize; i listlen * sizeof(shortint)); for i := 1 to listlen do ilist.ilp^[i] := i-1; sortlen := listlen; gbytes(newexttable, 8); newextsize := 8; while listlen > 0 do begin while sortlen > 0 do with slist^[ilist.ilp^[sortlen]], modp^ do bef forwardpatches = NIL then forwardpatches := modptr else lastptr^.patchlink := modptr; lastptr := modptr; end else with directory.drp^ do begin relocbase := mrbase; relocdelta := mrbase - relocatablebase; mrbasegin done := false; repeat if N >= listsize then begin listlen := listlen - 1; for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1]; done := true; end else if listaddr^[N] = 0 then N := N + 1 else begi*     rptr.syp^) mod 4; gbytes(newstrptr.a, len); fastmove(strptr.p, newstrptr.p, len); i := 1; done := false; repeat with slist^[ilist.ilp^[i]], modp^ do if ext^ = newstrptr.syp^ then begin wordrecptr(ext)^.w := newextsize; unr begin lastptr.a := lasttextrec.a + sizeof(textdescriptor); newptr.a := newtextrec.a + sizeof(textdescriptor); merged := gvrequal(lastptr, newptr, lasttextrec.tdp^.textsize ); end else merged := false; if merged then esbits.bmp^[listaddr^[N] div 4] := true; N := N + 1; i := i + 1; done := i > listlen; end else done := true; until done; sortlen := i-1; newextsize := newextsize + len; end; end; if newextsize <= 8 then newextsize : begin lasttextrec.tdp^.textsize := lasttextrec.tdp^.textsize + newtextrec.tdp^.textsize; lowheap := newtextrec; end else begin newtextrecs := newtextrecs + 1; lasttextrec := newtextrec; end; end; end; be= 0; end; function gvrequal(a,b: addrec; offset: integer): boolean; var boff, aoff: integer; b0: gvrptr; begin gvrequal := false; b0 := b.gvp; with a.gvp^ do if primarytype = b0^.primarytype then begin if longoffset then a.a :=gin {makedir} gbytes(tempdirptr.a, sizeof(moduledirectory)); if newmodname.syp=NIL then begin gbytes(newmodname.a, 2); newmodname.syp^ := ''; end else begin len := strlen(newmodname.syp^) + 2 - ord(odd(strlen(newmodname.syp^)));  a.a + 4 else a.a := a.a + 2; if b0^.longoffset then b.a := b.a + 4 else b.a := b.a + 2; if valueextend then begin aoff := a.vep^.value; a.a := a.a + sizeof(valueextension, sint); end else aoff := 0;  gbytes(index, len); fastmove(newmodname.p, point(index), len); end; if startgvr.p<>NIL then begin oldptr := startgvr; ptr := lowheap; makenewgvr(oldptr, startgvrmod); compressgvr(ptr); end; lasttextrec.tdp := NIL; if b0^.valueextend then begin boff := b.vep^.value; b.a := b.a + sizeof(valueextension, sint); end else boff := 0; if aoff + offset = boff then if primarytype = general then begin while (a.rpp^.w = b.rpp^.w)  newtextrecs := 0; modptr := newmods; while modptr <> NIL do with modptr^ do begin if patchmod then begin gbytes(newtextrec.a, sizeof(textdescriptor)); newtextrec.tdp^.textsize := patchsize; gbytes(oldptr.a, sizeof(gener and (a.rpp^.last = false) do begin a.a := a.a + sizeof(referenceptr); b.a := b.a + sizeof(referenceptr); end; gvrequal := a.rpp^.w = b.rpp^.w; end else gvrequal := true; end; end; procedure makedir; var modptr: moalvalue, false)); with oldptr.gvp^ do begin primarytype := relocatable; datasize := sint; patchable := false; longoffset := false; if patchbase = 0 then begin valueextend := false; short := 2; end else begin gbytes(newptr, ddescptr; newtextrec, lasttextrec: addrec; len: shortint; extblocks, newtextrecs, movebytes, textrecs : integer; index, newptr: address; tempdirptr, oldindex, sizeof(valueextension, sint)); veptr(newptr)^.value := patchbase; valueextend := true; short := 6; end end; mergetext; end else with directory.drp^ do begin oldindex.a := directory.a + sizeof(moduledirectory) oldptr, ptr: addrec; procedure mergetext; var merged: boolean; lastptr, newptr: addrec; begin if newtextrec.tdp^.textsize = 0 then lowheap := newtextrec else begin if lasttextrec.tdp <> NIL then ; oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 - ord(odd(strlen(oldindex.syp^))); if executable then oldindex.a := oldindex.a + oldindex.gvp^.short; textrecs := textrecords; while textrecs > 0 do with oldindex.tdp^ do*     ptr: moddescptr; len, i: integer; done: boolean; strptr, newstrptr, sptr: addrec; newdeftable: address; defblocks: integer; c: char; begin slist := lowheap.slp; listlen := 0; mod list; writeln(listing,'duplicate symbol definition for: ', def.syp^); {**!!!!*} end else begin errorline; writeln('duplicate symbol: ',def.syp^); if streaming then escape(119); write('Presptr := newmods; while modptr <> NIL do with modptr^ do begin if not patchmod then if defsize > 0 then begin listlen := listlen + 1; gbytes(sptr.a, sizeof(sortdesc)); with sptr.sdp^ do begin modp := modptr; def := defadds ''C'' to continue, any other key to abort ',cteol); read(keyboard,c); if (c <> 'C') and (c <> 'c') then escape(119); fgotoxy(output, 0, 22); writeln(cteol); write('LINKING ...', cteol); end; def.a := def. begin gbytes(newtextrec.a, sizeof(textdescriptor)); if odd(textsize) then textsize := textsize + 1; newtextrec.tdp^.textsize := textsize; oldindex.a := oldindex.a + sizeof(textdescriptor); ptr := lowheap; makenewgvr(oldindex, modptr); compressgvr(pr; end; end; modptr := link; end; gbytes(ilist.a, listlen * sizeof(shortint)); for i := 1 to listlen do ilist.ilp^[i] := i-1; sortlen := listlen; newdeftable := lowheap.a; while listlen > 0 do begin while sortlen > 0 do wtr); mergetext; textrecs := textrecs - 1; end; end; modptr := link; end; with tempdirptr.drp^ do begin date := todaysdate; revision := linkerdate; producer := 'L'; systemid := 3; notice := copyright; directorith slist^[ilist.ilp^[sortlen]], modp^ do begin done := false; repeat if def.a >= defaddr.a + defsize then begin listlen := listlen - 1; for i := sortlen to listlen do ilist.ilp^[i] := ilist.ilp^[i+1]; done := true; end ysize := lowheap.a - tempdirptr.a; {modulesize := } executable := (startgvr.p <> NIL); relocatablesize := totalreloc; relocatablebase := startreloc; globalsize := totalglobal; globalbase := startglobal; {extblock :=} {extsize  else begin len := strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^))); with gvrptr(def.a+len)^ do if patchable then def.a := def.a + len + short else begin i := sortlen; minindex := ilist.ilp^[i]; repeat if i >= list:=} {defblock := } {defsize := } sourceblock := 0; {implement later} sourcesize := 0; textrecords := newtextrecs; nextblock := (directorysize +(blocksize-1)) div blocksize; extblock := nextblock; extsizelen then done := true else if def.syp^ <= slist^[ilist.ilp^[i+1]].def.syp^ then done := true else begin ilist.ilp^[i] := ilist.ilp^[i+1]; i := i + 1; end; until done; ilist.ilp^[i] := minindex; end; end until done;  := newextsize; extblocks := (newextsize + (blocksize-1)) div blocksize; blockwrite(outfile,point(newexttable)^,extblocks,outblock+nextblock); nextblock := nextblock + extblocks; {lowheap.a := newdirectory.a + directorysize; fastmove(sortlen := sortlen - 1; end; if listlen > 0 then begin with slist^[ilist.ilp^[1]] do begin strptr := def; len := strlen(strptr.syp^) + 2 - ord(odd(strlen(strptr.syp^))); gbytes(newstrptr.a, len); fastmove(strptr.p, newstrptr.p, ltempdirptr.p, newdirectory.p, directorysize); } newdirectory := tempdirptr; end; end; procedure mergedefs; var slist: sortlistptr; ilist: addrec; listlen: shortint; sortlen: shortint; minindex: shortint; moden); def.a := strptr.a + len; makenewgvr(def, modp); end; i := 2; done := false; repeat with slist^[ilist.ilp^[i]], modp^ do if i > listlen then done := true else if def.syp^ = newstrptr.syp^ then begin if printeron then begin +     a + strlen(def.syp^) + 2 - ord(odd(strlen(def.syp^))); def.a := def.a + def.gvp^.short; i := i + 1; end else done := true; until done; sortlen := i-1; end; end; with newdirectory.drp^ do begin defblock := nextblorelative block index into new text} textoutsize, {number of bytes processed into new text} refbufblocks, {maximum blocks allocated for ref buffer} refinblock, {file relative block index into old ref table} refinsize, ck; if defsout then defsize := lowheap.a - newdeftable else defsize := 0; defblocks := (defsize + (blocksize-1)) div blocksize; if defblocks > 0 then blockwrite(outfile,point(newdeftable)^,defblocks,outblock+nextblock); nextblock : {number of bytes left to read from old ref} refoutblock, {file relative block index into new ref table} refoutsize: {number of bytes processed into new ref table} integer; procedure starttext; begin if not merging th= nextblock + defblocks; end; lowheap.slp := slist; end; procedure copytext; var patchptr: patchdescptr; loadaddr,loadaddr0: address; modptr: moddescptr; {current module being loaded} gvrp: gvrpten with newindex.tdp^ do begin textstart := nextblock; textoutblock := nextblock + outblock; nextblock := nextblock + (textsize + (blocksize - 1)) div blocksize; refoutblock := nextblock + outblock; textoutsize := 0; textr; patching, merging: boolean; {whether text records are combined} textbuffer, {base of text record buffer} textbuftop, {end of text record buffer} textindex, {pointer to next space availableindex := textbuffer; refoutsize := 0; outrefindex := refbuffer; offsetbytes := 0; object := textbuffer; valptr.a := newindex.a + sizeof(textdescriptor); patching := (valptr.gvp^.primarytype = relocatable) and (totalp in text buffer} object, {object in text record being modified by ref record} refbuffer, {base of ref table buffer} refbuftop, {end of ref table buffer} outrefindex, {pointer to next space available inatchspace > 0); if patching then if valptr.gvp^.valueextend then begin valptr.a := valptr.a + sizeof(generalvalue, false); loadaddr0 := valptr.vep^.value; end else loadaddr0 := 0; loadaddr := object.a - loadaddr0; ref buffer} inrefindex, {pointer to next record in ref buffer to process} newptr, {base of new gvr on heap} valptr, {value extension in new gvr on heap} oldindex, {pointer to old text descriptors} end; end; procedure endtext; var lastblocks: integer; td: addrec; org: integer; begin with newindex.tdp^ do begin merging := (textoutsize < textsize); if not merging then begin if textindex.a > textbuffer newindex: {pointer to new text descriptors} addrec; vevalue, newbytes, {size of new gvr on heap} offsetbytes, {distance from last object referenced by new refs} oldtextrec, {text records left to pr.a then begin lastblocks := (textindex.a-textbuffer.a+(blocksize-1)) div blocksize; blockwrite(outfile, textbuffer.p^, lastblocks, textoutblock); end; if outrefindex.a > refbuffer.a then begin lastblocks := (outrefindex.a - refbuffer.a + (blockocess from old module} textbufblocks, {maximum blocks allocated for text buffer} textinblock, {file relative block index into old text} textinsize, {number of bytes left to read from old text} textoutblock, {file size-1)) div blocksize; blockwrite(outfile, refbuffer.p^, lastblocks, refoutblock); end; refstart := nextblock; refsize := refoutsize; nextblock := nextblock + (refoutsize + (blocksize - 1)) div blocksize; newindex.a := newindex.a + +     e := textinsize - readbytes; textindex.a := textindex.a + readbytes; end; end; end; procedure dumprefs; var writebytes, writeblocks: integer; begin writeblocks := (outrefindex.a - refbuffer.a) div blocksize; writebytes : := 0; newbytes := lowheap.a - newptr.a; if outrefindex.a + newbytes > inrefindex.a then dumprefs; fastmove(newptr.p, outrefindex.p, newbytes); outrefindex.a := outrefindex.a + newbytes; refoutsize := refoutsize + newbytes; lowheap := newptr; = writeblocks * blocksize; blockwrite(outfile, refbuffer.p^, writeblocks, refoutblock); refoutblock := refoutblock + writeblocks; outrefindex.a := outrefindex.a - writebytes; fastmove(point(refbuffer.a + writebytes), refbuffer.p, outr end; {putref} procedure patcherror(dsize: datatype); procedure printmessage(var f: text); var index: addrec; begin index.a := modptr^.directory.a+sizeof(moduledirectory); write(f, 'Can''t patch byte ', object.a - loadaddr - loasizeof(textdescriptor); org := 0; gvrstring(newindex.gvp,org,false,true); if printeron then begin list; writeln(listing, '(load record: size = ',textsize:1,', load address = ',gvaluestring, ')'); end; end; efindex.a - refbuffer.a); end; procedure checkinref; const maxrefsize = 254; var refinbytes, readbytes: integer; begin refinbytes := refbuftop.a - inrefindex.a; if refinbytes < maxrefsize then begin if refinsize > 0 then end; end; procedure dumptext(writebytes: integer); var writeblocks: integer; begin writeblocks := writebytes div blocksize; writebytes := writeblocks * blocksize; blockwrite(outfile, textbuffer.p^, writeblocks, textoutblock);  repeat if outrefindex.a > refbuffer.a + blocksize then readbytes := inrefindex.a - (outrefindex.a + blocksize) else readbytes := inrefindex.a - (refbuffer.a + (2 * blocksize)); if refinsize <= readbytes then readbytes := refinsize else if outre textoutblock := textoutblock + writeblocks; textindex.a := textindex.a - writebytes; object.a := object.a - writebytes; loadaddr := loadaddr - writebytes; fastmove(point(textbuffer.a + writebytes), textbuffer.p, textindex.a - textbuffindex.a - refbuffer.a < readbytes then readbytes := readbytes - readbytes mod blocksize else begin dumprefs; readbytes := 0; end; if readbytes > 0 then begin fastmove(inrefindex.p, point(inrefindex.a - readbytes), refinbytes); inrefer.a); end; procedure checktextbuf(obsize: integer); var readbytes, writebytes: integer; begin while textindex.a < object.a + obsize do begin readbytes := textbuftop.a - textindex.a; if textinsize <= readbytes then readbytes :findex.a := inrefindex.a - readbytes; readblocks(modptr^.filefib.fbp^, point(inrefindex.a + refinbytes)^, readbytes, refinblock); refinblock := refinblock + readbytes div blocksize; refinsize := refinsize - readbytes; end; until readbyt= textinsize else begin if object.a < textindex.a then writebytes := object.a - textbuffer.a else writebytes := textindex.a - textbuffer.a; if writebytes < readbytes then readbytes := readbytes - readbytes mod blocksize es > 0; end; end; procedure putref; var newbytes: shortint; valptr: addrec; begin compressgvr(newptr); with newptr.gvp^ do if longoffset then long := offsetbytes else if offsetbytes < 256 then short := offsetbytes elselse begin dumptext(writebytes); readbytes := 0; end; end; if readbytes > 0 then begin readblocks(modptr^.filefib.fbp^, textindex.p^, readbytes, textinblock); textinblock := textinblock + readbytes div blocksize; textinsize begin valptr.a := newptr.a + sizeof(generalvalue,false); moveright(valptr.p^, point(valptr.a + 2)^, lowheap.a - valptr.a); lowheap.a := lowheap.a + 2; longoffset := true; long := offsetbytes; end; offsetbytes,     daddr0:1, ' in text record ',oldtextrec:1, ' of module ',index.syp^); end; begin errors := errors + 1; errorline; printmessage(output); if printeron then begin list; write(listing, '*** ERROR *** '); printmessage(listing); st then patchmodptr := backwardpatches else patchmodptr := forwardpatches; while (patchmodptr <> NIL) and (patchstate < oldpatch) do with patchmodptr^ do begin patchaddr := patchbase; patchptr := patchlist; while (patchptr<>writeln(listing); end else escape(128); end; procedure makepatch; var r, rptr: addrec; objectaddr: address; patchaddr: address; foundpatchmodptr, patchmodptr: moddescptr; foundlastpptr, lastpatchptr, NIL) and (patchstate < oldpatch) do with patchptr^ do begin patchdelta := patchaddr-objectaddr; if (-32768<=patchdelta) and (patchdelta<32768) then if gvrequal(newptr,patchref,0) then begin object.sw^ := patchdelta;  patchptr: patchdescptr; patchdelta, delta2,foundpatchdelta: integer; patchstate: (nopatch,longpatch,shortpatch, oldpatch); backwardlist: boolean; begin objectaddr := object.a - loadaddr; with valptr.vep^ do value  lowheap := newptr; patchstate := oldpatch; end; if patchref.gvp^.datasize = sword then patchaddr := patchaddr + 4 else patchaddr := patchaddr + 6; lastpatchptr := patchptr; patchptr := patchlist; en:= value + object.sw^ + objectaddr; with newptr.gvp^ do begin patchable := false; if primarytype = absolute then primarytype := relocatable else begin if primarytype <> general then begin gbytes(rptr.a, sizeof(referenceptrd; patchdelta := patchaddr-objectaddr; if (patchstate < shortpatch) then if (-32768<=patchdelta) and (patchdelta<32768) then begin if patchsize - (patchaddr - patchbase) >= 4 then if newptr.gvp^.primarytype = relocatable then)); with rptr.rpp^ do begin adr := 0; op := addit; last := false; end; gbytes(rptr.a, sizeof(referenceptr)); with rptr.rpp^ do begin adr := ord(primarytype)-1; op := addit; last := true; end; primarytype := gene begin delta2 := valptr.vep^.value - (patchaddr+2); if (-32768 <= delta2) and (delta2 < 32768) then if object.a + patchdelta >= textbuffer.a then begin patchstate := shortpatch; foundpatchdelta := patchdelta; foundlastpptr := lastpral; short := short + 4; end else begin rptr.a := valptr.a + sizeof(valueextension,sint); with rptr.rpp^ do if (adr=0) and (op=subit) then if last then begin primarytype := absolute; lowheap := rptr; short atchptr; foundpatchmodptr := patchmodptr; end; end; if (patchstate < longpatch) and not backwardlist then if patchsize - (patchaddr - patchbase) >= 6 then begin patchstate := longpatch; foundpatchdelta := patchdelta; foundlastpptr:= short - 2; end else begin moveleft(point(rptr.a+2)^,rptr.p^, short-(valptr.a-newptr.a)-6); lowheap.a := lowheap.a - sizeof(referenceptr); short := short - 2; end else begin gbytes(r.a, sizeof(referenceptr));  := lastpatchptr; foundpatchmodptr := patchmodptr; end; end; patchmodptr := patchlink; end; end; if patchstate = nopatch then patcherror(newptr.gvp^.datasize) else if patchstate < oldpatch then with foundpatchmodptr^ do bmoveright(rptr.p^,point(rptr.a+2)^, short-(valptr.a-newptr.a)-4); adr := 0; op := addit; last := false; short := short + 2; end; end; end; end; patchstate := nopatch; for backwardlist := false to true do begin if backwardliegin gbytes(r.a, sizeof(patchdescriptor)); if patchlist = NIL then patchlist := r.pdp else foundlastpptr^.patchlist := r.pdp; with r.pdp^ do begin patchlist := NIL; patchref := newptr; if patchstate = longpatch then newp,     n list; writeln(listing, '(patch space)', patchsize:29,patchbase:10); end; starttext; patchptr := patchlist; while patchptr <> NIL do with patchptr^, patchref.gvp^ do begin if textbuftop.a - textindex.a < 6 then dumptext(textindex.backwardpatches := modptr; end else with directory.drp^ do begin oldindex.a := directory.a + sizeof(moduledirectory); if printeron then begin list; writeln(listing, oldindex.syp^, '':32-strlen(oldindex.syp^), relocatablesiza - textbuffer.a); if printeron then begin list; gvrp := patchref.gvp; vevalue := 0; gvrstring(gvrp, vevalue, false, true); end; if valueextend then begin if longoffset then valptr.a := patchref.a +sizeof(generalvalue,true) else valpe:10,relocbase:10, globalsize:10, globase:10); end; oldindex.a := oldindex.a + strlen(oldindex.syp^) + 2 - ord(odd(strlen(oldindex.syp^))); if executable then oldindex.a := oldindex.a + oldindex.gvp^.short; for oldtextrec :tr.gvp^.datasize := sint else begin newptr.gvp^.datasize := sword; if foundpatchdelta < 0 then begin r.a := object.a + foundpatchdelta; r.uw^.w := 24576 {BRA pc relative}; r.a := r.a + 2; r.sw^ := delta2; if printeron thetr.a := patchref.a +sizeof(generalvalue,false); vevalue := valptr.vep^.value; end else vevalue := 0; if datasize = sword {PC relative branch} then begin if printeron then writeln(listing, ' BRA ',gvaluestring, '':26-strlen(gvaluen begin list; write(listing, '(backward patch) BRA '); gvrp := patchref.gvp; vevalue := 0; gvrstring(gvrp, vevalue, false, true); writeln(listing, gvaluestring, '':20-strlen(gvaluestring), r.a-2-loadaddr:10); end;string), object.a-loadaddr:20); object.uw^.w := 24576 {BRA pc relative}; object.a := object.a + 2; object.sw^ := vevalue - (object.a - loadaddr); object.a := object.a + 2; offsetbytes := offsetbytes + 4; end else {long absolute branch}  end; end; end; object.sw^ := foundpatchdelta; end; end; begin {procedure copytext} {estimate data structures at 3/2(totalpatchspace) + 1/4(workspace) } textbufblocks := ((highheap.a - lowheap.a) * 3 - totalpatchspace  begin if printeron then writeln(listing, ' JMP ', gvaluestring, '':26-strlen(gvaluestring), object.a-loadaddr:20); object.uw^.w := 20217 {JMP long absolute}; object.a := object.a + 2; object.si^ := vevalue; object.a := object. * 6 ) div (blocksize * 4); refbufblocks := textbufblocks div 4; if refbufblocks < 4 then refbufblocks := 4; textbufblocks := textbufblocks - refbufblocks; if textbufblocks < 3 then textbufblocks := 3; gbytes(textbuffer.a, textbufblocks *a + 4; gbytes(newptr.a, short); fastmove(patchref.p, newptr.p, short); if valueextend then begin valptr.a := newptr.a + (valptr.a - patchref.a); valptr.vep^.value := 0; end; offsetbytes := offsetbytes + 2; putref; offs blocksize); textbuftop := lowheap; gbytes(refbuffer.a, refbufblocks * blocksize); refbuftop := lowheap; newindex.a := newdirectory.a + sizeof(moduledirectory); newindex.a := newindex.a + strlen(newindex.syp^) + 2 - ord(odd(strlen(newindexetbytes := 4; end; textindex := object; patchptr := patchlist; end; object.a := textindex.a + patchsize - (object.a - loadaddr - patchbase); while textindex.a < object.a do begin if textindex.a >= textbuftop.a - 2 then dumptext(texti.syp^))); if newdirectory.drp^.executable then newindex.a := newindex.a + newindex.gvp^.short; merging := false; modptr := newmods; while modptr <> NIL do with modptr^ do begin if patchmod then begin if printeron then begindex.a - textbuffer.a); textindex.sw^ := -1; textindex.a := textindex.a + 2; offsetbytes := offsetbytes + 2; end; textoutsize := textoutsize + patchsize; endtext; forwardpatches := patchlink; patchlink := backwardpatches; -     = 1 to textrecords do begin if oldindex.tdp^.textsize > 0 then begin starttext; loadaddr0 := object.a - loadaddr; with oldindex.tdp^ do begin refinsize := refsize; textinsize := textsize; refinblock := fileblock+refstart; t; {with gvrptr(newptr)^, valptr^} end; {while there are any ref's } newbytes := textindex.a + textinsize - object.a; offsetbytes := offsetbytes + newbytes; object.a := object.a + newbytes; checktextbuf(0); endtext; end; oldindex.a := oldextinblock := fileblock+textstart; textoutsize := textoutsize + textsize; end; inrefindex := refbuftop; while (refbuftop.a - inrefindex.a) + refinsize > 0 do begin checkinref; newptr := lowheap; with inrefindex.gvp^ do if longoffindex.a + sizeof(textdescriptor); oldindex.a := oldindex.a + oldindex.gvp^.short; end; {for oldtextrec} end; {with directory^ do} modptr := link; end; end; {copytext} procedure printdirectentry(modnum: shortint; var entry: direset then begin newbytes := long; valptr.a := newptr.a + sizeof(generalvalue, true); end else begin newbytes := short; valptr.a := newptr.a + sizeof(generalvalue, false); end; object.a := objecntry); begin with entry do begin upc(dtid); list; write(listing, modnum:4,' ',dtid, dlastblk-dfirstblk:21-strlen(dtid),' '); writedate(listing, daccess); writeln(listing, dfirstblk:7); end; end; procedure bootmod(modnum: shortint); const set.a + newbytes; offsetbytes := offsetbytes + newbytes; makenewgvr(inrefindex, modptr); with newptr.gvp^, valptr.vep^ do begin case datasize of {$range off$} sbyte: begin checktextbuf(sizeof(sbyterec)); value := valctorsize = 256; var buffer, bufptr, valptr, ptr, endrefs, mname, infostart: addrec; object, recordnum: integer; procedure writesector(anyvar f: fib; anyvar obj: window; size,sector: integer); begin call (f.am, addr(f), writebytes, obj, size,ue + object.sb^.sb; object.sb^.sb := value; value := value - object.sb^.sb; end; sword: begin checktextbuf(sizeof(shortint)); value := value + object.sw^; object.sw^ := value; value := value - object.sw^;  sector * sectorsize); if ioresult <> 0 then escape(114); end; begin infostart := lowheap; loadinfo(modnum,true, true); with newmods^,directory.drp^ do begin if extsize > 8 then escape(120); mname.a := directory.a + sizeof(moduledirect end; sint: begin checktextbuf(sizeof(integer)); object.si^ := object.si^ + value; value := 0; end; ubyte: begin checktextbuf(sizeof(ubyterec)); value := value + object.ub^.ub; object.ub^.ub := value; value ory); ptr.a := mname.a + strlen(mname.syp^) + 2 - ord(odd(strlen(mname.syp^))); if executable then with ptr.gvp^, fibp(addr(outfile))^ do begin if fstartaddress = 0 then if valueextend then begin valptr.a := ptr.a + sizeof(genera := value - object.ub^.ub; end; uword: begin checktextbuf(sizeof(wordrec)); value := value + object.uw^.w; object.uw^.w := value; value := value - object.uw^.w; end; {$range on$} otherwise escape(111); lvalue,false); fstartaddress := valptr.vep^.value; end; ptr.a := ptr.a + short; end; recordnum := 0; while textrecords > 0 do with ptr.tdp^ do begin recordnum := recordnum + 1; if refsize > 0 then {check to end; {case datasize} if primarytype = absolute then begin if value <> 0 then if patchable and patching then makepatch else patcherror(datasize); end else if patching and patchable then makepatch else putref; end make sure code is "absolute"} begin gbytes(buffer.a, refsize); readblocks(filefib.fbp^,buffer.p^,refsize,fileblock+refstart); bufptr := buffer; endrefs.a := buffer.a + refsize; object := 0; while bufptr.a < endrefs.a do with bufptr.gvp^ do begin -     osize+ord(odd(fosize)); var startblock, numblocks, transblocks: {shortint} INTEGER; {SFB} copybuffer: addrec; bufblocks: {shortint} INTEGER; {SFB} begin if booting then bootmod(modnum) else if linking then begin if loadfib.a > strlen(dtid) > fnlength then setstrlen(dtid, fnlength); dlastbyte := 256; daccess := todaysdate; end; {if printeron then printdirectentry(outmodnum, outdirectory.fdp^[outmodnum]); } end; procedure trim(var s: string); var first, last: short= highheap.a then begin fastmove(highheap.p, lowheap.p, fsize); highheap.a := highheap.a + fsize; lowheap.a := lowheap.a + fsize; loadfib.a := loadfib.a - (highheap.a - lowheap.a); end; loadinfo(int; begin last := strlen(s); while last > 0 do begin if s[last] = ' ' then begin last := last - 1; if last = 0 then s := ''; end else begin first := 1; while s[first] = ' ' do first := first + 1; s := str(s, first, if longoffset then begin object := object + long; bufptr.a := bufptr.a + sizeof(generalvalue, true); end else begin object := object + short; bufptr.a := bufptr.a + sizeof(generalvalue, false); end; if valuemodnum, true, true) end else begin bufblocks := (highheap.a -lowheap.a) div blocksize; gbytes(copybuffer.a, bufblocks * blocksize); if outmodnum>=maxmodules then escape(127); outmodnum := outmodnum + 1; outdirectory.fdp^[outmodnum] := fextend then begin errorline; write ('Can''t relocate byte ',object:1, ' in record ',recordnum:1, ' of module ',mname.syp^); escape(128); end; if primarytype = general then begin while not bufptr.rpp^.last directory^[modnum]; with fdirectory^[modnum] do begin startblock := dfirstblk; numblocks := dlastblk-startblock; end; with outdirectory.fdp^[outmodnum] do begin dfirstblk := outblock; dlastblk := outblock + numblocks; do bufptr.a := bufptr.a + sizeof(referenceptr); bufptr.a := bufptr.a + sizeof(referenceptr); end; end; lowheap := buffer; end; gbytes(buffer.a, sizeof(integer)); ptr.a := ptr.a + sizeof(textdescriptor); with ptr.gvp^ end; while numblocks > 0 do begin if numblocks <= bufblocks then transblocks := numblocks else transblocks := bufblocks; readblocks(loadfib.fbp^, copybuffer.p^, transblocks*blocksize, startblock); blockwrite(outfile, copybuffer do begin if valueextend then begin valptr.a := ptr.a + sizeof(generalvalue,false); buffer.p^ := valptr.vep^.value; end else buffer.p^ := 0; ptr.a := ptr.a + short; end; gbytes(bufptr.a, sizeof(integer)); bufptr.p^ := textsize.p^, transblocks, outblock); startblock := startblock + transblocks; outblock := outblock + transblocks; numblocks := numblocks - transblocks; end; lowheap := copybuffer; {if printeron then printdirectentry(outmodnum, outdirectory.f; gbytes(bufptr.a, textsize); readblocks(filefib.fbp^,bufptr.p^,textsize,fileblock+textstart); writesector(outfile, buffer.p^, textsize+2*sizeof(integer), outblock); outblock := outblock + (textsize + 2*sizeof(integer) + (sectorsdp^[outmodnum]); } end; end; procedure writedirectory; begin with newdirectory.drp^ do begin modulesize := nextblock * blocksize; blockwrite(outfile, newdirectory.drp^, extblock, outblock); end; if outmodnum>=maxmodules then escape(127)ize-1)) div sectorsize; lowheap := buffer; textrecords := textrecords - 1; end; end; lowheap := infostart; newmods := NIL; end; procedure copymodule(modnum: shortint); const fosize = sizeof(addrec)+sizeof(fib,1); fsize = f; outmodnum := outmodnum + 1; with outdirectory.fdp^[outmodnum] do begin dfirstblk := outblock; outblock := outblock + nextblock; dlastblk := outblock; dfkind := codefile; moveleft(newmodname.syp^, dtid, sizeof(filname)); if.      last - first + 1); last := 0; end; end; end; procedure toggleprinter; var newlistname: string80; fvid: vid; ftitle: fid; fsegs: integer; fkind: filekind; begin printeron := not printeron; if printeron then begin fgotoxy(o.syp = NIL then write(listing, '(no name)', '':32-9) else write(listing, newmodname.syp^, '':32-strlen(newmodname.syp^)); writeln(listing, totalreloc:10, totalglobal:20); listln; end; closein; closefiles; lowheap := infostart; {release memorutput, 13,3); write(' ',cteol); readln(newlistname); fixname(newlistname, textfile); if scantitle(newlistname, fvid, ftitle, fsegs, fkind) then ; { jws 3/2/84} if strlen(newlistname)>0 then begin listfilename := newlistname; if fsegy used by linker} linking := false; newmods := NIL; if errors > 0 then escape(122); end; {link} procedure printdirectory; var numfiles: shortint; modnum: shortint; begin list; writeln(listing, 'FILE DIRECTORY OF: ''', loadfib.fbp^.ftids=0 then { jws 3/2/84 } sappend(newlistname, '[*]'); pageeject; if (pagenum=0) and (linenum=0) then close(listing) else close(listing, 'lock'); rewrite(listing, newlistname); pagen, ''''); listln; numfiles := fdirectory^[0].dnumfiles; for modnum := 1 to numfiles do printdirectentry(modnum, fdirectory^[modnum]); listln; end; procedure copyfile; var modnum: shortint; begin for modnum := 1 to fdirectory^[0].dnumfiles do um := 0; linenum := 0; printopen := ioresult = 0; printeron := printopen; if not printopen then escape(118); end else printeron := printopen; end; end; procedure copyon; begin lowheap := infostart; linking := false; end; procecopymodule(modnum); closein; end; procedure verifynext; begin if vmodnum < fdirectory^[0].dnumfiles then begin vmodnum := vmodnum + 1; upc(fdirectory^[vmodnum].dtid) end else begin vmodnum := 0; verifying := false; end; end; procedure dure closein; begin if fdirectory <> NIL then begin if loadfib.a >= highheap.a then begin close(loadfib.php^); loadfib.a := loadfib.a - sizeof(addrec); loadfib := loadfib.arp^; end; highheap := highheap0; fdirectory := NIL; vverifymod; begin vmodnum := 0; verifying := true; verifynext; end; procedure xfer; var modnum: shortint; begin if verifying then begin copymodule(vmodnum); verifynext; end else begin for modnum := 1 to fdirectory^[0].dnumfiles do wmodnum := 0; verifying := false; end; end; procedure initlink; begin linking := true; defsout := true; infostart := lowheap; newmodname.syp := NIL; startreloc := 0; startglobal := 0; copyright := ''; end; procedure link; begin errors ith fdirectory^[modnum] do begin upc(dtid); if dtid = fdirectory^[vmodnum].dtid then copymodule(modnum); end; vmodnum := 0; end; end; procedure openin; const fosize = sizeof(addrec)+sizeof(fib,1); fsize = fosize+ord(odd(fo:= 0; fgotoxy(output, 0,23); write('LINKING ...'); rsolve; if printeron then begin list; writeln(listing, 'link map', 'Rsize':34, 'Rbase':10, 'Gsize':10, 'Gbase':10); list; writeln(listing, '------':42, '------':10, '------':10, '------':10); size)); begin closein; fgotoxy(output, 22,13); write(cteol); if strlen(infilename)=0 then { if no name then get it } begin readln(infilename); fixname(infilename, codefile); end; if strlen(infilename) > 0 then begin openlinkfile(infilename);  end; newdirectory := lowheap; mergeexts; makedir; {also write new ext table, move down directory} mergedefs; copytext; writedirectory; if printeron then begin list; writeln(listing, '------':42,'------':20); list; if newmodname if fdirectory = NIL then begin errorline; write('cannot open ''', infilename, ''', '); ioerror; end else begin highheap.a := highheap.a - fsize; lowheap.a := lowheap.a - fsize; fastmove(lowheap.p, highheap.p, fsize); loadfib.a := loa.     left(outfilename, dvid, sizeof(volname)); if strlen(outfilename) > vnlength then setstrlen(dvid, vnlength); deovblk := outdirectsize; dnumfiles := 0; dloadtime := 0; dlastboot := todaysdate; end; outblock := outdirectsize; ofying := false; vmodnum := 0; fgotoxy(output, 18,18); write(cteol); readln(s); trim(s); if strlen(s) > 0 then begin upc(s); i := 1; while (i <= fdirectory^[0].dnumfiles) and (vmodnum = 0) do with fdirectory^[i] do begin utopen := true; end; end; if outopen then booting := boot else begin booting := false; errorline; write('cannot open ''', outfilename, ''', '); ioerror; end; end; end; { openout } procedure setmaxmodules; var total, exces upc(dtid); if s = dtid then vmodnum := i else i:= i + 1; end; if vmodnum = 0 then begin errorline; write('module ''', s,''' not found in file'); escape(123); end; end; end; {openmod} procedure findmod(var s:fidfib.a + (highheap.a - lowheap.a); if fdirectory^[0].dnumfiles = 1 then vmodnum := 1 else verifymod; end; end; end; { openin } procedure closeout; begin closein; with outdirectory.fdp^[0] do begin deovblk := outblock; dnumfiles :=s: integer; begin fgotoxy(output, 30,6); write(cteol); if readint(maxmodules) then begin if maxmodules > 300000 then begin maxmodules := 38; escape(125); end; if maxmodules <= 0 then maxmodules := 0; outdirectsize := ((max outmodnum; outopen := false; outmodnum := 0; lowheap := outdirectory; blockwrite(outfile, outdirectory.fdp^, outdirectsize, 0); close(outfile, 'lock'); if ioresult <> 0 then escape(126); end; end; procedure openout(boot: boolean); var i,jmodules+1)*entrysize+(blocksize-1)) div blocksize; maxmodules := outdirectsize*blocksize div entrysize - 1; end; end; procedure setreloc; begin fgotoxy(output, 21,7); write(cteol); if readint(startreloc) then ; end; procedure setglobal; begin fg: integer; nul: string[1]; typestring: string[6]; thirdparm: string[10]; begin thirdparm := 'shared'; if linking then lowheap := infostart; linking := false; if outopen then begin close(outfile); lowheap := outdirectory; end; outopotoxy(output, 21,8); write(cteol); if readint(startglobal) then ; end; procedure setcopyright; begin fgotoxy(output, 0,12); write(cteol); fgotoxy(output, 22,11); write(cteol); readln(copyright); end; procedure makepatchspace; var pmod: addreen := false; fgotoxy(output, 22,4); write(cteol); readln(outfilename); trim(outfilename); if strlen(outfilename) > 0 then begin nul := ''; if boot then begin fixname(outfilename, sysfile); reset(outfile, outfilename); close(outfile, 'PURc; begin fgotoxy(output, 23,9); write(cteol); if readint(patchbytes) then if patchbytes > 0 then begin patchbytes := patchbytes + ord(odd(patchbytes)); gbytes(pmod.a, sizeof(moduledescriptor,true)); with pmod.mdp^ do begin patchmoGE'); typestring := '.SYSTM'; fmaketype(outfile, outfilename, thirdparm, typestring); outopen := (ioresult = 0); outblock := 0; end else begin fixname(outfilename, codefile); typestring := '.CODE'; fmaketype(outfile, outfilename, thid := true; patchsize := patchbytes; link := newmods; newmods := pmod.mdp; patchlink := NIL; patchlist := NIL; end; end; end; procedure setname; var s: string80; begin fgotoxy(output, 24,6); write(cteol); readln(s); trim(s); if rdparm, typestring); if ioresult = 0 then begin gbytes(outdirectory.a, outdirectsize*blocksize); with outdirectory.fdp^[0] do begin dfirstblk := 0; dlastblk := outdirectsize; dfkind := untypedfile {volume entry}; movestrlen(s)=0 then newmodname.syp := NIL else begin upc(s); gbytes(newmodname.a, strlen(s)+2-ord(odd(strlen(s)))); moveleft(s, newmodname.syp^, strlen(s)+1); end; end; {setname} procedure openmod; var s: string80; i: shortint; begin veri/     lname; var n:shortint); var i : integer; begin if strlen(s)=0 then { if no name given then get it } begin readln(s); trim(s); end; n:= 0; if strlen(s) > 0 then begin upc(s); i := 1; while (i <= fdirectory^[0].dnumfiles) and (n = irectory^[vmodnum].dtid,cteol); if booting then lc := 'boot' else if linking then lc := 'link' else lc := 'copy'; writeln; writeln('T Transfer (',lc,') module',cteol); writeln(' to continue verifying',cteo0) do with fdirectory^[i] do begin upc(dtid); if s = dtid then n := i else i:= i + 1; end; if n = 0 then n:=-1; { signal not found } end; end; { findmod } procedure clear(N: shortint); begin repeat writeln(cteol); n :l); end; getcommandchar('Edit option?',commandchar); case commandchar of 'A':begin oldfilename:= infilename; { save current inputfile name } oldvmodnum := vmodnum; { same current module number & name } oldvmodname := fdi= n - 1; until n <= 0; end; procedure none; begin write('(none)'); clear(1); end; procedure doedit; var firstmodname,untilmodname, oldvmodname : filname; firstmodnum, untilmodnum, oldvmodnum : integer; oldfilename: string80; modlist : stringrectory^[vmodnum].dtid; fgotoxy(output,0,13); write(' Input file: ',cteol); setstrlen(infilename,0); openin; { get new input file } if strlen(infilename)>0 then begin { 3.0 BUG FIX -- 4/11/84 } { get list of modules an255; assoc : boolean; lc : string[4]; tempf : filname; im : shortint; procedure checkassoc; begin assoc:=assoc and (vmodnum>0); if assoc then begin firstmodname:=fdirectory^[vmodnum].dtid; firstmodnum:=vmodnum; assoc:=ad copy them } fgotoxy(output,0,10); writeln('enter list of modules or = for all'); readln(modlist); trim(modlist); upc(modlist); if modlist='=' then begin { all modules } for im:=1 to fdirectory^[0].dnumfiles do beginssoc and (firstmodnum<>untilmodnum); end; end; procedure outoforder; begin errorline; write('module ',tempf,' out of order'); dobeep; end; procedure mnotfound; begin errorline; write('module ',tempf,' not found'); dobeep; end; begin {  fgotoxy(output,0,11); write(fdirectory^[im].dtid,cteol); copymodule(im); end; end else while strlen(modlist)>0 do begin im:=strpos(',',modlist); if im=0 then im:=strlen(modlist)+1; try if im>sizeof(temdoedit } untilmodname := '(end of file)'; untilmodnum := fdirectory^[0].dnumfiles+1; if vmodnum=0 then firstmodname:='(none)' else firstmodname := fdirectory^[vmodnum].dtid; firstmodnum := vmodnum; assoc := true; fgotoxy(output,0,2); pf) then escape(129) else tempf:=str(modlist,1,im-1); if im>strlen(modlist) then setstrlen(modlist,0) else strdelete(modlist,1,im); if strlen(tempf)>0 then begin { find the module and copy it } findmod(tempf,vmodnum); if vwrite(cteos); repeat fgotoxy(output,0,2); writeln('S Stop editing'); clear(2); if firstmodnum>0 then writeln('C Copy First module upto Until module',cteol) else clear(1); writeln('F First module: ',firstmodname,cteol); modnum>0 then copymodule(vmodnum) else escape(123); fgotoxy(output,0,11); write(modlist,cteol); end; recover begin im:=escapecode; errorline; case im of 123: writeln('module ',tempf,' not found'); 129: writeln('invalid modu writeln('U Until module: ',untilmodname,cteol); clear(1); writeln('A Append module(s)'); clear(5); fgotoxy(output,0,18); write('M input Module: '); if vmodnum = 0 then begin none; clear(3); end else begin writeln(fdle name'); otherwise escape(im) end; { case im } dobeep; setstrlen(modlist,0); { zap module list to force exit } end;{ end recover} end; {while list not empty} if not streaming then { 3.0 bug fix -- 4/9/84 jws/     m<=untilmodnum then begin firstmodname := tempf; firstmodnum:=im; assoc:=false; end else outoforder; end; { case im } end; 'M': if fdirectory<>NIL then begin openmod; if vmodnum>0 then begin { 3.0 BUG # 57 4/10/84 } ite('L finish Linking') else if linking then write('C Copy') else write('L Link'); write(cteol); fgotoxy(output, 40,5); if booting then begin writeln('BOOTING'); lc := 'boot'; end else if linking then begin  assoc := assoc and (vmodnum to continue',commandchar); until commandchar=' '; end; { 3.0 BUG FIX -- 4/11/84 } infilename := oldfilename; openin; { reopen the old file & fin { 3.0 BUG # 57 4/10/84 } end else dobeep; 'S':; 'T': if vmodnum>0 then begin xfer; checkassoc; end else dobeep; 'U':begin fgotoxy(output,17,7); write(cteol); setstrlen(tempf,0); findmod(tempf,im); case im of d old input module } if oldvmodnum=0 then vmodnum:=0 else begin findmod(oldvmodname,vmodnum); if (vmodnum<>oldvmodnum) then begin errorline; write('unable to find old input module ',oldvmodname); vmodnum:=0; dobeep; end -1: mnotfound; 0: { no module name given, so default } begin untilmodname := '(end of file)'; untilmodnum := fdirectory^[0].dnumfiles+1; end; otherwise { found the module } if im>=firstmodnum then begin unti; end; end; 'C':if (firstmodnum>0) and (firstmodnumfirstmodnum); end; { case im } end; ' ': if vmodnum>0 then begin verifynext; checkassoc; end else dobeep; otherwise dobeep end; unbegin if untilmodnum>fdirectory^[0].dnumfiles then begin vmodnum := 0; firstmodname := '(none)'; end else begin vmodnum := untilmodnum; firstmodname := fdirectory^[vmodnum].dtid; end; firstmodnum := vmodnum;til commandchar='S'; end; {doedit} procedure finishboot; begin close(outfile, 'LOCK'); if ioresult<>0 then escape(126); outopen := false; booting := false; outmodnum := 0; end; procedure menu; var lc: string[4]; begin fgotoxy(output, 0,2); write('Q  assoc:= assoc and (vmodnum>0); end; end else dobeep; 'F':begin fgotoxy(output,17,6); write(cteol); setstrlen(tempf,0); findmod(tempf,im); case im of -1: mnotfound; 0: { no module name given, so use default } begin if (Quit'); clear(1); write('P Printout '); if printopen then begin if printeron then write('ON ') else write('OFF '); write(listfilename); clear(1); end else none; if outmodnum > 0 then write('K Keep o') else if (newmods = NIL) avmodnum>0) and (vmodnum<=untilmodnum) then begin firstmodname := fdirectory^[vmodnum].dtid; firstmodnum := vmodnum; assoc := assoc and (vmodnum NIL then wr0     ze: ',maxmodules,cteol); end; if linking and outopen then begin write('N Name of new module: '); if newmodname.syp = NIL then none else writeln(newmodname.syp^,cteol); writeln('R Relocation base: ',startreloc:12,cteol); writeln('G Glo 'H': if outopen then dobeep else setmaxmodules; 'I': begin setstrlen(infilename,0); openin; end; 'K': if (outmodnum > 0) and not booting then closeout else dobeep; 'L': if booting then dobeep else if newmods <> NIL then link else if outopenbal base: ',startglobal:12,cteol); write ('S Space for patches:'); if patchbytes > 0 then writeln(patchbytes:12) else clear(1); patchbytes := 0; write('D output Def table? '); if defsout then write('YES') else write('NO '); writeln and not linking then initlink else dobeep; 'M': if fdirectory<>NIL then openmod else dobeep; 'N': if linking and outopen then setname else dobeep; 'O': if (outmodnum = 0) and (newmods=NIL) and not booting then openout(false) else dobeep; 'P'(cteol); writeln('X copyright notice: ',copyright); end else clear(7); fgotoxy(output, 0,13); write('I Input file: '); if fdirectory = NIL then begin none; clear(7); end else begin writeln(infilename,cteol); if outopen then writ: toggleprinter; 'Q': quit; 'R': if linking and outopen then setreloc else dobeep; 'S': if linking and outopen then makepatchspace else dobeep; 'T': if (vmodnum > 0) and outopen then xfer else dobeep; 'U': if (vmodnum > 0) then unassemble eleln('E Edit') else clear(1); writeln('F list File directory'); if outopen then writeln('A ',lc,' All modules') else clear(1); write('V Verify modules'); if verifying then begin fgotoxy(output, 40,17); writeln('VERIFYING'); end elsse dobeep; 'V': if fdirectory<>NIL then verifymod else dobeep; 'X': if linking and outopen then setcopyright else dobeep; ' ': if verifying then verifynext; otherwise dobeep; end; recover begin if (escapecode <> -20) and (escapecode e clear(1); write('M input Module: '); if vmodnum = 0 then begin none; clear(3); end else begin writeln(fdirectory^[vmodnum].dtid,cteol); writeln('U Unassemble object'); if outopen then writeln('T Transfer (',lc,') module') <> 123) and (escapecode<>128) then errorline; if escapecode=-10 then begin getioerrmsg(err, ires); writeln(err); end else case escapecode of 110: write('symbols defined recursively'); 111: write('improper link info format'); 112:  else clear(1); if verifying then writeln(' to continue verifying') else clear(1); end; end; end; {menu} procedure getcommand; var err: string[80]; begin repeat try menu; getcommandchar('command?',commandchar); case commandwrite('not enough memory'); 113: write('output file full'); 114: write('error writing to boot disk, ioresult = ',ires:1); 116: write('''', infilename, ''' is not a code file'); 118: write('printer or list file not on line'); 119: write(char of 'A': if (fdirectory<>NIL) and outopen then copyfile else dobeep; 'B': if booting then finishboot else if outopen then dobeep else openout(true); 'C': if outopen and linking and (newmods = NIL) and not booting then copyon else dobeep; 'duplicate symbol definition'); 120: write('module being booted has external references'); 121: write('unexpected end of code'); 122: write(errors:1, ' errors during linking',cteol); 123,128,129: {error message already printed}; 124: wr 'D': if linking and outopen then defsout := not defsout else dobeep; 'E': if (fdirectory<>NIL) and outopen then doedit else dobeep; 'F': if fdirectory<>NIL then printdirectory else dobeep; 'G': if linking and outopen then setglobal else dobeep;ite('integer required'); 125: write('integer too large'); 126: write('unable to close output, ioresult = ',ires:1); 127: write('file header full'); otherwise escape(escapecode); end; {case escapecode} if streaming then escape(-1); 0     LH`6 n"h"i/)/) "h"i/)/) NLH+o ND,_+_pmWrmWpmWgLH?<-N.`NJ n1|* BP1| C-I"h$n%i"jLH n"hBQB`$ n"hp*i W.gD0( |m4U n/(-@N .ghJ-g ?<^N. n1|& Hh/<&N n"mh$hL?H?5i$$ n/(/N n/(/N`?<N.B.`4 .TV".TVg?<N. n!mT` n"hp*i W."hr*i Wg6"h$h)*|n,@2;N     "hJ)g4"hJf +h,` n"hpf+h,` n"h"iJQW/:/:"h"i/)/) -@N .g n+h,`H n"h"iJQW/:^/:V"h"i/)/) -@N .g n+h,`D n"hJ)g0g"h-i"h-iph f6J-lf ?<2N.pWrWp-@`l/-/HzB+O np h f .ЮNv-@` .쐮Nv-@+o N",_+_pmf?<-N.`NJ n1|* BP1| C-I"n#n`6 n (LW-lr if (escapecode-100) in [12,16] then closein; if (escapecode-100) in [10..13,19,22,26,28] then begin if newmods <> NIL then begin closein; closefiles; end; linking := false; newmods := NIL; if outopen then close(outfile); "hJf +h,` n"hpf+h,`` n"hp*i W.g0( |m|n@2;N P"hJ)g4"hJf +h,` n"hpf+h,` n"h"iJQW/:F/:>"h"i/)/) -@N .g n+h,`H outopen := false; outmodnum := 0; booting := false; lowheap := lowheap0; end; end; {recover} until commandchar = 'Q'; end {getcommand}; procedure wrapup; begin pageeject; closein; closefiles; if (pagenum=0) and (linen n"h"iJQW/:/:"h"i/)/) -@N .g n+h,` n"hJ)g"hpf+h,`H n"h"iJQW/:/:"h"i/)/) -@N .g n+h,`D n"hJ)g0"hJf +h,` n"hpf+h,`N^um=0) then close(listing) else close(listing, 'lock'); end; {wrapup} begin {program linker} with linkerdate do begin day := 28; year := 91; month := 10; end; sysdate(todaysdate); pagenum := 0; linenum := 0; fgotoxy(output, 0,0).Nu?NA n 0C22U@bHnHnHzNHn/N>p&mW-lA-g ?<^N.p&mfYN"-_=m-n0-@2;N 4& n1| `( n1| ` n1| ` n1| m,"n#h2#m,N3lHn; printheader(output); fgotoxy(output, 0, 22); writeln('Copyright Hewlett-Packard Company, 1982, 1991.'); mark(lowheap.p); lowheap0 := lowheap; highheap.a := lowheap.a + memavail - 5000; release(highheap.p); highheap0 := highheap; listfilenHnHz n0(W@m||nt@2;N<hZ,hLL n0( H/Hzh"n1i `^ n"h"iJQW/:/:"h"i/)/) -@N .g" n-h1| !n"n1i `L n"hpW"h)g +h,`" n"hJW"h)g+h,``l n"hp*i W.gT0( | mH|n@@2;Nz4444NJf ?<N.`. n0( H/HzBNJgv n"hJQW"hJQWgX=h 1|* BP|"h$h *fJnWr!A`pnW nr!A` ?<N.` n0( U@mB|n:@2;N  1| ` n1| `?<N"hJ)g"hJf+h,`H n"h"iJQW/:/:"h"i/)/) -@N .g n+h,` n"hJ)g"hJf+h,`H n"h"iJQW/:/:"h"i/)/) -@N .g n+h,`L n"hpW"h)g +h,.``>U/.Nb0Jf ?<N.`?<N.`?<N.` n"hp*i W"hr*i Wg"h$h)*gJ-lf ?<2N. n"h-i"h-i=h 1|* BP1| C-I"n0.@2;N &Db .]r#A` .`" n"hJW"h)g+h,`N^.Nu0NA n 0C22U@bB.p'mfd0-H/HzHNJgL|pmW@.@@N3lB-p"mWr#mWAHnHnHzNHn/N n"P#_"P-i"n#mhBQ3|* B)Hi/< N n-h"n2Bi N^.NuDNAY nHh?<N n h"h#_pmg ?< n/(/.NJf ?<N.N^.NuNAYBg<Nf n!_-hHnHhHzvNHn/. NԦ n!m,"m,pQg ?<8N.pmg?<3N.`$N3l nHhN n!m,/NhN^ _PONNAYN n h"h#_"h-iJ. g$Hn"nN.N3lY nHhN n h"h"i"N^.NuNABBJmf/: HnNXHn nHhHzNHn/.N̐ m,Jgd m,-h nphfBJg6-h"n-QJ)g ?<N. np hf-h` ?<}N.` ?<N. n h-hHiHzNHnN\` Hn nHhHzNHnN n!m,"m,-iJg"npiV"m,JQWg?<N.`pmW. g nHh"nHQ$n/*N`jpmW. Ag> nHh"nHQ$n/*NVpmf N3l` ?<N.` n"nHi/<N n-h"n#m,$nHj/.HnNfY/.N" n N^.Nu0DNAY n hHh. N\ n!_"h"i!iJgf"hpig?<}N. nB`B n"hJ)f?<N.`$ n"hJ)"g?<}N. nBN^ _Jg ?<~N.N^ _\ONDNAY nHhp8hWN-_ n h"h#npmf N3l` ?<N. np8hfYHhNd n `Y nHh<N* n n-Ppmf N3l` ?<N. np8hfYHhNb n `Y n\ONNAY n hHh. N n!_YNx-_-n n1|% "n$i!j$i%n$h0B$h#jJg8$ipjg?<}N. nB` n"h$n%ipmf N3l` ?<N.Hn n hHhHzNHnN n!m,"nJg2     -|"m,pQg?<}N.` m,Jg m, h0($H-@pmf N3l` ?<N.Y nHhN n h"h"i"-m,"np*i W)g" )^J]g ?</N.N^.NuNA n h-h"nJ)gYHi?<N n!_`&YNW@J.g*N3lHn nHhHzNHnN:` ?<N.`2J@gY/-@N n!_`?<N. nB`?<N. nB nphWrhWg -md`4 n h"h"iJg"h"i"i-i`BJ.g/./<N n n!_Y/-@N n"h#_N^.NuNAHn/< N n h"h#nHn"nHiHzjNHnN m,Jg m, hp hff n!m, m, (dg ?<N.pmf N3l` ?<N.Hn nHhHzNHnN`Y/-@N n!_ m-P n!m,Jg-m, .찭dgU n/("n/)NhbJg$ np*h f"n/)/-,N`r nphWrhWgNUHm,"n/)NVJf(U/-, n/(N6Jf ?<N.` n!m,` ?<N.` n-hJg"npif "n,Jg/./<N n-P n!m, m,-hJg nphf n-h .DV".HVg ?<}N.pmf N3l` ?<N.YHn nHhHz$NHnN< n N^.NuDDNAB nphg$Hn/< N n h-i .谭DV".貭HV .谭PV".貭TV .谭LVU/.-@Nb .AU/.-ANb0".@g ?<}N.U/.Nb0Jg n o ?<N.J-g6 n0(H/HzNU/.Nb0g ?<^N. nph"h#n nJ(fphf6J-n n0Hf||"n#n` n-h`Jn^.AgSn0.AF00H/HzNJf0.AL-p0.HnHnHhHzNHnNhp mfh -R n!@J-g|N3l nHhN n!m,-m,"nJV")TVg ?<N.` ?<5N.N^.Nu NAY?< <N n!_N3l n-hHnHhHzNHnN҈ n!m,-m,"nJAFrpgRJV.Ag>-n n0Hf| |"n#n` n-h`JnW.2.AFtpWg0J.f ?<N.N3lN^.NuNAY?<B'N n!_N3l n"hHiHnHnHhHz4NHnN܎p mV")TVg ?<N.pmf N3l` ?<6N.Y nHhN n!_N^.NuNAY?<<N, n!_N3l n-hJmg4?<N.Hn nHhHz&NHnN8zB`/:HnNXYN n!_-n-h"n3|$ $n#j f N3l` ?< N.N^.Nu@NAY?<<Nh n!_N3l n-hHnHhHzNHnN n!m,-m,"nJV")TVg ?<N.p mf N3l` ?<4N.YHn nHhHzXNHnN n!_p mf$N3lY nHhN2#npj$V2*m(Vg ?<N. nJgj"hpil?<N.`N/< nHhNJg?<N.`& nHhHnHhHz$NHnNN3lpmg0?<3N.Hn nHhHzNHnN8z`N3lHn nHhHzNHn3     -hJmg0?<N.Hn nHhHzLNHnN8z`/:8HnNXHn nHhHz"NHnN m,-hJgt np hg?<N.`Xpm&n?<N.`@Rm&0-&ABA-H n"n"3|#n n!m,pmV@J.N^ _PON@Label: NAB-B-N^NuNuNA n0C22U@bp*mf|N3l`B.p+mg,?<N.HnHnHzNHnN8z`N3lpmf N3l` ?< N. n -PHn/<&N-n n!nBB(B(B1|B(!| f&N3lY?< B'NΈ n!_ n-hJ.gpmf N3l` ?<6N.Y nHhN n!_;n&N^.NuBBNAY?<<N n!_N3l n-hR"nHiHnHnHhHzPNHnNϴSp9mf$N3lY nHhN n!_1|Hh HmN nB("n$Hh/<N n-hJmg?<N. nB` nHP/<,N n-P"nHQHmNd nB B1|1m(B 1| $HhHnHmHzNHnN nJ( f"n/N\(N3lp3mf N3l`(?<N.` ?<N.N^.Nu@NA n0C22U@bBp"mf 'o ?<N.=m&0.AF00H/HzNJgSn`0.AL-pJgr-n n0HfPJ(g?<N.B`. n|JmV( g ?<N.HnHnHzbNHnN8zJmg?<N. nB` nHh/<,N n-h"nHQHmNd nB B1|1m(B 1| $HhHnHmHzNHnN nJ( f"n/)N\(N3lpmg,?<N.HnHnHzNHnN8z`N n!m`` n-h`?<N.N3lpmf N3l` ?<N.0-H/HnHnHz&NHnNJf?<N.HnN8zpmfN3l0-H/HnHmHzNHnNJg0-@2;Nr\\\\\\\\\\\\\\\\\\3lJmg0?<N.BHnHnHzTNHnN8z`/:HnNXJgl nJ g0 n h phm n"n#h ` ?<qN. nJg"n$P%i nJg"n$h%i -nN3lpmV@J.fJ.g ?<N.N3lJ.gp8J\\\\\\\\\\\\\\\\\\\\\\\\\\\\\&/:JHnNX-n nphWr h$WphWgHn/./N` /./NΒ`/N`Rm/N|Sm`xRm/NSm`f/N`\Rm/NHSm`JRm/NSm`8Rm/Nmf N3l` ?< N.p mf N3l` ?<N.p+mWr*mWg(J.g ?<N.HnHn/.N`Jmf/:HnNX n-h -n n-h!nJg8Hh HnHmHn"nHi HzNHnNHnN nJVJVgSm`&Rm/NSm`Rm/NSm`0-H/Hz\NJf?<N.HnN8z`Y?< B'N4-_ n!n -n N^.Nud @NA0.n o =n`=n N^ _PONNA n 0C22U@b-m/-NJgz/-/"h.)@J.g\"h=i0.nr @l B.`:pnl =|`&pnl =|`pnf=|J.g n|B("1n 1|`n nB(-h"nJ)g ?<N. n0(HАS/0(H/-HN n0(H/N-_ n!n n PHP??Rm&0-&CBC-I"nB3|BBB B` ?<N.pnf"HnHzT nHhHhB'BN`HnHz8 nHhHhB'BN+n.;n& n N^ _ N0NA n0C22U@b0-H/HmpNJf(?<N.NX n-h pnfJg/< nHh NJg ?<yN. .԰hf ?<N. nJ(g ?<N.Jg<-n np]rhVU/.-ANb~".g=|-npnW".ԲhWg=|pnW".ԲhWg ?<N.JHnHnHmpNHnN8z0-H/HmpNJgpmf=m&0-&AF00H/HzNJgSm&`Hn/< N-n nBh 1|B(|B( 1|Hh "nHiNBBnN3lJmfHn/< N-n nHPHmNd ng&-n-n n!n 1n$-h` n!n-nN3l`Jp+mWr*mWg*BHnHn/N-nJg-n-n n!n pnf01|$/<"nHi NJg ?<yN.`$pnf?<N.` n1|$ n-h`| n!n!n !n1|Hh"nHiN n|0.H!@/.N\(Rn-nN3l` ?<N.0-H/HnHnHzzNHnNJf(?<N.HnHnHzRNHnN8zpmg n!n0.S@H/HnHnNKJ n1n;n&pmf N3l`-nN3lHn/<*N-n nBHh /<&N n"n$h L?H?5i$$ n1| $"n!i1|!n& n!n` ?<N.0-H/HzNJf(?<N.HnHnHzNHnN8z` ?<N.pmfXN3l0-H/HnHnHzN ?<N.`Jmf&/:HnNX nJhW@`B.J.gH0-mf& n P"m pR@ fS@f?<N.N3l n-h .hfpmg?<N.`N3lHnHnHz>NHnHnHnNH .DfJ_ ^g?<N4     /(HnHnNKJ0.ڰno=n.Հ.gRnp no\ n|1n.Հ.@ ( @rnpA\"(DWg !mH` nB( n 0-H/HnNJf?<N.HnN8z` n BN^ _ NDD n (o ?<fN.-n-npmV@J.fN3lJ.gpmf N3l` ?<N.pmf N3l` ?< N.pmf B` nBHnHmNHn nHhHzNHnHnHn nHh/(N-nJg0 nJ"fNA-n nJho 0(P@S@l^@@HШ"n"` n"n" nB(pW"nriWg 1|` n1| nJWr h^(@g"n|B) 3h` nB(N^ _PONNA-n nJ fBB(`< n h"n$i ( n"n#h""n-i```/<HnNJg ?<N. n/(Hn/(HnHnHzJNHnNHnN n h0(l^@@HШ-@0.l^@@HЮ-@0.@2(AA]".W".^g-h=hJg. n-h n!n*gJJhf. (=@Jng0.H0.H1@/-/HzR+O n h"n$i 0*hNvr @lTNvhNvJhlBh`+o N2,_+_pmf ?<N. n hBBh`NJ n h"n#h|3h $i 0*hJi Wri W/. n/(N-n`pmfdN3l0-H/Hn nHhHzlNHnNJf,?<N.Hn nHhHz@NHnN8z` ?<N.pmV@J.fN3l n h!n1np mW.g n h!n1n"n#nJg nL$i pjW$i * g0) l^@@HѩB)| n hpho1|` n hJhop/-/Hz.+O0(P@NvS@Nvl^@@HѨNv+o N.,_+_pmf?<N. n hB`NJ n hBh nB("n"iiYHi/( <?<NK nH n-hJgt nA-H n .ʰ\".ʲ_ .ΰ\$.δ_ .ʰ]".β^g?<N.` ` n-h` n-h`XN^.Nu hhNA n0C22U@bB.B0-H/HzN!_"h $n$j0*il "h 5iN^ _PONNAHn/<NHnHmN-n nBB1| Hh HnN n"h"N3lJmf n hJ(gHn/<"N`Hn/< N-n nBB 1|BB(HhHnNB.B-/:Jf(?<N.HnHnHzNHnN8zJmf8|BJmf nJ(gHn/<"N`Hn/< N-n nHPHmNd nB B1|B(Hh"nHiN n Jf n Jg n!n-nJf-n/.N\(N3l`HnNX|N3lJWrmWg| n|Jg "h#n n!n"h Jf "h "/.HmNd/.N\(pmf N3l` ?<N.Jmf/:HnNXN3l`,?<N.Hn nHhHzNHnN8zJg n-h `B ?<N.0-H/HzzNJf(?<N.HnHnHzlNHnN8zpmV@J.fN3lJ.gpmf N3l` ?<N.HnHnHzNHnHnN̮Jg8/.Hn/.Hn nHh HzNHnNHnNJg(-n n!nJgF nphm. n!n n!nJ.g/./.N` ?<nN.`,?<N.Hn nHhHzVNHnN8z n"nh/./(Nxp mf N3l` ?<N.B n h-h-h=h=hBHn nHhHzNHnHnHnN /./N n-h`pmfFN3l0-H/Hz|NJf(?<N.HnHnHz`NHnN8z`pmf /N` nBN^ _N``@p@NAHn/<N n"h"-n"nB3|B)B)"H nJg*U n h/( /.NhbJf ?<oN.Hn/<&N-n n!n!nB"!n1| Hh HnNp3mfvJ-g ?<^N.N3lHn nHhHzNHnHnHnNH nJg*U n h/( /.NhbJf ?<oN. n!n3|Hi HhNN3lJmfLHn/<N-n nHPHmNd n!n !m"Bh+n"N3l` ?<N.N^.NuNA/-/Hz*+O/. n/(N-_+o N:,_+_pmf*?<N.J g n phf n BN^ _ NNAN4     ABA-H nBBh` ?<N.BBn=|BHnHnHnHzNHnHzNHnHnHnHn/N^Hn/<N-n0-& nCB!q!n/./NZ n1| Hh HnN;n&p mf N3l` ?< N. n `p)m3l` ?<N.N^.NuPPNA n 0C22U@bN3lJmg(?<N.HnHnHznNHnN8zJmfNHn/< N-n nHPHmNd n+PB B1|HhHmNN3lp(mWr mWg N3l` ?<N.HnHnHzNf:N3lp mf N3l` ?<N.HnHn/NJg< nphl?<sN.B` .Df?<N.BHn/<N-n n!n1|Hh HnN nB(B(B1|B!|oJg^/.HnHnNjJ] o^g?<HnHnHnNH JgJ-g$ .XW-Ag ?<^N. n0(H/HzNJg-nJ-g npPg ?<^N. npPfB(J. f ?<N.J-g +n>`D nJ(f"J.f/.3lpmf N3l` ?< N.BHn/<&N-n n!nB"ni$B(B( 1|B(!| 1|Hh HiN nB("-nHn nHhHzNHnHn/.NJgB nphm* .Df?<N.` n!n` ?<qNN.`( n!n!npЮlмT n `dp-mf$N3lHn/<N-n nB(B(1|1| Hh HnHnHzTNHnNp mfxN3lHn nHhN nJgR"hJ_"h ^g?<N.`*/< n"hHi.pmV@J.fN3lJ.gpmf N3l` ?< N.p mf N3l` ?<N. nHhHnN̮-n n-h!nJg?<uACESb"n"Q ?]?@J.g .-@/< n/(/N`J| nJh f B`0 np =@0.S@HЮ/0.H/N-_`n nN^ _TONUndefined type NAACSbB-J"g m" PCASb/:HnNXJfJ.gL?<uACESb"m""QphW"hriWp hW"htiWg ?<N. nJ(fphf,Hh/<=N n"h3|"hB)8`2 nHh/<=N n-h"n3|B8B)< n!m ` nB J-)g n"PEpR@ f S@f`,J-*g2 n"PEpR@ fS@f``pm&f` /.N\(-nN3lpmf--f ?<dN.N3lHnHnHzfNHnHnHnNH .ⰭPfHnHn/<Nc .ⰭDVU/.-h"nHQHmNd nB B$1|B((B()mm+B(,B(*B(-B"n1iHhHiN n/(N\(`R n"h-iJg<-n nph$fYHm./( B'?<NK-_ n-h`N3l`?<N. n!m6pm&oRm&0-&ABA-@Nb0 .Ag ?<2N. n1|$ nLH& .ⰭDgpmfN3lHnHnHzNHnHnHnNH .ⰭPg?<2N.`p.|Lm|'nz@2;NPnnnnn`TnnnnnnnnnnnnnnnnnnnnnnnnPn-H nJ(g:"h-iJg nJg` n-h` n ` nB nB BB1|B` ?<N. nphf-|` -| pmW@-m.B. np hg"HhHzfHnHn(/.N`" nHhHzFHnHn(/.Nnnnn`T`& nBh$` n1|$` ?<2N.pmf N3l` ?< N.` ?<N.0-H/HnHnHnHzNHnHmNHnNJf:?<N.HnHnHnHz`NHnHmNHnN8zpmV@J.fN3lJ.gpm nJ(f"h#n"h#n$`|J.gtJ-g ?<^N. n"h .$V"..Vg?<N.`2U n"h/)/.<<NgJf ?<N. nJ(g+n. np hffpmfFN3lJmf /:PHnNXJg n-h .hf N3l` ?<N.-nBHnHnHnHzNHnHmNHnHnN^Jg-n n!n ph$fNpm&f&J-)gv"PEpR@ fdS@f .Ⱝdg?<N.`B .f n-h` n"n#h-nJ-f /-4N\(`J-*gf?<N.`RJgJ/< nHh NJg ?<N. n"h . V(g ?<N. n"h#n Jg("npin-mXJ-g ?<^N. n"h .Щ$-@YHn/.<?<NK n"h#_8N3l`,?<N.Hn nHhHz>Nz n"PEpR@ fdS@f .Ⱝdg?<N.`B .f n-h` n"n#h-nJ-f /-8N\(`&YHm./.B'?<NK n!_-n` YHm./.B'?<NK n!_ nJfjJgZJV/<"nHi -@N .g20-&HnN8z` nJ(f ?<{N.N^.Nu0NA n0C22U@b=mBr|N3l-m.B.| |!HnHmNHmHzN=m(=m&pm(o Rm(` ?<N./Nt-nJrV n@(.g ?<lN. nJ(5     <NpgNB.?<cACESb"m0.z<HPHq-HN nHPN`vp mnB.?<bN.`ZJnf?<eACESb<HPHm-HN nB>HmHzNB.Brp.mf N3l` ?<N.Jmg"?<8z`B-mN^ _PON@@@@NAJ gR-n nJg /(N n -h Jg/./.N n-h` n -h `N^ _PONNA=m$0-&R@;@$-mpmf?<N. nHhNڦ0-H/Hz$NJg0-|@2;N8`N.ACSb`p-d ?<N.0-&ABA-H nphf/(/N`F n/(/N n-hJWJVg n/( /N| n-h`JW@pm&o>Rm&0-&ABA-H nBBB B1|B` ?<Hn nHhHzNHn<B'N`lHn nHhHztNHnNh`JHn nHhHzVNHnN`(J-f ?<dN.<NjB'N.0-|.@2;N@v nHhB'B'0-&CN.Hn/<NJ.gHn/<$NHn/<=N-n nHPHmNd nB BHhHz N n1|1||+B(B$B()B(-|(B(,B(*|81m(-n n B|B( B BBB(B`Z m-P n-P-n nJ( THqB'Nh`lN3l nHh<<0-&CTHqB'Nh`6N3l nHh<B'0-&CTHqB'Nh``HJ-f ?<dN.N3l nHh0-&CP"q"QHi <N`` 0-H/Hz6NJg0-|@2;N8Xrvg ?<N. n0-&CH#+h .| |!pm(f-m n+PJ.g n!m -n n BBB "n!i-n0-&ABA-H n!n"n#nJmfN3lpmf N3l` ?<N.pm&W.AgB'Nvvvvvvvvvvvv8vvvvvv?<N. nHh<B'N` ?<N. nHhN܀`?<N. nHhN`<N֜B'N`Hn nHhHzJNHnN`<Nl?<N.p.mf. nHhB'B'0-&CTHqB'Nh`2N3l n/-NB-p/mflpm&W..Ag"|/-N|0-]@;@N N3l n"n"Hn$nHjB'N n"n#P nB"n|J.gF/.N\(Sm&Hn/<=N n"nHPHQ/<=N/.N\(Rm&p0mfvpm&W-A.Hh<B'0-&CTHqB'Nh`@?<N.N3l nHh0-&CP"q"QHi <N``^<Nծ<Npp mg@?< N.pmf N3l`"Hn nHhHz6NHnN8z n-h"nB)(|-J(g-h"nB)(|-0-&.@-Ag"|/-N|0-]@;@N N3lHnHnHz>NHn/NZ`J.g ?<N. nB("n$n%QB.@-rm&Wg N0B-pm&W.AgFJ>g>-m> n"hJ)f/HhN n"h| n+hAB/0N n-hJg n/(N n-h`=m(pm(o Rm(` ?<N.-m.B.B- B-!Bm0-&ALB|lHn nHhHz^NHn n/(NpmVrmVg,?<N.Hn nHhHz NHnN8z0-H/Hn >`B'NB'Np1mfbJ.g ?<N.N3l/N`pm&Vrm(Wg*.gS/-/./.N -.Ѯ`2J.f ?<N.p mf N3l` ?< N. n"n#h#m. +n.+n>;n&HmHnNnmpm(f(+npm&W.HmHzNHnNJgp n"hB)-J(g "hB)-;n(+n.pm&f<N n/(/N0-&AT-pJgB-n n"PJV"P")\g"P"i$P%i` n-h`+n=m$N^.Nu@@@@@  Ag /-N| J.f n| n"n !Q n -nJg n-h Jg-n n-PJ.fV"nJ) fF?<E&Q&SIGSbNd nHhTHzNd nHhXHzNAHn/<&N-n nB!n "n!iHhHmN n1|1n $B n!nN^ _ NNA nHhHzpNd nHhHzNd nHhHzNd nHhHz Nd nHhHzNd nHhHzNd nHhHz@Nd nHhHzN.Nd nHh\HzNd nHh`HzNd nHhHzNd nHhHzNd nHhHzDNd nHhhHzNd nHhlHzxNd nHhpHzNd nHhtHzNd nHhdHzNd nHhHzNd nHhHz&Nd nHhHzNd nHhxHz Nd nHhHzNd nHhHzNd nHhHz Nd nHhHzNd nHhxHzTNd nHh|Hz~Nd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nd nHh|HzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHz*Nd nHhHzNd nHhHzNd nHhHz\Nd nHhHzNd nHh4HzNd nHh8HzNdHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzNdN^.NuLNPOSSTRSINCOSEXPGETPUTCOPYMARKSQRTINSERTDELETEESCAPEARCTANSTRRPTSTRPOSRELEASEMEMAVAILUNITBUSY nHhHzbNd nHhHzBNd nHhHzNd nHhHzNd nHhHz$Nd nHhHzNd nHhHzNd nHh0HzNNd nHhHzDNd nHhHzNd nHhHzNd nHhHzNd nHhHzNd nHhHzdNdN^.UNITWAITNEWWORDSSTRLTRIMSTRRTRIM UNITCLEAR STRAPPEND STRINSERT STRDELETE ESCAPECODENAp/NHn/<&N mh"nL?H?3h$$ n1|$ n =|8Rn0.H/HzN_J.gHn/<N`Hn/<NBB0.|9@NuABSCHRODDORDSQRHEXNEWEOFPREDSUCCADDRCALLPAGEREADOPENSEEKEOLNHALTPACKSCANROUNDTRUNCOCTALWRITECLOSERESETBINARYSIZEOFPROMPTREADLNAPPENDMAXPOSSTRLENSTRMAXUNPACKLENGTHCONCATGOTOXYDISPOSEWRITELNR2;N:LJpJv^v/-X?</N`/-X?</N`-mT/-D?</N`/-D?</N|`x/-H?</Nj`f-mD`\-mL/-L?</NH`D/-`?</N6`2/-D?</N$/-X?</N`/-D?</7     0? n"n ()g n "n0) h ]@` n hN^ _ NNA n h h"hHn?.?<N/-/Hz0?<?N/N`/N/NBm(Bm&BmBm*Bm;|FBBBHBLBPBTHmHznN/N߈/N N3l/Nt/N/Nb;|/N-nt0.H ntC !n !nJ.g 1|` nt1| ntBh1n0.H/HzZNJg* ntHhHnpHmHz.NHnpN`0.H/Hz@NJg* ntHhHnpHmHzNHnpN`0.H/HzNJg* ntHhHnpHmHz(;|&;|\BXB^BbBfBj;|$NJmf2Hm/<N;| ;|A$mCSbJmfHm/<N;| BmB-&BR/-N m/-Hz?<?PROGRAMAll rights reserved.Copyright Hewlett-Packard Company, 1982, 1991.NA n JfD+m, n hB(Hh/<N nHh"h/)/<N`J n CSbBB|B-B-lB-mB"B-B.| +|+| ACxSbACSb|!B-BBB|B-B-||B-|||B-B-B-|#Bm B-|+BmBm|&B-"B-(BmAfC:Sb PLH=h$Hn/.N/. /<&NHn n //<&NN^ _PONNA nHh/. N6-m, nJgJPg?<2N. nB`d np,h fV"n#hJ-lgLH`4 n"hHQHn/< NHn/N n"h#nN^ _PONNAA:+H6ABCSbB-,B--B-)B-*;|B-BmB-$B-B- N^.NuFLTPTHDW SYSGLOBALSNAHmfHzNHmpHzNHmHzNHmzHnHnHzHmNHnHmpNHnNHmHzNHmHnHmHzpNHnNHmHz*N n hHh/< N n h"h$hLH n h"hJf"h#h` n h"h" n h"hB!hN^.NuNA n h"h"iHQHn/< N n+hJ. g/N@ n h-hJ. g*"nHi/< N n"h2"hB nHmHz"NHmHzPNN^.Nu`<=9@ \NA+|BR .SA 0".A! mN^.NuNA/N mB( |-|-r o<HmHn<-h"n < -@JlBpnf/.0.H/N-_`/./.N-_ .䰮oHn .䐮/Np-n԰n-@pnf@p2.H-Aаn(-@ nR ."( C .Rh`NpnfDp-nаn4-@ nR "n8     f N3l`?<N. n h|Hn n hHhHz GOTOW8IFWLW*Wh IMPLEMENTW^W~1IMPORTWv/INWVXt(LABELWMODWWW&MODULEWW.NOTW%OFWWX0 OBN^.NuNA n0C22U@bB|BB.0-H/HmfNJf(?<2N.HnHnHmfNHnN8z0-m|'n@2;NP\B/Nj`pf -mP`Y,`AC6pR@ f"S@fJ--g ?<eN.|-`tACpR@ f"S@fJ-)g ?<eN.|)`@ACpR@ f"S@fJ-*g ?<eN.|*` ?<hN.N3lpmVrmVgX^PROGRAMXV!RECORDXlWX,RECOVERXX9REPEATXSETXXX)THENXX TOXTRYXXY$8TYPE Y--"q&}}m-  "   ! , "P P>  !  >!- ! " "P P-XYUNTILY VARY XY8WHILEY2YLWITHYFLBDgp, `(E Tg2b.eJ$Fbe4>UGmVf&BNBGUGmVe*,f&.N>UGmVb*,f&.N(E TJg*,f`$d x_NMCPP  - -"---6  1&:  -- ---1  @.-1 --=1-= !=1m-yYm4-M1 -  - }}M--1*  - -"--- !2B"P        P      .   - -=--1-Eȸ-1- MPM1.-1-=!=MP=!=M1R(- -1-=M=--1-Ym-*}m(}-0-.6-` P PJ Y- ----  1 =1 1 != ==!= ==!= = ==1==1-1-  P-- e --  --    ===P!P!P!=M M=1-=M=!1-1-!=-= -!-= -=-= -!-=1 -=1-=1-=1LB !  -=-  - - -M=11 6-1, =1&$ 0! = !  =  = ( =1T  =1 =M!==  -M-=-  --1$ -=-Ո -  -1  -1-=-m- - -=1  $}}m-  =!1 1- f- - )---L1Ȣ- ----  -  -    - e- - -  -- --E" !,و =P21=d  == == =P:1=P==11P=1=1P1fMP =1=   P$P< DPP  P*P P00 P $  - "P(Ќ}X PPp   P$ ===@= =!=! =! =! = =!=! = == =! = ==!====1P@PPD= ===!0= = == =9     (}}Z}}@}}@}}@}}@}}@}}PTmY- - M- @M--&M-- $( 46M--M--TNM--4M--&!P&PPP\PP -P P PfP0P"(tt`}}$!,!HP P ! PPP^P2 PPT PP P(PPP2 PPPP"V}P P(PD0}P P P PPP PPP" PPP P P fPNP8PPP P ^ PPPP&P&* PP P (!(PPPPPPM--M--&P . M-"P *  " ( M-" }} P. ">  ":P220P  $M--Y- -P PP P P P2P P,PPPPPPP P&PP0-,0!(PPPPP PPP PP P P$P>PPJP PPP\PP4P P P PPPPPPBPFPPP(PP,P"4 PP PP,P PP PPP P^PXPPP2PPPP P&P,P P"P P$PPPP P(PPPPPPM = = = =! =====! = =!= = = =*= = ==!==P$1P= M=!1P= M=!11nP1P=-1-=1YYY6" mYM- (*& R<11r    M- M-- M- M--M1P=1PH1P=1P21P1P1PM=1P1- PbPP\PXP(*P0. P P      $ P P  P P  P P B} }P B 0 M-->P4.:$   M- M-- *P&   B$.2.2z M-- P  0BP P<}P dB(LRFfr8H} }P dP<}P xlP!* !(P<>1P Z t " 6 r$8h!P  46^-*-          *,&PP (!PP, PPP*!P,}p}}P P(:-QP,P$PP8Q>PPQP(؈ j-P( .v<uD$-2 .TЎ.F>p"d2:-PBPBPBP@P,$D PBP"P PP>P0$!$&!$8 H P  ڈ( $     LPvP *8P}P (4fP,PdP0 BP0tzm m6}@  PP PPPPPDP2 PP(PPPP*P0PP2PP&PPPPLPPPPPPlPnP4PnQ&P.P\P*P\PP&P*&"8  &   PP P PP0   l.    P 2 $   0    P P P  PPPPP PJP PP -P P4PPPPPPnP PP2PP P&P: PPPP&Q6!!PP"P"P"P PP8 P& PP*PP:P$P@PPPPP&P$PP PPPPP,P&PPPDPPPPHPPPhPfPPPP2PPPPPP(PP PP$PVP(PPP(P*P8P6P8P6PDPPPRPPP4P!PP,PP PPP>P(PRPP,PPP,PP PPPP<PPP PPP.PPP`P P0P4P*P.PtP PPP.PPP"P.P">PPPbPP&P P8PP PPP*PP PPPPPPPP PPP PPPPPPPPPP PPPbPPN}P f}P PP P PPPP PPP

!P&PPB!PPP.!P&PPPP P.PPPPPQPPP PPFBPNPP*PPPP PPBPPPPXP86P  PPP&P PPPPPP0 PL PPP PPPPP<P P!P$PP$P PPP"PL!P$P,PP(zP$PP" PfP* V PPP P PPP8P0PPPP PPPPPlP2P PP"-PPPPP2PPPP*P6. P P PPPP|PP@PPPP !P*P.PP.PPPPPPP(PPJPP"PPPP^PPbP"PPPDPPZPP^PPZP,}}P PPPPPPPPPPPЖ}P PP VPPPPP  PPPPPPP0P P PP2P$PPP0P PP PPPP( PPP,PPPPPPPPPPPPPP0(P !P<> PPP P&P PPPP -!"!PPPPPPP$PP(P6PhP"PPP>P"PPP8P"PP.P>&PPN؈ :- -P -2-PP!PP----P<P!PPP4PZPP P PP P8P0P2P2P0PPhP*PPPP* P4P,P&P@PPP&P,P@PPPPRP2PRPPPPPP.P2PPP>(PP PPPPPPP-PP2- -&}}P ---P P8PdPPPPPPP@PPP P0LP FP P4P*!PPPPP.,!PPPPP P P PPP P&\ P PP$!PLPPP P }P}}P} PPP*PP PP PPP P"P P PPPP PPPP* PPP&PP P(P-PFPPPPPPP(PP(PhPPPPP&P"PP,PPP(*P&P&PPPP P(P PP PpPP.P6 PP,PPPP,PPPP6P PPPPPP&P2PDP$PPP PPP"PP*PPPPP,P0PPPPPPPP(!PPPPP4PP4PPPPPPPPPP0PPPPPPPPPPPPP PP P"P PPP P$PP PP PPP PPP,P8P.PLPPbP8P&PPBPP P P`P PP$PP P P  P Pd PP&(}P} P  P@P"!P(PP PPPPPPP PPPPP PT PPPPPPPPPP$PPFPVP.PpPP"PPPPfP4PPP8P P2PPPP8P P2PPPPQBPP*PnPPPPPPPPP.P"P(PP P"P PP PPP4P24P*PP:$P$PP PP LPP PPP  P! PPP PPPP!!1- P-: P2PPPPPJP8PPjP6P PP PJPP0P PP P PPPPP PPP,PP P"PHPВPXPȮ-P6P`P:PP- ----P^PPPPPPP(PPP>P P>P2PPDPHP.PPJPP(P,PP P2P@ &P(PP$PdP PPPZ~P0PP$P$PP$P`P0,PhRPjVHP|PPP*P * PPPP PP.PP$P PNP* P PPPPP,PPPPPPP -PZpPJPJP PPpPP P  P PP P>,}P P  !PPP PBPn  P1  m -YP -P -6 ! ! ! !P,}P}} -1-=M:     !(<P(P PP&P(P ZP$P8P .\ P@$PPHPP6"PPP:PD(PP--PB!4upuR$j4u&4u&$< PňP&&P,> P <PňBP P"P2P`PPPHЬPP(NPPPNPPPP@P r&&&&u& P:ňP PP!!!!!!!!P$P(P6P&ІP* P:P FP P FP P4P(FPPPP.P Rx! h12BP PPPP"2FP P$P4PP < P "PP(PP.P&P PP(PP :"P P P PPP $PPPP0$P P8P !!!!!- - --$ P>2 PbPPPfP&8ňPP P V"ňP .0PPPPPPJPPnPP2PP$P$P&PP".P:PP"\PňzP Pň.Pň0N!\P P:Pň P:P"P"!PP&PP&P (&P P8 P 0PP>P P RP   PP4PPPP(PPP 6P0P2PPP(P0 PPP.P P P$P PPF$PPFPP&  P P   PP   PPPPňPPP4FPPPnP4PP8P.8P PP&P4V*!(ň P PPň!. PPPH!. P" P,8ň  PP P 2P& P PP"P* PP00PPP&PP2PPPfPP"PP PP(Nj!n14P P$$P* PP P4PPPPhPJ P P,PP:PP(P2P P PP P,PP(P*4P0PP2P P& 4- - ---P P !D - - 4---P , PPP( P! P"(PP8 PP PP PP P4P  P$PPJP PňTPP&PP*PP"P4ň PPňPPň PPP ňPPňPP PQ PRPPPP P.P &PPPP4P 0N4@P"&* "P P @*PP P $^P(P : P:P$P*- -:---P PR8FP"^r- -$A9$--P l PPPP2P P0\PP(0P ( - -< U  } ---- -PP."ňPPP,ňPPPP PPPP>P*ňP*PPP &  !PPPPP PPPP @PPPP RPP P PPPP\(ň PPPP,ňPPPPP4P P PPDPP$P PP P P -PP\ , :P|&!>TP P* PPPBPPP PP(&P P Z!zV &,! !"PPP.!О>*>P P PP,P P(PPP$P!4P PPP$PP$PPPPPP   Z("ňP 2PP PP PP P"  PNP P4PPP PPP4P PP ::P PPP   *P X-^&P  PPP P D,PLP"  P PP PPP~ PP !!P(PBPP PP PPPP*  6P PP ^!BP!P PP- - ---P P4PP!R$ň0P PPPPP4!!!P@:P&  0$PPPPP PPPPL!P  PPPP $P PPPP PPP PД}P LP P P PPjP PPPD  P"mP0m0m.PP   P PP PP"(]&! 0PPPPPP.P !$P:P >P!4 PP@P P DP P PP *(P@}P 0 P  ~.PPP P P   PNPPP*P P"P$P P R}P PPPP  P T2}} m  m  T !*& P.}P    P:P :P ! P P PP PPPP.P P !P PP PP PPP"! P$-P "P PP PP@P P !P  !8 !( !6 !8 !, !, ! !$  !$&"!P P !P  P !P P !P P !P P !P  P !P P !PP PP ňP PP P P4 !P  &,PP P PP P PP$ PP P PPPPň  Pň P PPP ň ň6"P 8P &P 8P PP: & PP PP PP P&!P  P& !PP0P !P (P !P  P  !P   PP ! !* !2 !( !B !:P8PPPPPPPPPPPPPPPPPPPPPPPPPPXP4P6PP&!.!2P (P6PPP P|*~P PP$PPPP PP$*P P,PPP P6PP P" PPP"PPP "P0PP P -P&P(-PP PP tPPPPPPPPPPPPPPPPPPPPPPPPPPPPPP!!D! j    P `!&P@PPPPPPPPPPPPPPPPPPPPPPPPPPPP!@!!Z P}P b -- -- Ym- }P - }P D-&}P &Ym"M*}P P0}} }}P 8}}P (Ym-P  ,&.Ђ       P d    (ň   ;     b( ] q]] q]m] -===P!P!P!MM1-1-=1-==1-1PPPP !- ! -1-= !P>-!6!P P*,>!Ў -6!X$!b!PPP(P<P6P(.PP&P"PPfP     >     ?     ?     @     @     A     A     B     B     C     C     D     D     E     E     F     F     G     G     H     H     I     I     J     J     K     K     L     L