IMD 1.16: 6/09/2007 15:22:26 sys 1 system   ߋtv ?B-NO BOOT ON VOLUME @w p@w wP׭ ׭ w f& fwW#w v   @ @wP  @& 7 "  BLOCK@   IS BAD   -̂@ &   # p@ zw 7 P7 R & B g wD ѕ  Rì     s   p x] \Z 1  d s  -2&w*  SYS1Z ( LINK3B.TEXTni(, LINK.TEXTn,@ LINK2.TEXTnٜ@b LINK3A.TEXTnb~ LINK0.TEXTn~ LINK1.TEXTn霐 SYSSEGS.TEXTnٝ SYSTEM.B.TEXTn SYSTEM.TEXTn SYSTEM.C.TEXTlJ GLOBALS.TEXTn8 LIBRARY.TEXTn8R PATCH1.TEXTnfRf PATCH2.TEXTnffj FILER.TEXTlZj FILER.A.TEXTlZ FILER.B.TEXTlZ FILER.C.TEXTlZ FILER.D.TEX SYS1Z ( LINK3B.TEXTni(, LINK.TEXTn,@ LINK2.TEXTnٜ@b LINK3A.TEXTnTlZb~ LINK0.TEXTn~ LINK1.TEXTn霐 SYSSEGS.TEXTnٝ SYSTEM.B.TEXTn SYSTEM.TEXTn  *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribute this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from the Institute for Information Systems. *) $(* *) $(**** SYSTEM.C.TEXTlJ GLOBALS.TEXTn8 LIBRARY.TEXTn8R PATCH1.TEXTnfRf PATCH2.TEXTnffj FILER.TEXTlZj FILER.A.TEXTlZ FILER.B.TEXTlZ FILER.C.TEXTlZ FILER.D.TEXO^TlZ  (******************************************************************) $(*  ranges for the source seg to be placed in (* room allocated for segbase. This may involve disk read (* or perhaps only crea,orgleng := codeleng; ,addr := codeaddr *end; &addleng := 0; &addprocs := 0; &wp := procs; &while wp <> NIL do (begin { ting an empty segment. In any case (* segbase points at lowest addr, and nextspot is pointed (* at the next place code can add up final seg size } *addleng := addleng+wp^.defsym^.entry.place^.length; *if wp^.newproc = 0 then ,addprocs := addprocs+1be copied into. This is used (* for destbase assignment in readsrcseg. (} ( (procedure readnsplit; *var nblocks, n, pdlen; *wp := wp^.next (end; &mark(lheap); &segbase := getcodep(ord(lheap)); &segleng := orgleng+addleng+2*addprocs; &if segleng, .pddelta, nprocs: integer; ( cp0, cp1: codep; (begin *nblocks := (segleng+511) div 512; *if memavail-400 < nblocks*g <= 0 then (begin *error('size oflow'); *exit(linker) (end; &readnsplit; &last := fetchbyte(segbase, segleng-1); &wp := 256 then ,begin .error('no mem room'); .exit(linker) ,end; *n := nblocks; *repeat * { alloc heap space } ,new(cp1); procs; &while wp <> NIL do (begin { assign places in code seg } *with wp^.defsym^.entry.place^ do ,begin .destbase := nexts,n := n-1 *until n <= 0; *if sephost then ,begin { set up identity seg } .storeword(0, segbase, segleng-2); .nextspot := 0pot; .nextspot := nextspot+length ,end; *if wp^.newproc = 0 then ,begin { assign new proc # } .last := last+1; .if last > **************************************************************) $ ${ $* Readsrcseg determines the final segment size after a ,end *else ,begin { read from disk } .nblocks := (orgleng+511) div 512; .if blockread(seginfo[s]^.srcfile^.code^, segbase^dding $* in the external procs/funcs, allocates enough area for the $* entire output code seg, reads in the original code (o, 8nblocks, addr) <> nblocks then 0begin 2error('seg read err'); 2exit(linker) 0end; .pddelta := segleng-orgleng; .nprocsr uses $* identity segment for sephost special case), and splits the $* segdict off from the code. For all procs to-be-link := fetchbyte(segbase, orgleng-1); .pdleng := nprocs*2+2; $ nextspot := orgleng-pdleng; .cp0 := getcodep(ord(segbaseed, a new $* destbase position is assigned in seg and the new proc num is )+orgleng-pdleng); .cp1 := getcodep(ord(segbase)+segleng-pdleng); $ if cp0 <> cp1 then 0begin { move proc dict } 2n$* set up in pdict. The segment number field of the pdict is $* also updated to the value of s. All is ready to copy in th := pdleng; 2while n > 2 do 4begin 6storeword(pddelta+fetchword(segbase, orgleng-n), :segbase, orgleng-n); 6n := n-2 2 ene $* sep procs/funcs. The values for segbase and segleng are set $* here too. $} $ $procedure readsrcseg; $ var orglend; 2moveright(cp0^, cp1^, pdleng); 2fillchar(cp0^, pddelta, 0) , end ,end (end { readnsplit } ; & $begin { readsrcseg g, addr, *addleng, addprocs, *nextspot: integer; *last: 0..MAXPROC; *wp: workp; *lheap: ^integer; * ({ (* Readnsplit ar} &if sephost then (orgleng := 2 &else (with seginfo[s]^, srcfile^.segtbl.diskinfo[srcseg] do *begin  ed to show procedures' position. $} $ $procedure copyinprocs; $ var cp0, cp1, pdp, *jtab, sepbase: codep; *wp: workp; *c ,wp := next *end; &release(lheap) $end { copyinprocs } ; $ ${ ursp: segp; *lheap: ^integer; * ({ (* Readsepseg reads the sep seg in sp onto the heap as (* done in Phase 2. We set up $* Fixuprefs is called to search through reflists and fix $* operand fields of P-code and native code to refer to the $* rsepbase and cursp for (* copyinprocs. (} ( (procedure readsepseg(sp: segp); *var n, nblocks: integer; (begin *release(lhesolved values. If fixallrefs is true, then all pointers $* in the ref lists are used, otherwise the reference pointers $* eap); *n := sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeleng; *nblocks := (n+511) div 512; *if memavail-400 < nblocks*256 thare checked to see if they occur in the procs to-be-linked. $} $ $procedure fixuprefs(work: workp; fixallrefs: boolean); &vaen ,begin .error('out of mem'); .exit(linker) ,end; *n := nblocks; *repeat ,new(sepbase); ,n := n-1 *until n <= 0; *ser n, i, ref, val: integer; *wp, wp1: workp; *rp: refp; *skipit: boolean; $ r: packed record /case boolean of 1TRUE: pbase := getcodep(ord(lheap)); *if blockread(sp^.srcfile^.code^, sepbase^, nblocks, (integ: integer); 1FALSE: (lowbyte: 0..255; 9highbyte: 0..255) -end { r } ; $begin &while work <> NIL do (with work^, refs.sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeaddr) <> nblocks then ,begin .error('sep seg read err'); .exit(linker) ,end; ym^.entry do *begin { for each work item } , { figure resolve val } ,case litype of .SEPPREF, .SEPFREF: val := defproc^*cursp := sp (end { readsepseg } ; ( $begin { copyinprocs } &sepbase := NIL; &cursp := NIL; &mark(lheap); &wp := procs; .newproc; .UNITREF: val := defsegnum; .CONSTREF: val := defsym^.entry.constval; .GLOBREF: val := defsym^.entry.icoffset+ ?&while wp <> NIL do (with wp^, defsym^.entry do *begin { copy in each proc } ,if cursp <> defseg then .readsepseg(defseg); defproc^.defsym^.entry.place^.destbase; .PUBLREF, .PRIVREF: begin :if litype = PRIVREF then  0 then .st locations set up in readsrcseg. If all goes right, we should $* fill dest seg to the exact byte. The proc dict is $* updatorebyte(newproc, jtab, 0); $ pdp := getcodep(ord(segbase)+segleng-2*newproc-2); ,storeword(ord(pdp)-ord(jtab), pdp, 0);  >begin @r.highbyte := val mod 256; @r.lowbyte := val div 256 + 128; @val := r.integ >end 8 else >error('addr oflow') eginfo[s]^, segtbl do (begin *nblocks := (segleng+511) div 512; *if blockwrite(code, segbase^, nblocks, nextblk) <> nblocks t8end ,end; $ n := nrefs; ,rp := reflist; ,while rp <> NIL do .begin 0if n > 8 then 2begin 4i := 7; 4n := n-8 2hen ,begin .error('code write err'); .exit(linker) ,end; *diskinfo[s].codeaddr := nextblk; end 0else 2i := n-1; 0repeat 2ref := rp^.refs[i]; 2skipit := not fixallrefs; 2if skipit then 4begin { see if pertinent } *diskinfo[s].codeleng := segleng; *segname[s] := srcfile^.segtbl.segname[srcseg]; *segkind[s] := LINKED; *nextblk := nextblk6wp := NIL; 6wp1 := procs; 6while wp1 <> NIL do 8if wp1^.defseg = refseg then :begin { find matching seg }  NIL) and skipit do 8if wp^.defseg = refseg then :with wp^.defsym^.enfile. The global var s has the seginfo index $* pertaining to the segment, and all the other procedures of $* Phase 3 are ctry.place^ do = srcbase then >if ref < srcbase+length then @begin Bref := ref-srcbase+destbase; Bskipit := FALSE alled from here. This proc facilitates linking $* the master seg separatly from the other segs to ensure that $* the DATASZ@end >else @wp := wp^.next wp := NIL 4 else :wp := NIL 4end; 2if not skipit then  of the outer block correctly reflects the number $* of PRIVREF words allocated by resolve. $} $ $procedure linksegment; &4case format of { fix up this ref } 6WORD: storeword(val+fetchword(segbase, ref), Psegbase, ref); 6BYTE: storebyte(val, s ({ (* Writemap is called for each seg to write some (* info into map file. (} ( (procedure writemap; *var wp: workp; egbase, ref); 6BIG: storeword(val, segbase, ref) 4end; 2i := i-1 0until i < 0; 0rp := rp^.next .end; ,work := next *en.b: boolean; (begin *with seginfo[s]^ do ,writeln(map, 'Seg # ',s,', ', srcfile^.segtbl.segname[srcseg]); *wp := procs; *ifd $end { fixuprefs } ; & ${ $* writetocode takes the finalized destseg and puts it in $* the output code file. This also wp <> NIL then * writeln(map, ' Sep procs'); *while wp <> NIL do ,with wp^.defsym^.entry do .begin  involves setting up values $* in the final segtable for writeout just before locking it. $} $ $procedure writetocode; $ 0write(map, ' ', name); 0if litype = SEPPROC then 2write(map, ' proc') 0else 2write(map, ' func'); 0write(map, ' # ',var nblocks: integer; $ jtab: codep; $begin $ if hostsp = seginfo[s] then (begin { fix up baselc } *jtab := getcodep( wp^.newproc: 3); 0write(map, ' base =', place^.destbase: 6); 0write(map, ' leng =', place^.length: 5); 0writeln(map); = 0 thenord(segbase)+segleng-4); *jtab := getcodep(ord(jtab)-fetchword(jtab, 0)); *storeword(nextbaselc*2-6, jtab, -8) (end; &with s  '' $end; "if useworkfile then $rewrite(code, '*SYSTEM.WRK.CODE[*]') "else $rewrite(code, fname); "if IORESULT <> 0 then $begin &error('Code open err'); &exit(linker) $end; "nextblk := 1; "{ clear output seg table } "fillchar(segtbl, sizeof(se0wp := wp^.next .end; *for b := FALSE to TRUE do ,begin .if b then 0begin 2wp := other; 2if wp <> NIL then 2 writeln(mgtbl), 0); "with segtbl do $for s := 0 to MAXSEG do &begin (segname[s] := ' '; (segkind[s] := LINKED &end; ap, ' Sep proc refs') 0end .else 0begin 2wp := local; 2if wp <> NIL then 2 writeln(map, ' Local seg refs') 0end; .w"if mapname <> '' then $begin &rewrite(map, mapname); " if IORESULT <> 0 then (begin *writeln('Can''t open ', mapname);hile wp <> NIL do 0with wp^.defsym^.entry do 2begin 4write(map, ' ', name); 4case litype of 6SEPPROC, 6SEPFUNC: ;  *mapname := '' (end &else & begin *write(map, 'Link map for '); *if hostsp <> NIL then ,writeln(map, hostsp^.srcfile^.s6PUBLDEF: write(map, ' public LC =', baseoffset: 5); 6CONSTDEF: write(map, ' const val =', constval: 6); 6PRIVREF: write(egtbl.segname[hostsp^.srcseg]) *else ,writeln(map, 'assem host'); *writeln(map) $ end $end; "mark(heapbase); "unitwritmap, ' privat LC =', wp^.newoffset: 5); 6UNITREF: write(map, ' unit seg# =', wp^.defsegnum: 3); 6GLOBDEF: write(map, ' gloe(3, heapbase^, 35); "{ link all but host } "for s := 0 to MAXSEG do $if (seginfo[s] <> NIL) $and (seginfo[s] <> hostsp) theb def in ', Dwp^.defproc^.defsym^.entry.name, D' @', icoffset: 5) 4end; 4writeln(map); 4wp := wp^.next 2end ,end; n &linksegment; "{ link host last! } "if hostsp <> NIL then $begin &s := MASTERSEG; &linksegment $end; "if blockwrite(co*writeln(map) (end { writemap } ; ( $begin { linksegment } &sephost := FALSE; &segbase := NIL; &segleng := 0; &if talkatde, segtbl, 1, 0) <> 1 then $error('Code write err'); "if errcount = 0 then $begin { final cleanup } &close(code, LOCK); &iive then (with seginfo[s]^ do *writeln('Linking ', * srcfile^.segtbl.segname[srcseg], ' # ', s); &buildworklists; &f useworkfile then (with userinfo do *begin ,gotcode := TRUE; ,codevid := syvid; ,codetid := 'SYSTEM.WRK.CODE' *end; &if if errcount = 0 then (begin *readsrcseg; *if mapname <> '' then ,writemap; *copyinprocs; *fixuprefs(local, TRUE); *fixuprmapname <> '' then (begin *if hostsp <> NIL then ,writeln(map, 'next base LC = ', nextbaselc); *close(map, LOCK) $ end efs(other, FALSE); *writetocode (end; &if sephost then (seplist := seginfo[s]^.next; &release(heapbase) $end { linksegment$end   end { phase3 } ;   } ; $  begin { phase3 } "if not useworkfile then $begin &write('Output file? '); &readln(fname); &useworkfile := fname = {$I link0 }  {$I link1 }  {$I link2 }  {$I link3a }  {$I link3b }   begin { linker } "phase1; "phase2; "phase3;  unitclear(3)  end { linker } ;   begin end.  O^O^ he Institute for Information Systems. *) $(* *) $(****(end { getentry } ; & ({ (* Addunit is called to find or allocate a library unit (* that is found in link info as an exte**************************************************************) $  {  * Phase2 reads in all linker info associated with  * rnal ref. This (* occurs in lib units which use other units. If (* the unit can't be found or no room, error is called. ( the segs in seginfo and sep seg list. Again all  * fields are checked carefully. As a help to phase3,  * ref lists are co} ( (procedure addunit(var name: alpha); *var fp: finfop; seg: integer; (begin *fp := unitsrch(hostfile, name, seg); *if fllected and place records for sep  * proc/func are computed. Some small optimization is  * done to eliminate the sep seg lip <> NIL then ,if fp <> hostfile then .if fp^.segtbl.diskinfo[seg].codeleng <> 0 then 0if nextseg = MAXSEG1 then 2error('no st if it is not  * going to be needed, saving a few disk IO's.  }   procedure phase2;  var s: segindex; &sp: segp; room in seginfo') 0else 2begin { allocate new seginfo el } 4new(seginfo[nextseg]); 4with seginfo[nextseg]^ do 6begin 8srcf&dumpseps: boolean; & ${ $* Readlinkinfo reads in the link info for segment sp $* and builds its symtab. Some simple disile := fp; 8srcseg := seg; 8segkind := UNITSEG; 8symtab := NIL 6end; 4nextseg := nextseg+1 2end (end { addunit } ; ) ({k io routines $* do unblocking, and all fields are again verified. $* The only legal litypes are in oktypes. Assume that $* (* Validate verifies lientry format. (* If the entry is SEPPROC or FUNC (* then a place rec is allocated for buildplace.  sp <> NIL $} $ $procedure readlinkinfo(sp: segp; oktypes: liset); &var rp, rq: refp; *syp: symp; *errs, nrecs, nextblk,  If (* a UNITREF is found, it searched for and possibly (* allocated. If the unit must be added to seginfo, recsleft: integer; *entry, temp: lientry; *buf: array [0..31] of 1array [0..7] of integer; * ({ (* Getentry reads an 8 word record from disk buf (* sequentially. No validity checking is done here, (* only disk read errors. (} ( (procedure ge  (******************************************************************) $(* tentry(var entry: lientry); ( var err: boolean; (begin *err := FALSE; *if recsleft = 0 then ,begin .recsleft := 32; .err *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribu := blockread(sp^.srcfile^.code^, buf, 1, nextblk) <> 1; .if err then 0error('li read err') , else 0nextblk := nextblk+1 te this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from t,end; *moveleft(buf[32-recsleft], entry, 16); *if err then ,entry.litype := EOFMARK; *recsleft := recsleft-1  0SEPFREF, 0UNITREF, 0GLOBREF, 0PUBLREF, 0PRIVREF, 0CONSTREF: begin =reflist := NIL; =if (nrefs < 0) =or (nrefs > 500) tf rec } 0getentry(temp); 0new(rp); 0moveleft(temp, rp^.refs, 16); 0rp^.next := entry.reflist; 0entry.reflist := rp; hen ?error('too many refs'); =if not (format in [WORD, BYTE, BIG]) then ?error('bad format'); =if litype = PRIVREF then ?if0nrecs := nrecs-1 .end; ,{ reverse ref list } ,rp := entry.reflist; ,entry.reflist := NIL; ,while rp <> NIL do .begin 0r (nwords <= 0) ?or (nwords > MAXLC) then Aerror('bad private'); =if litype = UNITREF then ?addunit(name) ;end; 0GLOBDEF: q := rp^.next; 0rp^.next := entry.reflist; 0entry.reflist := rp; 0rp := rq .end *end; (if entry.litype = EOFMARK then *if if (homeproc <= 0) ;or (homeproc > MAXPROC) ;or (icoffset < 0) ;or (icoffset > MAXIC) then =error('bad globdef'); 0PUBLDEF sp^.segkind = HOSTSEG then ,if (entry.nextlc > 0) ,and (entry.nextlc <= MAXLC) then .nextbaselc := entry.nextlc * else .e: if (baseoffset <= 0) ;or (baseoffset > MAXLC) then =error('bad publicdef'); 0EXTPROC, 0EXTFUNC, 0SEPPROC, 0SEPFUNC: rror('bad host LC') *else (else *if errs = errcount then ,begin { ok...add to symtab } .new(syp); .syp^.entry := entry; .begin =if litype in [SEPPROC,SEPFUNC] then ?new(place) { for use in buildplaces } =else ?place := NIL; =if (srcproc <= 0) entersym(syp, sp^.symtab) ,end &until entry.litype = EOFMARK $end { readlinkinfo } ; $ ${ $* Buildplaces reads code of se=or (srcproc > MAXPROC) =or (nparams < 0) =or (nparams > 100) then ?error('bad proc/func') ;end .end { case litype } (endp segs from disk to generate $* the placerec entries for use during phase3. The seg is $* read into the heap and the grossn { validate } ; $ $begin { readlinkinfo } &recsleft := 0; { 8 wd recs left in buf } &with sp^.srcfile^.segtbl, diskinfoess begins. Assume that $* sp <> NIL $} $ $procedure buildplaces(sp: segp); &var cp: codep; heap: ^integer; *nbytes, nblo[sp^.srcseg] do (begin { seek to linkinfo } *nextblk := codeaddr + (codeleng+511) div 512; *if talkative then ,writeln('Readcks, nprocs, n: integer; $ ({ (* procsrch recursivly searches symtab of sp to find ing ', segname[sp^.srcseg]) (end; &repeat (getentry(entry); (errs := errcount; (if entry.litype <> EOFMARK then *if entry.(* sepproc and sepfunc entries and build the actual (* place record for the link info entry by indexing (* thru proc dict litype in oktypes then ,validate(entry) *else ,begin , error('bad litype'); .entry.litype := EOFMARK ,end; (if dumpseps to jtab and using entric field. (} ( (procedure procsrch(symtab: symp); *var i, j: integer; (begin *if symtab <> NIL then (* it is placed after current position so it will have (* its link info read as well. (} ( (procedure validate(var entry:then *if entry.litype in [SEPPREF, SEPFREF, >EXTPROC, EXTFUNC, >GLOBREF] then ,dumpseps := FALSE; { we need them! } (if en lientry); (begin *with entry do ,if not alphabetic(name) then .error('non-alpha name') ,else .case litype of 0SEPPREF, try.litype in reflitypes then *begin { read ref list } ,nrecs := (entry.nrefs+7) div 8; ,while nrecs > 0 do .begin { read re  } " "dumpseps := TRUE; { assume we don't need sep segs } "for s := 0 to MAXSEG do $if seginfo[s] <> NIL then &case segi,begin .procsrch(symtab^.llink); .procsrch(symtab^.rlink); .procsrch(symtab^.slink); .with symtab^.entry do 0if litype in nfo[s]^.segkind of (LINKED: ; { nothin } (UNITSEG: readlinkinfo(seginfo[s], [PUBLREF, PRIVREF, UNITREF, [SEPPROC, SEPFUNC] then 2if (srcproc <= 0) or (srcproc > nprocs) then 4error('bad proc #') 2else { find byte place in code } MCONSTDEF,EXTPROC, EXTFUNC]); (SEPRTSEG: readlinkinfo(seginfo[s], [GLOBREF, GLOBDEF, MSEPPROC, SEPFUNC]); (HOSTSEG: readl4begin 6i := nbytes-2-2*srcproc; { point i at proc dict } 6i := i-fetchword(cp, i); { point i at jtab } 6if (fetchinkinfo(seginfo[s], [PUBLDEF, CONSTDEF, MEXTPROC, EXTFUNC]); (SEGPROC: readlinkinfo(seginfo[s], [EXTPROC, EXTFUNC]) &end { byte(cp, i) <> srcproc) 6and (fetchbyte(cp, i) <> 0) then 8error('disagreeing p #') 6else 8begin :j := fetchword(cp, i-2)+4cases } ;  "{ now do sep list elements } " "if dumpseps then $seplist := NIL; "sp := seplist; "while sp <> NIL do $be; :place^.srcbase := i+2-j; :if (place^.srcbase < 0) :or (j <= 0) or (j > MAXIC) then  &nbytes := sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeleng; &nblocks := (nbytes+511) div 512; &if memavail-400 < nblocks*25NIL do $begin &buildplaces(sp); &sp := sp^.next $end; "if errcount > 0 then $exit(linker)  end { phase2 } ; 6 then (error('sep seg 2 big') &else (begin { alloc space in heap } *mark(heap); *n := nblocks; *repeat ,new(cp); ,n := n-1 *until n <= 0; *if blockread(sp^.srcfile^.code^, heap^, nblocks, /sp^.srcfile^.segtbl.diskinfo[sp^.srcseg].codeaddr) <> nblocks then ,error('sep seg read err') *else ,begin .cp := getcodep(ord(heap)); .nprocs := fetchbyte(cp, nbytes-1); .if (nO^procs < 0) or (nprocs > MAXPROC) then 0error('bad proc dict') .else 0procsrch(sp^.symtab) ,end; *release(heap) (end $end { buildplaces } ; $  begin { phase2 } " "mark(heapbase); "unitwrite(3, heapbase^, 35); " "{ read link info for host segs    * massaging. For each segment in seginfo to be placed  * into the output code file, all referenced procedures  * and fun &uprocs, { unresolved external proc/func work list } &procs, { resolved list of above items } &ulocal, ctions are found, globals and other refs are  * resolved, and finally the final code segment is built.  * In the case of a S { unresolved list of updates for seginfo entry } &local, { resolved list of fixups that came along with seEPRTSEG host (eg an interpreter), then  * all the procs in it are put in the unresolved list and g } &uother, { unresolved work list of things other than procs } &other: workp; { resolved list of above } &sep * the host seg is made to appear as just another sep seg.  * This drags along all the original procedures and maintains  *host: boolean; { flag for interpreter host case (only seg #1) } &fname: string[39];{ output code file name } &segtbl: I5segtbl their original ordering for possible ASECT integrity.  }   procedure phase3; "type &workp = ^workrec; { all seg work is driven by these lists } &workrec = record 2next: workp; { list link } 2refsym, { symtab entry of unresolved name } 2defsym: symp; { " " " resolving entry } 2refseg, { seg refls point into, refrange only } 2defseg: segp; { seg where defsym was found } 2case litypes of { same as litype in refsym^.entr  (******************************************************************) $(* y } 0 SEPPREF, 4SEPFREF, 4GLOBREF: 8(defproc: workp); { work item of homeproc } 4UNITREF: 8(defsegnum: segrange); *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribu { resolved seg #, def = ref } 4PRIVREF: 8(newoffset: lcrange); { newly assigned base offset } 4EXTPROC, 4EXTFUNC, 4SEPPte this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from tROC, 4SEPFUNC: 8(needsrch: boolean; { refs haven't been found } 9newproc: 0..MAXPROC) { proc #, comp or link chosen } he Institute for Information Systems. *) $(* *) $(****2end { workrec } ; { 0 implies added proc } " "var s: segindex; &segbase: codep; { address of current seg bein**************************************************************) $  {  * Phase3 of the linker does all the real work of code g crunched } &segleng, { final code seg length for writeout } &nextblk: integer; { next available output code block }  which has work items which have at least one $* ref occuring in the procs or funcs in the procs list. $} $ $procedure buildinto the uprocs list, the defining proc is located and (* added into uprocs. (} ( (procedure findnewprocs; *var wp, wp1: wworklists; &var sp: segp;  wp: workp; $ ({ (* Findprocs goes through symtab and builds a list of (* procedure orkp; ( pnum: integer; ( ,{ ,* Findnadd finds the procedure numbered pnum in the ,* symbol table symtab. An error iand functions which occur in the tree and (* whose litype is in the okset. The resulting list (* is not ordered in any parts given if the ,* required proc cannot be found. It returns a work ,* node for the proc once it has been found. This ,* icular fashion. It is (* called to build initial uproc list. (} $ node is also added into the uprocs list. Any procs ,* added this way are "invisible", dragged along because ,* of global re(function findprocs(okset: liset; symtab: symp): workp; *var work: workp; * ,{ ,* procsrch recursivly searches subtrees tofs/defs. ,} , ,function findnadd(symtab: symp): workp; ( 0{ 0* procsrch recursivly searches the sym tree looking 0* for pick out ,* those symbols which are in the okset, generates ,* new work nodes, and puts them into local work list. ,} ,  the actual symbol containing pnum. This does 0* most of the work of findnadd. 0} 0 0procedure procsrch(sym: symp); 2var ,procedure procsrch(sym: symp); .var wp: workp; ,begin .if sym <> NIL then 0begin 2procsrch(sym^.llink); 2procsrch(sym^.rwp: workp; 0begin 2if sym <> NIL then 4begin 6procsrch(sym^.llink); 6procsrch(sym^.rlink); 6procsrch(sym^.slink); ; { output code's seg table } &map: text; { map text output file } & ${ $* Buildworklists is called for all segmentslink); 2procsrch(sym^.slink); 2if sym^.entry.litype in okset then 4begin { place new node in list } 6new(wp); 6wp^.refsym : which need to $* be copied, and maybe need to have sepprocs or others stuff = sym; 6wp^.refseg := NIL; 6wp^.defsym := NIL; 6wp^.defseg := NIL; 6wp^.needsrch := TRUE; 6if sephost then 6 wp^.newproc $* fixed up within them. The idea here is to get a list $* of procs and other item needing attention, with $* all the sub:= 0 { see readsrcseg! } 6else 8wp^.newproc := sym^.entry.srcproc; 6wp^.next := work; 6work := wp 4end 0end ,end { procstle implications of global defs falling $* in procs which are not yet selected for linking etc. $* In fact, three lists are rch } ; ( (begin { findprocs } *work := NIL; *procsrch(symtab); *findprocs := work (end { findprocs } ; ( ({ (* Findnebuilt: $* The procs list with all procs and func to be grabbed $* from the various sep segs. $* The local list of rewprocs is called to place new procedures into the (* uprocs work list that are needed to resolve GLOBDEFs, fs in the original segment which must $* ALL be fixed up such as public or private refs in a unit seg. $* The other list (* SEPPREFs, and SEPFREFs. The other list is traversed and (* for each element whose defining proc has not been added (*  procsrch(symtab); .{ if we get here then didnt find it } .error('missing proc') ,end { findnadd } ; , (begin { findnewprocs,* not be found, an error is given. ,} , ,procedure sepsrch(oktype: litypes); .var syp: symp; 2sp: segp; ,begin .sp :=  } *wp := other; { assume only globref, seppref, sepfref in list } *while wp <> NIL do ,begin .if wp^.defproc = NIL theseplist; .while sp <> NIL do 0begin 2syp := symsrch(inlist^.refsym^.entry.name, Aoktype, sp^.symtab); 2if syp <> NIL then n 0begin { find proc/func needed } 2if wp^.refsym^.entry.litype = GLOBREF then 4pnum := wp^.defsym^.entry.homeproc 2else { a4begin 6inlist^.defsym := syp; 6inlist^.defseg := sp; 6sp := NIL 4end 2else 4sp := sp^.next 0end ,end { sepsrch } ; , ssume a SEP proc/func } 4pnum := wp^.defsym^.entry.srcproc; 2wp1 := procs; 2while wp1 <> NIL do 4if wp^.defseg = wp1^.defseg,{ ,* Procinsert is called to insert work into the procs ,* list using a special set of sort keys so that copyin- ,* procs then 6if wp1^.defsym^.entry.srcproc = pnum then 8begin { already gonna be linked } :wp^.defproc := wp1; :wp1 := NIL 8end  will run reasonably fast and use the disk ,* efficiently. The procs list is sorted by segment, ,* srcbase keys. The seg o6else 8wp1 := wp1^.next 4else 6wp1 := wp1^.next; 2if wp^.defproc = NIL then { forcibly link it } 4wp^.defproc := findnadd(rdering is dictated by the ,* seplist, so user ASECTS etc will retain their original ,* ordering. ,} , ,procedure procinswp^.defseg^.symtab) 0end; .wp := wp^.next ,end { while } (end { findnewprocs } ; ( ({ (* Resolve removes work items fromert(work: workp); , label 1; .var crnt, prev: workp; 2sp: segp; ,begin , prev := NIL; .sp := seplist; .while sp <> outl inlist, searches symtabs (* for its corresponding definition symbol (error if not found), (* and moves the work item into tist^.defseg do 0if sp = work^.defseg then 2goto 1 0else 2sp := sp^.next; .crnt := outlist; .repeat he output list. Each flavor (* of work item needs some special handling to collect extra (* info related to specific things0if crnt^.defseg = work^.defseg then 2repeat 4if work^.defsym^.entry.place^.srcbase < 7crnt^.defsym^.entry.place^.srcbase th. In general, defsym and (* defseg are filled in. The insert algorithm is special for (* procedure types to make life easen 6goto 1; 2 prev := crnt; 4crnt := crnt^.next; 4if crnt = NIL then 6goto 1 0 until crnt^.defseg <> work^.defseg 0else6if sym^.entry.litype in [SEPPROC, SEPFUNC] then 8if sym^.entry.srcproc = pnum then :begin  NIL then 6while sp <> crnt^.defseg do 8if sp = work^.defseg then  if unitsrch(hostfile, name, seg) = hostfile then @begin { will be found in host } Bdefsym := refsym; Bdefsegnum := seg :goto 1 8else :sp := sp^.next 2end .until crnt = NIL; *1: .if prev = NIL then 0begin 2work^.next := outlist; 2outlist :@end 0 else { "impossible" } @error('unit err') 0end { cases } ; , .wp := inlist; .inlist := wp^.next; .if = work 0end .else 0begin 2work^.next := prev^.next; 2prev^.next := work 0end ,end { procinsert } ; , (begin { resolve }wp^.defsym = NIL then 0with wp^.refsym^.entry do 2begin 4case litype of 6GLOBREF: write('Global '); 6PUBLREF: write('Publ *while inlist <> NIL do ,begin .with inlist^, refsym^.entry do 0case litype of 2GLOBREF: begin @sepsrch(GLOBDEF); @deic '); 4 CONSTREF: write('Const '); 6SEPPREF, 6EXTPROC: write('Proc '); 6SEPFREF, 6EXTFUNC: write('Func ') 4end { casesfproc := NIL >end; 2 2CONSTREF: if hostsp <> NIL then @begin Bdefsym := symsrch(name, CONSTDEF, Phostsp^.symtab); Bdefs } ; 4write(name); 4error(' undefined') 2end .else 0if (wp^.defsym^.entry.litype in [SEPPROC, SEPFUNC]) 0and (outlist <> eg := hostsp @end; 2 2PUBLREF: if hostsp <> NIL then @begin Bdefsym := symsrch(name, PUBLDEF, Phostsp^.symtab); NIL) then 0 procinsert(wp) 0else 2begin 4wp^.next := outlist; 4outlist := wp 2end ,end { while } (end { resolve } ; ( Bdefseg := hostsp @end; 2 2PRIVREF: begin @newoffset := nextbaselc; @nextbaselc := nextbaselc+nwords; @if hostsp <> NI({ (* Refsrch slowly goes through all reference lists in symbols (* which are in the okset to see if any "occur" within theL then Bdefsym := refsym; @defseg := hostsp >end; 2EXTPROC, 2SEPPROC, 2SEPPREF: begin @sepsrch(SEPPROC); @if litype = (* procedures/functions selected to be linked, that is contained (* in procs list. It is assumed that procs is sorted by d SEPPREF then Bdefproc := NIL; @err := FALSE; @if defsym <> NIL then Bif litype = SEPPREF then Derr := defsym^.entry.nparamefseg (* so only the procs between ipl and lpl are searched. s <> nwords Belse Derr := defsym^.entry.nparams <> nparams; @if err then Bbegin Dwrite('Proc ', name); Derror(' param mism(* Any symbols which have any refs in selected procs are given (* work nodes and are placed in the uother list in no certainatch') Bend >end; 2EXTFUNC, 2SEPFUNC, 2SEPFREF: begin @sepsrch(SEPFUNC); @if litype = SEPFREF then Bdefproc := NIL;  (* order so resolve can be called right away. (} ( (procedure refsrch(okset: liset; sp: segp); *var lpl, ipl: workp; .di@err := FALSE; @if defsym <> NIL then Bif litype = SEPFREF then Derr := defsym^.entry.nparams <> nwords Belse Derr := defsyffseg: boolean; . ,{ ,* Checkrefs recursivly searches sym tree to kind names ,* in the okset. When one is found, each of m^.entry.nparams <> nparams; @if err then Bbegin Dwrite('Func ', name); Derror(' param mismatch') Bend >end; 2 2UNITREF:its ref pointers ,* are checked to see if they fall in one of the procs ,* to-be-linked (between ipl & lpl). If so, a new w  .repeat 0diffseg := lpl^.defseg <> ipl^.defseg; 0if not diffseg then 2lpl := lpl^.next .until diffseg or (lpl = NIL); .ch NIL do .begin 0wp^.needsrch := TRUE; 0wp := wp^.next .end; ,sp := seplist; ,while sp <> NIL do .begin 0refsrch([PUBLREFeckrefs(sp^.symtab); .repeat 0ipl^.needsrch := FALSE; 0ipl := ipl^.next .until ipl = lpl ,end (end { refsrch } ; ( ({ , PRIVREF, CONSTREF], sp); 0sp := sp^.next .end; ,resolve(uother, other) *end $end { buildworklists } ;  (* findlocals recursivly searches the main segs symtab to (* place any unresolved things like public refs in unit (* segs ork item ,* is generated and it's put on the uother list. ,} , ,procedure checkrefs(sym: symp); .label 1, 2; .var pl, wp:into the ulocal list so they can be fixed up in (* fixuprefs in addition to the sep proc things. (} ( (procedure findlocals workp; 2i, n, ref: integer; 2rp: refp; ,begin .if sym <> NIL then 0begin 2checkrefs(sym^.llink); 2checkrefs(sym^.rlink);(sym: symp); *var wp: workp; (begin *if sym <> NIL then ,begin .findlocals(sym^.llink); .findlocals(sym^.rlink); .findloc 2checkrefs(sym^.slink); 2with sym^.entry do 4if litype in okset then 6begin 8n := nrefs; 8rp := reflist; 8while rp <> NIals(sym^.slink); .if sym^.entry.litype in [UNITREF, PUBLREF, PRIVREF] then 0begin 2new(wp); 2wp^.refsym := sym; 2wp^.refsegL do :begin  8 then >begin @i := 7; @n := n-8 >end i := n-1; ref := rp^.refs[i]; >pl := ipl; >repeat { search proc list } @if pl^.needsrch then Bwith pl^.defsym^.entry.place^ do Dif begin { buildworklists } &procs := NIL; &local := NIL; &other := NIL; &uprocs := NIL; &ulocal := NIL; &uother := NIL; &wiref < srcbase then Fgoto 2 { terminate proc search } Delse Fif ref < srcbase+length then Hbegin { occurs in proc } Jnew(wp)th seginfo[s]^ do (if segkind <> LINKED then *begin ,sephost := segkind = SEPRTSEG; ,if sephost then .begin 0next := sepli; Jwp^.refsym := sym; Jwp^.refseg := sp; Jwp^.defsym := NIL; Jwp^.defseg := NIL; Jwp^.next := uother; Juother := wp; Jgotst; 0seplist := seginfo[s]; 0uprocs := findprocs([SEPPROC, SEPFUNC], symtab) .end ,else o 1 Hend; @pl := pl^.next >until pl = lpl; :2: >i := i-1  NIL do .begin 0resolve(uprocs, procs); 0sp := seplist; ,end { checkrefs } ; ( (begin { refsrch } *ipl := NIL; *lpl := procs; *while lpl <> NIL do ,if (lpl^.defseg = sp) ,and l0while sp <> NIL do 2begin 4refsrch([GLOBREF, SEPPREF, SEPFREF], sp); 4sp := sp^.next 2end; 0resolve(uother, other); 0findpl^.needsrch then .begin 0ipl := lpl; 0lpl := NIL .end ,else .lpl := lpl^.next; *if ipl <> NIL then ,begin .lpl := ipl;newprocs .end; ,if not sephost then .begin 0findlocals(symtab); 0resolve(ulocal, local) .end; ,wp := procs; ,while wp <>  The linker is made up of three phases:  * Phase1 which open all input files, reads up seg tables  * from them and decides which segments are to be  * linked into the final code file.  * Phase2 reads the linker info for each segment that is  * going to be used, either to select sep procs from  * or copy with modifications i  (******************************************************************) $(* nto output code.  * The main symbol tree are built here, one for each  * code segment.  * Phase3 do *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribues the crunching of code segments into their  * final form by figuring out the procs that need to  * bete this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from t linked in, resolves all references (PUBLREF,  * GLOBREF, etc), patches the code pointed to by their he Institute for Information Systems. *) $(* *) $(******************************************************************) $  {$U-,R+   (UCSD PASCAL SYSTEM ( PROGRAM LINKER (O^ (Written summer '78 by (Roger T. Sumner, IIS ( (Copyright (c) 1978, Regents of (the University of California (  All hope abandon ye who enter here 8-Dante   }   program systemlevel;   const $SYSPROG = 4;   var $syscom: ^integer;  gfiles: array [0..5] of integer; $userinfo: record 0filler: array [0..4] of integer; 0slowterm, stupid: boolean; 0altmode: char; 0gotsym, gotcode: boolean; 0workvid, symvid, codevid: string[7]; 0worktid, symtid, codetid: string[15] .end;  filler: array [0..4] of integer; $syvid, dkvid: string[7];  junk1, junk2: integer; $cmdstate: integer;   {  * oc } $MAXPROC = 160; { max legal procedure number } $MSDELTA = 12; { mark stack size for pub/priv fixup } $  typeGLOBDEF, { global addr location } /PUBLDEF, { BASE var location } /CONSTDEF, { BASE const definition }  $ ${ subranges } ${ --------- } $ $segrange = 0..MAXSEG; { seg table subscript type } $segindex = 0..MAXSEG1; - { proc/func info, assem } 3{ to PASCAL and PASCAL } 3{ to PASCAL interface } /EXTPROC, { EXTERNAL proc to { wish we had const expressions! } $lcrange = 1..MAXLC; { base offsets a la P-code } $icrange = 0..MAXIC; { lebe linked into PASCAL } /EXTFUNC, { " func " " " " " } /SEPPROC, { Separate proc definitgal length for proc/func code } $procrange = 1..MAXPROC; { legit procedure numbers } $ ${ miscellaneous } ion record } /SEPFUNC, { " func " " } /SEPPREF, { PASCAL ref to a sep proc } /SEPFREF); ${ ------------- } $ $alpha = packed array [0..7] of char; $diskblock = packed array [0..511] of 0..255; $codefile = file;  { " ref to a sep func }  $liset = set of litypes; $opformat = (WORD, BYTE, BIG); { instruction operand { trick compiler to get ^file } $filep = ^codefile;  codep = ^diskblock; { space management...non-PASCA field formats } $ $lientry = record { format of link info records } 0name: alpha; 0case litype: litypes of 2SEPPREF, 2L kludge }  ${ link info structures } ${ ---- ---- ---------- } $ $placep = ^placerec; { position in source seg } SEPFREF, 2UNITREF, 2GLOBREF, 2PUBLREF, 2PRIVREF, 2CONSTREF: 8(format: opformat; { how to deal with the refs } $placerec = record / srcbase, destbase: integer; 1length: icrange /end { placerec } ; $ $refp = ^refnode; { in9nrefs: integer; { words following with refs } 9nwords: lcrange; { size of private or nparams } 9reflist: refp);-core version of ref lists } $refnode = record 0next: refp; 0refs: array [0..7] of integer; .end { refnode } ; 0 $litypes  { list of refs after read in }  EXTPROC, 2EXTFUNC, 2SEPPROC, 2SEPFUNC: 8(srcproc: procrange;  * reflists, and writes the final code seg(s).  }   segment procedure linker(iii, jjj: integer);   const $MA= (EOFMARK, { end-of-link-info marker } 3{ ext ref types, designates } 3{ fields to be updated by linker } /UNITXSEG = 15; { max code seg # in code files } $MAXSEG1 = 16; { MAXSEG+1, useful for loop vars } $MASTERSEG = 1; REF, { refs to invisibly used units (archaic?) } /GLOBREF, { refs to external global addrs } /PUBLREF,  { USERHOST segment number # } $FIRSTSEG = 7; { first linker assignable seg # } $MAXFILE = 7; { number of lib fi { refs to BASE lev vars in host } /PRIVREF, { refs to BASE vars, allocated by linker } les we can use } $MAXLC = MAXINT; { max compiler assigned address } $MAXIC = 2400; { max number bytes of code per pr/CONSTREF, { refs to host BASE lev constant } - { defining types, gives } 3{ linker values to fix refs } / dest seg } 2GLOBDEF: 8(homeproc: procrange; { which proc it occurs in } 9icoffset: icrange); { its byte offset in pcode ?codeleng, codeaddr: integer =end { diskinfo } ; $ segname: array [segrange] of alpha; 1segkind: array [segrange} 2PUBLDEF: 8(baseoffset: lcrange); { compiler assign word offset } 2CONSTDEF: 8(constval: integer); { users defined val] of segkinds; 1filler: array [0..143] of integer /end { I5segtbl } ; / $filekind = (USERHOST, USERLIB, SYSTEMLIB); $ $filue } 2EOFMARK: 8(nextlc: lcrange) { private var alloc info } 0end { lientry } ;  ${ symbol table items } ${ ------ einforec = record 4next: finfop; { link to next file thats open } 4code: filep; { pointer to PASCAL file...sneaky----- ----- } $ $symp = ^symbol; $symbol = record /llink, rlink, { binary subtrees for diff names } /slink: symp! } $ fkind: filekind; { used to validate the segkinds } 4segtbl: I5segtbl { disk seg table w/ source inf; { same name, diff litypes } /entry: lientry { actual id information } -end { symbol } ; $ o } 2end { fileinforec } ; 2   var $hostfile, { host file info ptr, its next = libfiles } $libfiles: finfop; ${ segment information } ${ ------- ----------- } $ $segkinds =(LINKED, { no work needed, executable as is } /HOST{ list of lib files, user and system } $ $seplist: segp; { list of sep segs to search through } $reflitypes: liset; { tSEG, { PASCAL host program outer block } /SEGPROC, { PASCAL segment procedure, not host } /UNITSEG, {hose litypes with ref lists } $ $talkative, $useworkfile: boolean; $ $errcount: integer; $heapbase: ^integer; $ $hostsp: library unit occurance/reference } /SEPRTSEG); { library separate proc/func TLA segment } $ $finfop = ^fileinforec;  segp; { ptr to host prog outer block }  { forward type dec } $ $segp = ^segrec; { this structure provides access to all } $segrec = record $nextbaselc: lcrange; { next base offset for private alloc } $seginfo: array [segrange] of segp; { seg is avai { info for segs to be linked to/from } /srcfile: finfop; { source file of segment } /srcseg: segrange; { solable if NIL } $nextseg: segindex; { next slot in seginfo available } $ $mapname: string[40]; $ $f0, f1, furce file seg # } /symtab: symp; { symbol table tree } /case segkind: segkinds of 1SEPRTSEG: 1 (next: segp)2, f3, $f4, f5, f6, f7, { input files with lurking pntrs } $code: codefile; { output  { used for library sep seg list } -end { segrec } ; $ ${ host/lib file access info } ${ ---- --- ---- ------ ---- } $ code file, *system.wrk.code } $ $  {  * Print an error message and bump  * the error counter.  }   procedure error(ms { the procnum in source seg } 9nparams: integer; { words passed/expected } 9place: placep); { position in source/$I5segtbl = record { first full block of all code files } 1diskinfo: array [segrange] of =record   useleft: boolean;  begin "newsym^.llink := NIL; "newsym^.rlink := NIL; "newsym^.slink := NIL; "if symtab = NIL then en.  }   function unitsrch(fp: finfop; var name: alpha; var seg: segrange): finfop; "label 1;  var s: segindex;  begin $symtab := newsym "else $begin { search symtab and add newsym } &syp := symtab; &repeat (lastsyp := syp; (if syp^.entry.nseg := 0; "while fp <> NIL do $begin &with fp^.segtbl do (for s := 0 to MAXSEG do *if segname[s] = name then ,if segkind[sg: string);  var ch: char;  begin "writeln(msg); "repeat $write('Type (continue), (terminate)'); $read(keyboardame > newsym^.entry.name then *begin syp := syp^.llink; useleft := TRUE end (else *if syp^.entry.name < newsym^.entry.name th, ch); $if ch = userinfo.altmode then &exit(linker) "until ch = ' '; "errcount := errcount+1  end { error } ;   {  * Ren ,begin syp := syp^.rlink; useleft := FALSE end *else { equal } ,begin { add into sideways list } .newsym^.slink := syp^.soutines to access object code segments. There  * is subtle business involving byte flipping with  * the 16-bit operations. link; .syp^.slink := newsym; .lastsyp := NIL; { already added flag } .syp := NIL { stop repeat loop } ,end &un This needs more research  * when the time comes.  }  {$R-}   function fetchbyte(cp: codep; offset: integer): integer; til syp = NIL; &if lastsyp <> NIL then (begin { add to bottom of tree } *if useleft then ,lastsyp^.llink := newsym *else , begin "fetchbyte := cp^[offset]  end { fetchbyte } ;   function fetchword(cp: codep; offset: integer): integer;  var ilastsyp^.rlink := newsym (end $end { symtab <> NIL }  end { entersym } ;   {  * Look up name in symtab tree and return p: integer;  begin "moveleft(cp^[offset], i, 2); "{ byte swap i } "fetchword := i  end { fetchword } ;   procedure storebointer  * to it. Oktype restricts what litype is  * acceptable. NIL is returned if name not found.  }   function symsryte(val: integer; cp: codep; offset: integer);  begin "cp^[offset] := val  end { storebyte } ;   procedure storeword(val: ch(var name: alpha; oktype: litypes; symtab: symp): symp;  var syp: symp;  begin  symsrch := NIL; "syp := symtab; integer; cp: codep; offset: integer);  begin "{ byte swap val } "moveleft(val, cp^[offset], 2)  end { storeword } ; $  {$R"while syp <> NIL do $if syp^.entry.name > name then &syp := syp^.llink $else &if syp^.entry.name < name then (syp := syp^+}   {  * Enter newsym in symtab tree. The tree is binary for  * different names and entries with the same name are ente.rlink &else { equal name } (if syp^.entry.litype <> oktype then *syp := syp^.slink (else { found! } *begin symsrch := syp;red  * onto sideways links (slink). No check is made for dup  * entry types, caller must do that. Nodes on slink will  *  syp := NIL end  end { symsrch } ;   {  * Search for the occurance of the unit segment  * given by name in the list of f always have NIL rlink and llink.  }   procedure entersym(newsym: symp; var symtab: symp); "var syp, lastsyp: symp;  iles in fp.  * Return the file and segment number in seg.  * NIL is returned for non-existant units and  * an error is giv he Institute for Information Systems. *) $(* *) $(******************************************************************) $  {  * Phase 1 opens host and library files and  * reads O^in seg tables. All fields are verified  * and the hostfile/libfiles file list is built.  * The prototype final seg table is set up in  * seginfo[*] from the host file and the sep seg  * list is set up for searching in later phases.  }   procedure phase1;  ${ $* Build file list opens input code files and reads segtbls. ] = UNITSEG then .goto 1; &fp := fp^.next $end; "write('Unit ', name); "error(' not found'); "s := 0;  1: "seg := s; "unitsrch := fp  end { unitsrch } ;   {  * Alphabetic returns TRUE if name contains all legal  * characters for PASCAL identifiers. Used to validate  * segnames and link info entries.  }   function alphabetic(var name: alpha): boolean; "label 1; "var i: integer;  begin "alphabetic := FALSE; "for i := 0 to 7 do $if not (name[i] in ['A'..'Z', '0'..'9', ' ', '_']) then &goto 1; "alphabetic := TRUE;  1:  end { alphabetic } ;   {  * Getcodep is a sneaky routine to point codep's anywhere  * in memory. It violates Robot's Rules of Order, but is  * very useful for dealing with t  (******************************************************************) $(* he variable size segments  }   function getcodep(memaddr: integer): codep;  var r: record +case boolean of -TRUE: (i:  *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribuinteger); -FALSE: (p: codep) +end;  begin  r.i := memaddr; "getcodep := r.p  end { getcodep } ;  te this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from t et of segkinds; ( ,{ ,* Getfilep returns a pointer to a file using unspeakable ,* methods, but the ends justify the means.error('bad diskinfo'); 6if not (segkind[s] in goodkinds) then 8error('bad seg kind'); 6if not alphabetic(segname[s]) then 8e ,} , ,function getfilep(var f: codefile): filep; .var a: array [0..0] of filep; ,begin .{$R-} .getfilep := a[-1]; .{$R+rror('bad seg name'); 6if errcount > errs then 8s := MAXSEG; 6s := s+1 4until s > MAXSEG; 2if alllinked and (kind = USERHOS} ,end { getfilep } ; , (begin { setupfile } *case num of ,0: cp := getfilep(f0); ,1: cp := getfilep(f1); T) then 4begin 6write('All segs linked'); 6exit(linker) 4end; 2if errcount = errs then 4hostfile := fp { ok fil,2: cp := getfilep(f2); ,3: cp := getfilep(f3); ,4: cp := getfilep(f4); ,5: cp := getfilep(f5); ,6: cp := getfilep(f6)e...link in } 0end ,end (end { setupfile } ; ( $begin { buildfilelist } &if talkative then (begin *for i := 1 to 7 do ,; ,7: cp := getfilep(f7) *end { cases } ; *reset(cp^, title); *if IORESULT <> 0 then ,if title <> 'in workspace' then .bewriteln; *writeln('Linker [I.5]') (end; &useworkfile := cmdstate <> SYSPROG; &with userinfo do (if useworkfile then *begingin 0insert('.CODE', title, length(title)+1); 0reset(cp^, title) .end; *if IORESULT <> 0 then ,begin .insert('No file ', t ,if gotcode then .fname := concat(codevid, ':', codetid) ,else .fname := 'in workspace'; ,setupfile(0, USERHOST, fname); itle, 1); .error(title); .if kind <> USERHOST then 0errcount := errcount-1 ,end *else ,begin { file open ok } .if talkati,setupfile(1, SYSTEMLIB, '*SYSTEM.LIBRARY') *end (else & begin ,write('Host file? '); ,readln(fname); ,if fname = '' tve then 0writeln('Opening ', title); .new(fp); .fp^.next := hostfile; .fp^.code := cp; .fp^.fkind := kind; .if blockread(chen .if gotcode then 0fname := concat(codevid, ':', codetid) .else 0fname := 'in workspace'; ,setupfile(0, USERHOST, fname)$* The var hostfile is set up as head of linked list of file $* info recs. The order of these files determines how id's $*p^, fp^.segtbl, 1, 0) <> 1 then 0error('segtbl read err') .else 0begin { now check segtbl values } 2s := 0; alllinked := TRU will be searched for. Note that libfiles points at the $* list just past the host file front entry. $} $ $procedure buiE; 2errs := errcount; 2if kind = USERHOST then 4goodkinds := [LINKED,SEGPROC,SEPRTSEG,HOSTSEG,UNITSEG] 2else 4goodkinds := ldfilelist; &label 1; &var f: 0..MAXFILE; *i: integer; *p, q: finfop; *fname: string[40]; $ ({ (* Setupfile opens file [LINKED,UNITSEG,SEPRTSEG]; 2with fp^.segtbl do 4repeat 6alllinked := alllinked and (segkind[s] = LINKED); and enters new finfo rec in (* hostfile list. Segtbl is read in and validated. (} ( (procedure setupfile(num: integer; kin6if (diskinfo[s].codeleng = 0) 6and (segkind[s] <> LINKED) then 8if (kind <> USERHOST) 8or (segkind[s] <> UNITSEG) then :erd: filekind; title: string); *var errs: integer; .s: segindex; .cp: filep; .fp: finfop; .alllinked: boolean; .goodkinds: sror('funny code seg'); 6if (diskinfo[s].codeleng < 0) 6or (diskinfo[s].codeaddr < 0) 6or (diskinfo[s].codeaddr > 300) then 8 , fname) .end; (1: * write('Map name? '); ,readln(mapname); ,if mapname <> '' then .if mapname[length(mapname)] = '.' the ; .if errs = errcount then 0seginfo[s] := sp .else 0seginfo[s] := NIL ,end; $ &{ now find first assignable seg } & &fon 0delete(mapname, length(mapname), 1) .else 0insert('.TEXT', mapname, length(mapname)+1) *end; , &{ now reverse list so hr s := FIRSTSEG to MAXSEG do (if seginfo[s] = NIL then *goto 1; &s := MAXSEG1; $1: &nextseg := s; &if seginfo[MASTERSEG] =ost is } &{ first and syslib is last } & &p := hostfile; hostfile := NIL; &repeat (q := p^.next; (p^.next := hostfile;  NIL then (error('wierd host') $end { buildseginfo } ; $ ${ $* Buildseplist searches through libraries and adds onto $* (hostfile := p; (p := q &until p = NIL; &libfiles := hostfile^.next; $end { buildfilelist } ; $ ${ a global list of sep segs that are to be searched $* for procs and globals. They are initially build in $* the reverse orde$* Buildseginfo initializes the seginfo table from $* the host prototype seg table. All legal states $* are checked, and r, then reversed again so searches $* will go in the order the files were specified. $} $ $procedure buildseplist; &var spimported units found. This $* leaves a list of all segs to finally appear in $* the output code file. $} $ $procedure bu, p, q: segp; *fp: finfop; *s: segindex; $begin &fp := libfiles; &while fp <> NIL do (begin *for s := 0 to MAXSEG do ,ifildseginfo; &label 1; &var s: segindex; *errs: integer; *sp: segp; $begin &with hostfile^.segtbl do (for s := 0 to MAXSEG fp^.segtbl.segkind[s] = SEPRTSEG then .begin 0new(sp); 0sp^.next := seplist; 0sp^.srcfile := fp; 0sp^.srcseg := s;  do *if (segkind[s] = LINKED) *and (diskinfo[s].codeleng = 0) then ,seginfo[s] := NIL { not in use } *else ,begin { do so0sp^.symtab := NIL; 0sp^.segkind := SEPRTSEG; 0sp^.next := seplist; 0seplist := sp .end; *fp := fp^.next (end; & &{ nowmething with seg } .errs := errcount; .new(sp); .sp^.srcfile := hostfile; .sp^.srcseg := s; .sp^.symtab := NIL; .sp^.segki reverse the list to maintain original order } & &p := seplist; seplist := NIL; &while p <> NIL do (begin *q := p^.next; *nd := segkind[s]; .case sp^.segkind of 0SEGPROC, 0LINKED: ; { nothing to check! } 0 0HOSTSEG: if s <> MASTERSEG then p^.next := seplist; *seplist := p; *p := q (end $end { buildseplist } ; $  begin { phase1 } " "{ initialize globals } "=error('bad host seg') ;else =if hostsp <> NIL then = error('dup host seg') =else ?hostsp := sp; 0 0SEPRTSEG: if s = M "hostfile := NIL; "libfiles := NIL; "hostsp := NIL; "seplist := NIL; "reflitypes := [UNITREF, GLOBREF, PUBLREF, 1PRIVREF,; ,if errcount > 0 then .exit(linker); { no host! } ,for f := 1 to MAXFILE do .begin 0write('Lib file? '); 0readln(fname);ASTERSEG then =sp^.next := NIL ;else =begin { put into seplist } ?sp^.next := seplist; ?seplist := sp; ?sp := NIL =end;  0if fname = '' then 2goto 1; 0if fname = '*' then 2setupfile(f, SYSTEMLIB, '*SYSTEM.LIBRARY') 0else 2setupfile(f, USERLIB0 0UNITSEG: if diskinfo[s].codeleng = 0 then =sp^.srcfile := unitsrch(libfiles, Tsegname[s], Tsp^.srcseg) .end { cases }   (******************************************************************) $(*  9: S := 'vol not found'; 10: S := 'file not found'; 11: S := 'dup dir entry'; 12: S := 'file already open';  CONSTREF, 1SEPPREF, SEPFREF]; "errcount := 0; "nextbaselc := 3; "mapname := ''; "talkative := not userinfo.slowterm; "mar *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribuk(heapbase); "unitwrite(3, heapbase^, 35); " "{ build list of input files } " "buildfilelist; "if errcount > 0 then $exitte this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from t(linker); " "{ init basic seg info table } " "buildseginfo; "if errcount > 0 then $exit(linker); $ "{ finally build sep he Institute for Information Systems. *) $(* *) $(****seg list } " "buildseplist; "if errcount > 0 then $exit(linker)  end { phase1 } ;  **************************************************************) $ SEGMENT PROCEDURE USERPROGRAM(INPUT,OUTPUT: FIBP); BEGIN FWRIO^TELN(SYSTERM^); PL := 'No user program'; FWRITESTRING(SYSTERM^,PL,0) END (*USERPROGRAM*) ; SEGMENT PROCEDURE DEBUGGER; BEGIٝN FWRITELN(SYSTERM^); PL := 'No debugger in system'; FWRITESTRING(SYSTERM^,PL,0) END (*DEBUGGER*) ; SEGMENT PROCEDURE PRINTERROR(XEQERR,IORSLT: INTEGER); VAR S: STRING[40]; BEGIN S := 'Unknown run-time error'; CASE XEQERR OF  1: S := 'Value range error'; 2: S := 'No proc in seg-table'; 3: S := 'Exit from uncalled proc'; 4: S := 'Stack overflow'; 5: S := 'Integer overflow'; 6: S := 'Divide by zero'; 7: S := 'NIL pointer reference'; 8: S := 'Program interrupted by user'; 9: S := 'System IO error'; 10: BEGIN S := 'unknown cause'; CASE IORSLT OF 1: S := 'parity (CRC)'; 2: S := 'illegal unit #'; 3: S := 'illegal IO request'; 4: S := 'data-com timeout'; 5: S := 'vol went off-line'; 6: S := 'file lost in dir'; 7: S := 'bad file name'; 8: S := 'no room on vol';  EGIN XEQERR := 0; IORSLT := INOERROR; BUGSTATE :=0 END; TITLE := '*SYSTEM.MISCINFO' ; RESET( F, TITLE ); OF CHAR; SET2: CHARSET; FILLER2: PACKED ARRAY [0..63] OF CHAR; TRITON: ARRAY [0..63,0..3] OF INTEGER END (*CHA IF IORESULT = ORD(INOERROR) THEN BEGIN IF NOT EOF( F ) THEN WITH SYSCOM^, F^ DO BEGIN MISCINFO := MSYSCOM.MRBUF*) ; LFIB: FIB; BEGIN FINIT(LFIB,NIL,-1); LTITLE := '*SYSTEM.CHARSET'; FOPEN(LFIB,LTITLE,TRUE,NIL); IF LISCINFO; ,CRTTYPE := MSYSCOM.CRTTYPE; ,CRTCTRL := MSYSCOM.CRTCTRL; CRTINFO := MSYSCOM.CRTINFO; ,FILLER[0] := CHR(SYSCOM^FIB.FISOPEN THEN BEGIN UNITWRITE(3,TRIX,128); IF IORESULT = ORD(INOERROR) THEN BEGIN WITH LFIB.FHEADER DO .CRTCTRL.FILLCOUNT); ,FILLCHAR( FILLER[1], SYSCOM^.CRTCTRL.FILLCOUNT, CHR(0) ); END; CLOSE( F, NORMAL ) END; END (*IBEGIN DOTRITON := DLASTBLK-DFIRSTBLK > 4; UNITREAD(LFIB.FUNIT,CHARBUF,SIZEOF(CHARBUF),DFIRSTBLK) END;  13: S := 'file not open'; 14: S := 'bad input format' END (*IO ERRORS*) ; INSERT('IO error: ',S,1) END; 11NITSYSCOM*) ; PROCEDURE INITUNITABLE; VAR LUNIT: UNITNUM; LDIR: DIRP; BEGIN FOR LUNIT := 0 TO MAXUNIT DO WITH: S := 'Unimplemented instruction'; 12: S := 'Floating point error'; 13: S := 'String overflow';  UNITABLE[LUNIT] DO BEGIN UVID := ''; UISBLKD := LUNIT IN [4,5,9..12]; IF UISBLKD THEN UEOVBLK := MMAXINT; UNITCLEAR(L 14: S := 'Programmed HALT'; 15: S := 'Programmed break-point' END (*XEQ ERRORS*) ; WRITELN(OUTPUT,S); WITH SYSCOM^UNIT); END; UNITABLE[1].UVID := 'CONSOLE'; UNITABLE[2].UVID := 'SYSTERM'; SYVID := ''; LUNIT := VOLSEARCH(SYVID.BOMBP^ DO WRITE(OUTPUT,'S# ',MSSEG^[0] MOD 256, ', P# ',MSJTAB^[0] MOD 256, ', I# ',MSIPC-(ORD(MSJTAB)-2-MSJTAB^[-1]),TRUE,LDIR); SYVID := UNITABLE[SYSCOM^.SYSUNIT].UVID; IF LENGTH(SYVID) = 0 THEN HALT; IF JUSTBOOTED THEN DKVID := SY) END (*PRINTERROR*) ; SEGMENT PROCEDURE INITIALIZE; VAR DOTRITON,JUSTBOOTED: BOOLEAN; LTITLE: STRING[40]; MONTHS: ARRAVID; LUNIT := VOLSEARCH(SYVID,FALSE,LDIR); IF LDIR = NIL THEN HALT; THEDATE := LDIR^[0].DLASTBOOT; Y [0..15] OF STRING[3]; &DISPLAY: ARRAY [0..79,0..19] OF INTEGER; (*FOR TRITON*) STKFILL: ARRAY [0..1199] OF INTEGER;  UNITCLEAR(6); IF IORESULT = ORD(INOERROR) THEN UNITABLE[6].UVID := 'PRINTER'; UNITCLEAR(8); IF IORESULT = PROCEDURE INITSYSCOM; VAR TITLE: STRING; F: FILE OF MISCINFOREC; BEGIN (* FIRST SOME GLOBALS *) FILLER[0] ORD(INOERROR) THEN UNITABLE[8].UVID := 'REMOTE'; END (*INITUNITABLE*) ; PROCEDURE INITCHARSET; TYPE CHARSET= ARRAY := CHR(SYSCOM^.CRTCTRL.FILLCOUNT); FILLCHAR( FILLER[1], SYSCOM^.CRTCTRL.FILLCOUNT, CHR(0) ); DEBUGINFO := NIL; IPOT[32..127] OF PACKED ARRAY [0..9] OF 0..255; VAR I: INTEGER; TRIX: RECORD CASE BOOLEAN OF TRUE: (CHARADDR: IN[0] := 1; IPOT[1] := 10; IPOT[2] := 100; IPOT[3] := 1000; IPOT[4] := 10000; DIGITS := ['0'..'9']; WITH SYSCOM^ DO BTEGER); FALSE: (CHARBUFP: ^ CHAR) END; CHARBUF: RECORD SET1: CHARSET; FILLER1: PACKED ARRAY [0..63]  (*BASIC FILE AND HEAP SETTUP*) SYSCOM^.GDIRP := NIL; (* MUST PRECEDE THE FIRST "NEW" EXECUTED *) NEW(SWAPFIB,TRUE,FALSE)YSCOM^.MISCINFO.STUPID END END (*INITWORKFILE*) ; PROCEDURE INITFILES; BEGIN FCLOSE(SWAPFIB^,CNORMAL); FCLO; FINIT(SWAPFIB^,NIL,-1); NEW(INPUTFIB,TRUE,FALSE); NEW(LWINDOW); FINIT(INPUTFIB^,LWINDOW,0); SE(USERINFO.SYMFIBP^,CNORMAL); FCLOSE(USERINFO.CODEFIBP^,CNORMAL); FCLOSE(INPUTFIB^,CNORMAL); FCLOSE(OUTPUTFIB^,CNOR NEW(OUTPUTFIB,TRUE,FALSE); NEW(LWINDOW); FINIT(OUTPUTFIB^,LWINDOW,0); NEW(SYSTERM,TRUE,FALSE); NEW(LWINDOW); FMAL); LTITLE := 'CONSOLE:'; FOPEN(INPUTFIB^,LTITLE,TRUE,NIL); FOPEN(OUTPUTFIB^,LTITLE,TRUE,NIL); IF JUSTBOOTED TINIT(SYSTERM^,LWINDOW,0); GFILES[0] := INPUTFIB; GFILES[1] := OUTPUTFIB; WITH USERINFO DO BEGIN NEW(SYMFIBP,TRUE,HEN BEGIN LTITLE := 'SYSTERM:'; FOPEN(SYSTERM^,LTITLE,TRUE,NIL) END; GFILES[0] := INPUTFIB; GFILES[1] := OUFALSE); FINIT(SYMFIBP^,NIL,-1); NEW(CODEFIBP,TRUE,FALSE); FINIT(CODEFIBP^,NIL,-1) END; MARK(EMPTYHEAP) END (*INITHETPUTFIB; GFILES[2] := SYSTERM; GFILES[3] := NIL; GFILES[4] := NIL; GFILES[5] := NIL; END (*INITFILES*) ; AP*) ; PROCEDURE INITWORKFILE; BEGIN WITH USERINFO DO BEGIN (*INITIALIZE WORK FILES ETC*) ERRNUM := 0; ERRBLK :=BEGIN (*INITIALIZE*) JUSTBOOTED := EMPTYHEAP = NIL; DOTRITON := FALSE; MONTHS[ 0] := '???'; MONTHS[ 1] := 'Jan'; MONTHS[ 0; ERRSYM := 0; IF JUSTBOOTED THEN BEGIN SYMTID := ''; CODETID := ''; WORKTID := ''; SYMVID := SYVID; CODEVID :=  2] := 'Feb'; MONTHS[ 3] := 'Mar'; MONTHS[ 4] := 'Apr'; MONTHS[ 5] := 'May'; MONTHS[ 6] := 'Jun'; MONTHS[ 7] := 'Jul'; MON TRIX.CHARADDR := 512-8192; (*UNIBUS TRICKYNESS!*) FOR I := 32 TO 127 DO BEGIN MOVERIGHT(CHARBUF.SET1[I],TRIX.SYVID; WORKVID := SYVID END; IF LENGTH(SYMTID) > 0 THEN LTITLE := CONCAT(SYMVID,':',SYMTID) ELSE LTITLE := '*SCHARBUFP^,10); TRIX.CHARADDR := TRIX.CHARADDR+16 END; TRIX.CHARADDR := 512-6144; FOR I := 32 TO 127 DO YSTEM.WRK.TEXT'; FOPEN(SYMFIBP^,LTITLE,TRUE,NIL); GOTSYM := SYMFIBP^.FISOPEN; IF GOTSYM THEN BEGIN SYMVID := SYMFIB BEGIN MOVERIGHT(CHARBUF.SET2[I],TRIX.CHARBUFP^,10); TRIX.CHARADDR := TRIX.CHARADDR+16 END; UNITABLE[3].UVID := P^.FVID; SYMTID := SYMFIBP^.FHEADER.DTID END; FCLOSE(SYMFIBP^,CNORMAL); IF LENGTH(CODETID) > 0 THEN 'GRAPHIC'; UNITWRITE(3,I,0) END END ELSE SYSCOM^.MISCINFO.HAS8510A := FALSE; IF DOTRITON THEN  LTITLE := CONCAT(CODEVID,':',CODETID) ELSE LTITLE := '*SYSTEM.WRK.CODE'; FOPEN(CODEFIBP^,LTITLE,TRUE,NIL);BEGIN (*INITIALIZE DISPLAY ARRAY*) FILLCHAR(DISPLAY,SIZEOF(DISPLAY),0); FOR I := 0 TO 63 DO MOVELEFT(CHARBUF.TRITON[I],DISP GOTCODE := CODEFIBP^.FISOPEN; IF GOTCODE THEN BEGIN CODEVID := CODEFIBP^.FVID; CODETID := CODEFIBP^.FHEADER.DTID ELAY[I,10],8) END; FCLOSE(LFIB,CNORMAL) END (*INITCHARSET*) ; PROCEDURE INITHEAP; VAR LWINDOW: WINDOWP; BEGIN ND; FCLOSE(CODEFIBP^,CNORMAL); ALTMODE := SYSCOM^.CRTINFO.ALTMODE; SLOWTERM := SYSCOM^.MISCINFO.SLOWTERM; STUPID := S SCREEN; WRITELN(OUTPUT); IF JUSTBOOTED THEN BEGIN IF DOTRITON THEN BEGIN (*ASSUME DATA MEDIA SCREEN*) UNITREAD(CODEFIBP^.FUNIT,SEGTBL,SIZEOF(SEGTBL), CODEFIBP^.FHEADER.DFIRSTBLK); IF IORESULT <> ORD(INOERROR) THEN BEGIN WRITE(OUTPUT,CHR(30),CHR(32),CHR(41)); UNITWRITE(3,DISPLAY[-80],23) END; WRITELN(OUTPUT,'Welcome ', WRITE(OUTPUT,'Bad block #0'); GOTO 1 END; WITH SEGTBL DO FOR LSEG := 0 TO MAXSEG DO IF NOT (SSYVID,', to'); IF DOTRITON THEN WRITELN(OUTPUT); WRITELN(OUTPUT,'U.C.S.D. Pascal System I.5'); EGKIND[LSEG] IN [LINKED..SEPRTSEG]) THEN BEGIN { PRE I.5 CODE...FIX UP! } FILLCHAR(SEGKIND, SIZEOF(SEGKIND), ORD(LINKED)); IF DOTRITON THEN WRITELN(OUTPUT); WITH THEDATE DO WRITE(OUTPUT,'Current date is ',DAY,'-',MONTHS[MONTH],'-',YEAR)  FILLCHAR(FILLER, SIZEOF(FILLER), 0); UNITWRITE(CODEFIBP^.FUNIT, SEGTBL, SIZEOF(SEGTBL), CODEFIBP^.FHEADER.DFIRSTBLK END ELSE WRITE(OUTPUT,'System re-initialized') END (*INITIALIZE*) ; SEGMENT FUNCTION GETCMD(LASTST: CMDSTATE): CMDSTA) END; WITH SEGTBL DO FOR LSEG := 0 TO MAXSEG DO IF SEGKIND[LSEG] <> LINKED THEN BEGIN IF OKTOLINK THETE; CONST ASSEMONLY = LINKANDGO; "VAR CH: CHAR; BADCMD: BOOLEAN; PROCEDURE RUNWORKFILE(OKTOLINK, RUNONLY: BOOLEAN); FON BEGIN WRITELN(OUTPUT,'Linking...'); FCLOSE(CODEFIBP^, CNORMAL); RWARD; FUNCTION ASSOCIATE(TITLE: STRING; OKTOLINK, RUNONLY: BOOLEAN): BOOLEAN; LABEL 1; VAR RSLT: IORSLTWD; LSEG: SEG IF ASSOCIATE('*SYSTEM.LINKER', FALSE, FALSE) THEN BEGIN IF RUNONLY THEN GETCMD := LINKANDGO ELSE GETCMD := LRANGE; SEGTBL: RECORD DISKINFO: ARRAY [SEGRANGE] OF SEGDESC; SEGNAME: ARRAY [SEGRANGE] OF PACKED ARRAY [0..7] INKDEBUG; EXIT(GETCMD) END END ELSE IF NOT (LASTST IN [LINKANDGO, LINKDEBUG]) THEN 2 WRITE(OUTPUT,'Must LOF CHAR; SEGKIND: ARRAY [SEGRANGE] OF (LINKED,HOSTSEG,SEGPROC,UNITSEG,SEPRTSEG); FILLER: ARRAY [0..143] OF INTEG(ink first'); GOTO 1 END; FOR LSEG := 1 TO MAXSEG DO IF (LSEG = 1) OR (LSEG >= 7) THEN WITH SEGTABLE[LSEER END { SEGTBL } ; BEGIN ASSOCIATE := FALSE; FOPEN(USERINFO.CODEFIBP^,TITLE,TRUE,NIL); RSLT := SYSCOM^.IORSLT; G],SEGTBL.DISKINFO[LSEG] DO BEGIN CODEUNIT := CODEFIBP^.FUNIT; CODEDESC.CODELENG := CODELENG; CODEDESC.DISKADDR := DISTHS[ 8] := 'Aug'; MONTHS[ 9] := 'Sep'; MONTHS[10] := 'Oct'; MONTHS[11] := 'Nov'; MONTHS[12] := 'Dec'; MONTHS[13] := '???'; IF RSLT <> INOERROR THEN BEGIN IF TITLE <> '*SYSTEM.STARTUP' THEN *IF RSLT = IBADTITLE THEN  MONTHS[14] := '???'; MONTHS[15] := '???'; IF JUSTBOOTED THEN INITHEAP ELSE RELEASE(EMPTYHEAP); INITUNITABLE; (*AND THEDAT,WRITE(OUTPUT,'Illegal file name') *ELSE ,WRITE(OUTPUT,'No file ',TITLE); (GOTO 1 END; WITH USERINFO,SYSCOM^ DO E*) INITFILES; INITWORKFILE; IF SYSCOM^.MISCINFO.HAS8510A THEN INITCHARSET; INITSYSCOM; (*AND SOME GLOBALS*) CLEAR IF CODEFIBP^.FHEADER.DFKIND <> CODEFILE THEN BEGIN WRITE(OUTPUT,TITLE,' not code'); GOTO 1 END ELSE BEGIN  KADDR+ CODEFIBP^.FHEADER.DFIRSTBLK END END; ASSOCIATE := TRUE; 1: FCLOSE(USERINFO.CODEFIBP^,CNORMAL) END (*ASSOCIRBLK > 0 THEN BEGIN CLEARSCREEN; WRITELN(OUTPUT); IF ASSOCIATE('*SYSTEM.EDITOR', FALSE, FALSE) THEN BEGIN GETCMD :ATE*) ; PROCEDURE STARTCOMPILE(NEXTST: CMDSTATE); LABEL 1; VAR TITLE: STRING[40]; BEGIN IF NEXTST = ASSEMONLY T= SYSPROG; EXIT(GETCMD) END END END ELSE BEGIN GOTCODE := TRUE; CODEVID := CODEFIBP^.FVID; CODETID := CODEFIBHEN &WRITE(OUTPUT,'Assembling') $ELSE &WRITE(OUTPUT,'Compiling'); $WRITELN(OUTPUT,'...'); $IF NEXTST = ASSEMONLY THEN &TITP^.FHEADER.DTID; FCLOSE(CODEFIBP^,CLOCK); IF LASTST IN [COMPANDGO,COMPDEBUG] THEN RUNWORKFILE(TRUE, LASTST = COMPANDGLE := '*SYSTEM.ASSMBLER' $ELSE $ TITLE := '*SYSTEM.COMPILER'; $IF ASSOCIATE(TITLE, FALSE, FALSE) THEN &WITH USERINFO DO O) END END (*FINISHCOMPILE*) ; PROCEDURE EXECUTE; VAR TITLE: STRING[255]; BEGIN WRITE(OUTPUT,'Execute'); IF (BEGIN ,IF GOTSYM THEN .TITLE := CONCAT(SYMVID,':',SYMTID) ,ELSE .BEGIN 0IF NEXTST = ASSEMONLY THEN 2WRITE(OUTPUT, 'AssemNOT SYSCOM^.MISCINFO.SLOWTERM THEN WRITE(OUTPUT,' what file'); WRITE(OUTPUT,'? '); READLN(TITLE); IF LENGTH(TITLE)ble') 0ELSE 2WRITE(OUTPUT, 'Compile'); 0WRITE(OUTPUT,' what text? '); 0READLN(INPUT, TITLE); IF TITLE = '' THEN GOTO 1;  > 0 THEN BEGIN IF TITLE[LENGTH(TITLE)] = '.' THEN DELETE(TITLE,LENGTH(TITLE),1) ELSE INSERT('.CODE',TITLE,LENGTH(INSERT('.TEXT', TITLE, LENGTH(TITLE)+1); GOTCODE := FALSE .END; ,FOPEN(SYMFIBP^,TITLE,TRUE,NIL); ,IF IORESULT <> ORD(INOERRTITLE)+1); IF ASSOCIATE(TITLE, FALSE, FALSE) THEN BEGIN GETCMD := SYSPROG; EXIT(GETCMD) END END END (*EXECUTE*) ; OR) THEN .BEGIN 0WRITE(OUTPUT,'Can''t find ', TITLE); 0GOTSYM := FALSE; GOTO 1 .END; ,TITLE := '*SYSTEM.SWAPDISK'; ,FOPEN PROCEDURE RUNWORKFILE; BEGIN WITH USERINFO DO IF GOTCODE THEN BEGIN CLEARSCREEN; IF ASSOCIATE(CONCAT(CODEVID,(SWAPFIB^,TITLE,TRUE,NIL); ,TITLE := '*SYSTEM.WRK.CODE[*]'; ,FOPEN(CODEFIBP^,TITLE,FALSE,NIL); ,IF IORESULT <> ORD(INOERROR) ':',CODETID), OKTOLINK, RUNONLY) THEN BEGIN WRITELN(OUTPUT,'Running...'); IF RUNONLY THEN GETCMD := SYSPROG THEN .BEGIN 0WRITE(OUTPUT,'Code open error!'); 0GOTO 1 .END; ,ERRNUM := 0; ERRBLK := 0; ERRSYM := 0; ,IF NEXTST = ASSEMONELSE GETCMD := DEBUGCALL; EXIT(GETCMD) END; IF NOT (LASTST IN [LINKANDGO, LINKDEBUG]) THEN *GOTCODE := FALSE ELY THEN .NEXTST := COMPONLY; ,GETCMD := NEXTST; EXIT(GETCMD) (END; "1: END (*STARTCOMPILE*) ; PROCEDURE FINISHCOMPILE; ND ELSE IF RUNONLY THEN STARTCOMPILE(COMPANDGO) ELSE STARTCOMPILE(COMPDEBUG) END { RUNWORKFILE } ; BEGIN (* BEGIN FCLOSE(USERINFO.SYMFIBP^,CNORMAL); FCLOSE(SWAPFIB^,CNORMAL); IF SYSCOM^.MISCINFO.HAS8510A THEN GETCMD*) FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^); GFILES[0] := INPUTFIB; GFILES[1] := OUTPUTFIB; IF LASTST UNITCLEAR(3); WITH USERINFO DO IF ERRNUM > 0 THEN BEGIN GOTCODE := FALSE; FCLOSE(CODEFIBP^,CPURGE); IF ER = HALTINIT THEN $IF ASSOCIATE('*SYSTEM.STARTUP',FALSE,FALSE) THEN &BEGIN CLEARSCREEN; (WRITELN(OUTPUT,'Initializing...'); &  IF ASSOCIATE('*SYSTEM.LINKER', FALSE, FALSE) THEN BEGIN GETCMD := SYSPROG; EXIT(GETCMD) END END; 'X': EXECUTE; 'C': STARTCOMPILE(COMPONLY); 'A': STARTCOMPILE(ASSEMONLY); ('U': IF LASTST <> UPROGNOU THEN BEGIN WRITELN(OUTPUT,'Restarting...'); GETCMD := SYSPROG; EXIT(GETCMD) END ELSE BEGIN WRITELN(OUTPUT); WRITE(OUTPUT,'U not allowed') END;  GETCMD := SYSPROG; EXIT(GETCMD) &END; "IF LASTST IN [COMPONLY,COMPANDGO,COMPDEBUG] THEN FINISHCOMPILE; IF LASTST IN [L 'R','D': RUNWORKFILE(TRUE, CH = 'R'); 'I','H': BEGIN GETCMD := HALTINIT; IF CH = 'H' THEN EMPTYHEAP := NIL; EINKANDGO,LINKDEBUG] THEN RUNWORKFILE(FALSE, LASTST = LINKANDGO); "IF SYSCOM^.MISCINFO.USERKIND = AQUIZ THEN XIT(GETCMD) END END UNTIL FALSE END (*GETCMD*) ; $IF LASTST = HALTINIT THEN $ BEGIN LASTST := COMPANDGO; RUNWORKFILE(TRUE, TRUE) END $ELSE &BEGIN (EMPTYHEAP := NIL; (GETCMD := HALTINIT; (EXIT(GETCMD) &END; WITH USERINFO DO BEGIN ERRNUM := 0; ERRBLK := 0; ERRSYM := 0 END; BADCMD := FALSE; REPEAT PL :=  'Command: E(dit, R(un, F(ile, C(omp, L(ink, X(ecute, A(ssem, D(ebug,? [I.5]'; PROMPT; CH := GETCHAR(BADCMD); CLEARSCREEN; IF CH = '?' THEN &BEGIN PL := 'Command: U(ser restart, I(nitialize, H(alt'; (PROMPT; CH := GETCHAR(BADCMD); CLEARSCREEN &END; $BADCMD := NOT (CH IN ['E','R','F','C','L','X','A','D','U','I','H','?']); IF NOT BADCMD THEN  CASE CH OF 'E': BEGIN WRITELN(OUTPUT); IF ASSOCIATE('*SYSTEM.EDITOR', FALSE, FALSE) THEN BEGIN GETCMD := SYSPROG; EXIT(O^GETCMD) END END; 'F': BEGIN WRITELN(OUTPUT); IF ASSOCIATE('*SYSTEM.FILER', FALSE, FALSE) THEN BEGIN GETCMD := SYSPROG; EXIT(GETCMD) END END; 'L': BEGIN WRITELN(OUTPUT,'Linking...');   GFILES[0] := INPUTFIB; GFILES[1] := OUTPUTFIB; BOMBIPC := IORESULT; FWRITELN(SYSTERM^); OM^,CRTCTRL DO BEGIN IF MISCINFO.HAS8510A THEN UNITCLEAR(3); IF ERASEEOS <> CHR(0) THEN BEGIN IF ESCAPE <> C IF UNITABLE[SYSUNIT].UVID = SYVID THEN PRINTERROR(XEQERR,BOMBIPC) ELSE BEGIN WRITE(OUTPUT,'Exec err # ',XHR(0) THEN WRITE(OUTPUT,ESCAPE); WRITE(OUTPUT,ERASEEOS); IF LENGTH(FILLER) > 0 THEN WRITE(OUTPUT,FILLER) END EQERR); IF XEQERR = 10 THEN WRITE(OUTPUT,',',BOMBIPC) END; WRITELN(OUTPUT); IF NOT SPACEWAIT(TRUE) THEN EXIT END END (*CLEARSCREEN*) ; PROCEDURE CLEARLINE; BEGIN WITH SYSCOM^,CRTCTRL DO IF ERASEEOL <> CHR(0) THEN BEGIN IF(COMMAND) END END END (*EXECERROR*) ; FUNCTION CHECKDEL(CH: CHAR; VAR SINX: INTEGER): BOOLEAN; BEGIN CHECKDEL := FALSE;  ESCAPE <> CHR(0) THEN WRITE(OUTPUT,ESCAPE); WRITE(OUTPUT,ERASEEOL); IF LENGTH(FILLER) > 0 THEN WRITE(OUTPUT,FILLER) WITH SYSCOM^,CRTCTRL,CRTINFO DO BEGIN IF CH = LINEDEL THEN BEGIN CHECKDEL := TRUE; IF (BACKSPACE = CHR(0)) OR (ERA END END (*CLEARLINE*) ; PROCEDURE PROMPT; VAR I: INTEGER; BEGIN HOMECURSOR; WITH SYSCOM^,CRTCTRL DO BEGIN CSEEOL = CHR(0)) THEN BEGIN SINX := 1; WRITELN(OUTPUT,' 1 DO LEARLINE; IF MISCINFO.SLOWTERM THEN BEGIN I := SCAN(LENGTH(PL),=':',PL[1]); IF I <> LENGTH(PL) THEN PL[0] := CHR(I+  (******************************************************************) $(* BEGIN SINX := SINX-1; WRITE(OUTPUT,BACKSPACE) END; WRITE(OUTPUT,ESCAPE,ERASEEOL) END END; IF CH = CHARDEL THE *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribuN BEGIN CHECKDEL := TRUE; IF SINX > 1 THEN BEGIN SINX := SINX-1; IF BACKSPACE = CHR(0) THEN IF CHARDEL < ' ' Tte this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from tHEN WRITE(OUTPUT,'_') ELSE (*ASSUME PRINTABLE*) ELSE BEGIN IF CHARDEL <> BACKSPACE THEN he Institute for Information Systems. *) $(* *) $(**** WRITE(OUTPUT,BACKSPACE); WRITE(OUTPUT,' ',BACKSPACE) END END ELSE IF CHARDEL = BACKSPACE THEN WR**************************************************************) $ PROCEDURE EXECERROR; BEGIN WITH SYSCOM^ DO BEGIN ITE(OUTPUT,' ') END END END (*CHECKDEL*) ; PROCEDURE HOMECURSOR; BEGIN WITH SYSCOM^,CRTCTRL DO BEGIN IF ESCAPEIF XEQERR = 4 THEN BEGIN RELEASE(EMPTYHEAP); PL := '*STK OFLOW*'; UNITWRITE(2,PL[1],LENGTH(PL)); EXIT(COMMAND) END;  <> CHR(0) THEN FWRITECHAR(SYSTERM^,ESCAPE,1); FWRITECHAR(SYSTERM^,HOME,1); IF (LENGTH(FILLER) > 0) AND (HOME <> CH BOMBP^.MSIPC := BOMBIPC; IF BUGSTATE <> 0 THEN BEGIN DEBUGGER; XEQERR := 0 END ELSE BEGIN RELEASE(EMPTYHEAP);R(EOL)) THEN FWRITESTRING(SYSTERM^,FILLER,0) END END (*HOMECURSOR*) ; PROCEDURE CLEARSCREEN; BEGIN HOMECURSOR; WITH SYSC ; READ(INPUT,CH); IF (CH >= 'a') AND (CH <= 'z') THEN CH := CHR(ORD(CH)-ORD('a')+ORD('A')); GETCHAR := CH END (*GETCHAE ELSE BEGIN OK := FALSE; RBRACK := POS(']',FTITLE); IF RBRACK = 2 THEN OK := TRUE ELSE IF RBRACK > 2R*) ; FUNCTION SPACEWAIT(*FLUSH: BOOLEAN*); VAR CH: CHAR; BEGIN REPEAT WRITE(OUTPUT,'Type ');  THEN BEGIN OK := TRUE; I := 2; REPEAT CH := FTITLE[I]; IF CH IN DIGITS THEN FSEGS := FSEGS*10+(ORD(CH)-O IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN WRITE(OUTPUT,' to continue'); CH := GETCHAR(FLUSH); IF NOT EOLN(INPUT) TRD('0')) ELSE OK := FALSE; I := I+1 UNTIL (I = RBRACK) OR NOT OK; IF (I = 3) AND (RBRACK = 3) THEN IF FTITLHEN WRITELN(OUTPUT); CLEARLINE UNTIL (CH = ' ') OR (CH = SYSCOM^.CRTINFO.ALTMODE); SPACEWAIT := CH <> ' ' END (*SPE[I-1] = '*' THEN BEGIN FSEGS := -1; OK := TRUE END END END; SCANTITLE := OK; IF OK AND (LENGTH(FACEWAIT*) ; FUNCTION SCANTITLE(*FTITLE: STRING; VAR FVID: VID; VAR FTID: TID; VAR FSEGS: INTEGER; VAR FKIND: FILEKIND*); TID) > 5) THEN BEGIN FTITLE := COPY(FTID,LENGTH(FTID)-4,5); IF FTITLE = '.TEXT' THEN FKIND := TEXTFILE ELSE  VAR I,RBRACK: INTEGER; CH: CHAR; OK: BOOLEAN; BEGIN FVID := ''; FTID := ''; FSEGS := 0; FKIND := UNTYPEDFILE; SCANTITLE  IF FTITLE = '.CODE' THEN FKIND := CODEFILE ELSE IF FTITLE = '.INFO' THEN FKIND := INFOFILE ELSE IF FTITLE = := FALSE; I := 1; WHILE I <= LENGTH(FTITLE) DO BEGIN CH := FTITLE[I]; IF CH <= ' ' THEN DELETE(FTITLE,I,1) ELS'.GRAF' THEN FKIND := GRAFFILE ELSE IF FTITLE = '.FOTO' THEN FKIND := FOTOFILE END END END END END (*SCANTITE BEGIN IF (CH >= 'a') AND (CH <= 'z') THEN FTITLE[I] := CHR(ORD(CH)-ORD('a')+ORD('A')); I := I+1 END END; IFLE*) ; (* VOLUME AND DIRECTORY HANDLERS *) FUNCTION FETCHDIR(FUNIT: UNITNUM): BOOLEAN; VAR LINX: DIRRANGE; OK: BOOLEAN; HNOW LENGTH(FTITLE) > 0 THEN BEGIN IF FTITLE[1] = '*' THEN BEGIN FVID := SYVID; DELETE(FTITLE,1,1) END; I := POS(':: INTEGER; BEGIN FETCHDIR := FALSE; WITH SYSCOM^,UNITABLE[FUNIT] DO BEGIN (*READ IN AND VALIDATE DIR*) IF GDIRP = NI1) END END; WRITE(OUTPUT,PL) END (*PROMPT*) ; PROCEDURE FGOTOXY(*X,Y: INTEGER*); BEGIN (*ASSUME DATA MEDIA*) WITH SYSC',FTITLE); IF I <= 1 THEN BEGIN IF LENGTH(FVID) = 0 THEN FVID := DKVID; IF I = 1 THEN DELETE(FTITLE,1,1) END OM^.CRTINFO DO BEGIN IF X < 0 THEN X := 0; IF X > WIDTH THEN X := WIDTH; IF Y < 0 THEN Y := 0; IF Y  ELSE IF I-1 <= VIDLENG THEN BEGIN FVID := COPY(FTITLE,1,I-1); DELETE(FTITLE,1,I) END; IF LENGTH(FVI> HEIGHT THEN Y := HEIGHT END; WRITE(OUTPUT,CHR(30),CHR(X+32),CHR(Y+32)) END (*GOTOXY*) ; FUNCTION GETCHAR(*FLUSH: BOOLEAD) > 0 THEN BEGIN I := POS('[',FTITLE); IF I > 0 THEN I := I-1 ELSE I := LENGTH(FTITLE); IF I <= TIDLENG THEN N*); VAR CH: CHAR; BEGIN IF FLUSH THEN UNITCLEAR(1); IF INPUTFIB^.FEOF THEN EXIT(COMMAND); INPUTFIB^.FSTATE := FNEEDCHARBEGIN IF I > 0 THEN BEGIN FTID := COPY(FTITLE,1,I); DELETE(FTITLE,1,I) END; IF LENGTH(FTITLE) = 0 THEN OK := TRU GDIRP^[0] DO BEGIN OK := FALSE; (*CHECK OUT DIR*) IF (DFIRSTBLK = 0) AND ( (MISCINFO.USERKIND=BOOKER) .OR ( (MISCINND SYSCOM^.MISCINFO.HASCLOCK; IF NOT OK THEN BEGIN (*NO CLOCK OR TOO OLD*) UNITREAD(FUNIT,LDE,SIZEOF(DIRENTFO.USERKIND IN [AQUIZ,PQUIZ]) AND (DFKIND=SECUREDIR) ) OR ( (MISCINFO.USERKIND=NORMAL) AND (DFKIND=UNTYPEDFILE) ) ) RY),DIRBLK); IF IORESULT = ORD(INOERROR) THEN OK := DVID = LDE.DVID; END; IF OK THEN BEGIN (*WE GUESS ALL THEN IF (LENGTH(DVID) > 0) AND (LENGTH(DVID) <= VIDLENG) AND (DNUMFILES >= 0) AND (DNUMFILES <= MAXDIR) THEN IS SAFE...WRITEIT*) DFIRSTBLK := 0; (*DIRTY FIX FOR YALOE BUGS*) UNITWRITE(FUNIT,FDIR^, (DNUMFILES+1)*SIZEOF(DI BEGIN OK := TRUE; (*SO FAR SO GOOD*) IF DVID <> UVID THEN BEGIN (*NEW VOLUME IN UNIT...CAREFUL*) LINX := 1; RENTRY),DIRBLK); OK := IORESULT = ORD(INOERROR); IF DLASTBLK = 10 THEN (*REDUNDANT AFTERTHOUGHT*) UNITWRITE(FUNI WHILE LINX <= DNUMFILES DO WITH GDIRP^[LINX] DO IF (LENGTH(DTID) <= 0) OR (LENGTH(DTID) > TIDLENG) OR T,FDIR^, (DNUMFILES+1)*SIZEOF(DIRENTRY),6); IF OK THEN TIME(HNOW,DLOADTIME) END END; IF NOT OK THEN BEG (DLASTBLK < DFIRSTBLK) OR (DLASTBYTE > FBLKSIZE) OR (DLASTBYTE <= 0) OR (DACCESS.YEAR >= 100) THENIN SYSCOM^.IORSLT := ILOSTUNIT; UVID := ''; UEOVBLK := MMAXINT END END END (*WRITEDIR*) ;  BEGIN OK := FALSE; DELENTRY(LINX,GDIRP) END ELSE LINX := LINX+1; IF NOT OK THEN BEGIN (*MUST HAVEFUNCTION VOLSEARCH(*VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP*); VAR LUNIT: UNITNUM; OK,PHYSUNIT: BOOLEAN; HNOW,LNOW: I BEEN CHANGED...WRITEIT*) UNITWRITE(FUNIT,GDIRP^, (DNUMFILES+1)*SIZEOF(DIRENTRY),DIRBLK); OK := IORSLT = INOERROR NTEGER; BEGIN VOLSEARCH := 0; FDIR := NIL; OK := FALSE; PHYSUNIT := FALSE; IF LENGTH(FVID) > 0 THEN BEGIN IF (FVID END END END; IF OK THEN BEGIN UVID := DVID; UEOVBLK := DEOVBLK; TIME(HNOW,DLOADTIME) END END;[1] = '#') AND (LENGTH(FVID) > 1) THEN BEGIN OK := TRUE; LUNIT := 0; HNOW := 2; REPEAT IF FVID[HNOW] IN DIGITS THEN  FETCHDIR := OK; IF NOT OK THEN BEGIN UVID := ''; UEOVBLK := MMAXINT; RELEASE(GDIRP); GDIRP := NIL END END  LUNIT := LUNIT*10+ORD(FVID[HNOW])-ORD('0') ELSE OK := FALSE; HNOW := HNOW+1 UNTIL (HNOW > LENGTH(FVID)) OR NEND (*FETCHDIR*) ; PROCEDURE WRITEDIR(*FUNIT: UNITNUM; FDIR: DIRP*); VAR HNOW,LNOW: INTEGER; OK: BOOLEAN; LDE: DIRENTRY; OT OK; PHYSUNIT := OK AND (LUNIT > 0) AND (LUNIT <= MAXUNIT) END; IF NOT PHYSUNIT THEN BEGIN OK := FALSE; LUNIT := MABEGIN WITH UNITABLE[FUNIT],FDIR^[0] DO BEGIN OK := (UVID = DVID) AND ((DFKIND = UNTYPEDFILE) OR (DFKIND = SECUREDIRXUNIT; REPEAT OK := FVID = UNITABLE[LUNIT].UVID; IF NOT OK THEN LUNIT := LUNIT-1 UNTIL OK OR (LUNIT = 0) END L THEN NEW(GDIRP); UNITREAD(FUNIT,GDIRP^,SIZEOF(DIRECTORY),DIRBLK); OK := IORSLT = INOERROR; IF OK THEN WITH )); IF OK THEN BEGIN TIME(HNOW,LNOW); OK := (LNOW-DLOADTIME <= AGELIMIT) AND ((LNOW-DLOADTIME) >= 0) A  *) ; PROCEDURE DELENTRY(*FINX: DIRRANGE; FDIR: DIRP*); VAR I: DIRRANGE; BEGIN WITH FDIR^[0] DO BEGIN FOR I := FINDINX := I; I := LASTI END; I := I+1 END; IF DINX = 0 THEN IF FDIR^[0].DEOVBLK-FDIR^[LASTI].DLASTBLK >= FSEGS THEN X TO DNUMFILES-1 DO FDIR^[I] := FDIR^[I+1]; FDIR^[DNUMFILES].DTID := ''; DNUMFILES := DNUMFILES-1 END END (*DELDINX := LASTI+1 END; IF LASTI = MAXDIR THEN DINX := 0; IF DINX > 0 THEN BEGIN WITH LDE DO BEGIN  END; IF OK THEN IF UNITABLE[LUNIT].UISBLKD THEN WITH SYSCOM^ DO BEGIN OK := FALSE; (*SEE IF GDIRP IS GOOD*) IENTRY*) ; PROCEDURE INSENTRY(*VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP*); VAR I: DIRRANGE; BEGIN WITH FDIR^[0] DO F GDIRP <> NIL THEN IF FVID = GDIRP^[0].DVID THEN BEGIN TIME(HNOW,LNOW);  BEGIN FOR I := DNUMFILES DOWNTO FINX DO FDIR^[I+1] := FDIR^[I]; FDIR^[FINX] := FENTRY; DNUMFILES := DNUMFI OK := LNOW-GDIRP^[0].DLOADTIME <= AGELIMIT END; IF NOT OK THEN BEGIN OK := PHYSUNIT; IF FETCHDIR(LUNIT) LES+1 END END (*INSENTRY*) ; FUNCTION ENTERTEMP(VAR FTID: TID; FSEGS: INTEGER; FKIND: FILEKIND; FDIR: DIRP): DIRRANTHEN IF NOT PHYSUNIT THEN OK := FVID = GDIRP^[0].DVID END END; IF NOT OK AND LOOKHARD THEN BEGIN LUNIT := MAXUGE; VAR I,LASTI,DINX,SINX: DIRRANGE; RT11ISH: BOOLEAN; SSEGS: INTEGER; LDE: DIRENTRY; PROCEDURE FINDMAX(CURINX: DIRRANIT; (*CHECK EACH DISK UNIT*) REPEAT WITH UNITABLE[LUNIT] DO IF UISBLKD THEN IF FETCHDIR(LUNIT) THEN OK :=NGE; FIRSTOPEN,NEXTUSED: INTEGER); VAR FREEAREA: INTEGER; BEGIN FREEAREA := NEXTUSED-FIRSTOPEN;  FVID = UVID; IF NOT OK THEN LUNIT := LUNIT-1 UNTIL OK OR (LUNIT = 0) END; IF OK THEN WITH UNITABLE[LUNIT] DO  IF FREEAREA > FSEGS THEN BEGIN SINX := DINX; SSEGS := FSEGS; DINX := CURINX; FSEGS := FREEAREA END ELSE  BEGIN VOLSEARCH := LUNIT; IF LENGTH(UVID) > 0 THEN FVID := UVID; IF UISBLKD AND (SYSCOM^.GDIRP <> NIL) THEN BEGIN FDIR IF FREEAREA > SSEGS THEN BEGIN SSEGS := FREEAREA; SINX := CURINX END END (*FINDMAX*) ; BEGIN (*ENTERTEMP*) DINX := 0;  := SYSCOM^.GDIRP; TIME(HNOW,FDIR^[0].DLOADTIME) END END END (*VOLSEARCH*) ; FUNCTION DIRSEARCH(*VAR FTID: TID; FLASTI := FDIR^[0].DNUMFILES; SINX := 0; SSEGS := 0; IF FSEGS <= 0 THEN BEGIN RT11ISH := FSEGS < 0; FOR I := 1 TO LINDPERM: BOOLEAN; FDIR: DIRP*); VAR I: DIRRANGE; FOUND: BOOLEAN; BEGIN DIRSEARCH := 0; FOUND := FALSE; I := 1; WHILE (I <= FASTI DO FINDMAX(I,FDIR^[I-1].DLASTBLK,FDIR^[I].DFIRSTBLK); FINDMAX(LASTI+1,FDIR^[LASTI].DLASTBLK,FDIR^[0].DEOVBLK); DIR^[0].DNUMFILES) AND NOT FOUND DO BEGIN WITH FDIR^[I] DO IF DTID = FTID THEN  IF RT11ISH THEN IF FSEGS DIV 2 <= SSEGS THEN BEGIN FSEGS := SSEGS; DINX := SINX END ELSE FSEGS := (FSEGS+1) DIV 2 END  IF FINDPERM = (DACCESS.YEAR <> 100) THEN BEGIN DIRSEARCH := I; FOUND := TRUE END; I := I+1 END END (*DIRSEARCH ELSE BEGIN I := 1; WHILE I <= LASTI DO BEGIN IF FDIR^[I].DFIRSTBLK-FDIR^[I-1].DLASTBLK >= FSEGS THEN BEGIN ! PROCEDURE RESETER(VAR F:FIB); VAR BIGGER: BOOLEAN; BEGIN WITH F DO BEGIN FREPTCNT := 0; FEOLN := FALSE; FEOF := FALSE DO IF FISOPEN AND (SYSCOM^.GDIRP = NIL) THEN BEGIN MARK(OLDHEAP); NBYTES := ORD(SYSCOM^.LASTMP)-ORD(OLDHEAP); I; IF FISBLKD THEN BEGIN BIGGER := FNXTBLK > FMAXBLK; IF BIGGER THEN FMAXBLK := FNXTBLK; IF FSOFTBUF THEN BEF (NBYTES > 0) AND (NBYTES < SIZEOF(DIRECTORY)+400) THEN BEGIN NBYTES := ORD(OLDHEAP)-ORD(EMPTYHEAP); IF (NBYTESGIN IF BIGGER THEN FMAXBYTE := FNXTBYTE ELSE IF FNXTBLK = FMAXBLK THEN IF FNXTBYTE > FMAXBYTE THEN BEGIN BIGGER > 0) AND (NBYTES > SIZEOF(DIRECTORY)) AND (UNITABLE[FUNIT].UVID = FVID) THEN BEGIN  := TRUE; FMAXBYTE := FNXTBYTE END; IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; IF BIGGER THEN  UNITWRITE(FUNIT,EMPTYHEAP^,SIZEOF(DIRECTORY), FHEADER.DFIRSTBLK); RELEASE(EMPTYHEAP); SWAPPED := TRUE END  FILLCHAR(FBUFFER[FNXTBYTE],FBLKSIZE-FNXTBYTE,0); UNITWRITE(FUNIT,FBUFFER,FBLKSIZE, FHEADER.DFIRSTBLK+FNXTBLK END END; LUNIT := VOLSEARCH(LVID,TRUE,LDIR); IF LUNIT = 0 THEN SYSCOM^.IORSLT := INOUNIT ELSE WITH UNITABL DFIRSTBLK := FDIR^[DINX-1].DLASTBLK; DLASTBLK := DFIRSTBLK+FSEGS; DFKIND := FKIND; DTID := FTID; DLASTBYTE := FBLKSI-1); IF BIGGER AND (FHEADER.DFKIND = TEXTFILE) AND ODD(FNXTBLK) THEN BEGIN FMAXBLK := FMAXBLK+1; FILLCHAR(FZE; WITH DACCESS DO BEGIN MONTH := 0; DAY := 0; YEAR := 100 END END; INSENTRY(LDE,DINX,FDIR) END; ENTERTEMPBUFFER,FBLKSIZE,0); UNITWRITE(FUNIT,FBUFFER,FBLKSIZE, FHEADER.DFIRSTBLK+FNXTBLK) END END; FNXTBYTE := FBLK := DINX END (*ENTERTEMP*) ; (* FILE STATE HANDLERS *) PROCEDURE FINIT(*VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER*); BEGISIZE END; FNXTBLK := 0; IF FSOFTBUF AND (FHEADER.DFKIND = TEXTFILE) THEN FNXTBLK := 2 END END N WITH F DO BEGIN FSTATE := FJANDW; FISOPEN := FALSE; FEOF := TRUE; FEOLN := TRUE; FWINDOW := WINDOW; IFEND (*RESETER*) ; PROCEDURE FOPEN(*VAR F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK PARAM*); LABEL 1; VAR LDIR: D (RECWORDS = 0) OR (RECWORDS = -2) THEN BEGIN FWINDOW^[1] := CHR(0); FRECSIZE := 1; IF RECWORDS = 0 THEN FSTATE := FNEEDCIRP; LUNIT: UNITNUM; LINX: DIRRANGE; LSEGS,NBYTES: INTEGER; LKIND: FILEKIND; OLDHEAP: ^INTEGER; SWAPPED: BOOLEAN; HAR END ELSE IF RECWORDS < 0 THEN BEGIN FWINDOW := NIL; FRECSIZE := 0 END ELSE FRECSIZE := RECWORDS+RECWORDS END SAVERSLT: IORSLTWD; LVID: VID; LTID: TID; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN SYSCOM^.IORSLT : END (*FINIT*) ; = INOTCLOSED ELSE IF SCANTITLE(FTITLE,LVID,LTID,LSEGS,LKIND) THEN BEGIN (*GOT AN OK TITLE*) IF ORD(FOPENOLD) > 1 THEN (*OLD CODE SPECIAL CASE*) FOPENOLD := (ORD(FOPENOLD) = 2) OR (ORD(FOPENOLD) = 4); SWAPPED := FALSE; WITH SWAPFIB^" FILE THEN LKIND := DATAFILE; LINX := ENTERTEMP(LTID,LSEGS,LKIND,LDIR); IF (LINX > 0) AND (LKIND = TEXTFILE) THEN EGIN RELEASE(OLDHEAP); SYSCOM^.GDIRP := NIL; SAVERSLT := SYSCOM^.IORSLT; UNITREAD(SWAPFIB^.FUNIT,EMPTYHEAP^,SIZEOF WITH LDIR^[LINX] DO BEGIN IF ODD(DLASTBLK-DFIRSTBLK) THEN DLASTBLK := DLASTBLK-1; IF DLASTBLK-DFIR(DIRECTORY), SWAPFIB^.FHEADER.DFIRSTBLK); SYSCOM^.IORSLT := SAVERSLT END END ELSE SYSCOM^.IORSLT := IBADTSTBLK < 4 THEN BEGIN DELENTRY(LINX,LDIR); LINX := 0 END END; IF LINX = 0 THEN BEGIN SYSCOM^.IORSLT :=ITLE END (*FOPEN*) ; PROCEDURE FCLOSE(*VAR F: FIB; FTYPE: CLOSETYPE*); LABEL 1; VAR LINX,DUPINX: DIRRANGE; LDIR: DIRP; FOUN INOROOM; GOTO 1 END; FHEADER := LDIR^[LINX]; FMODIFIED := TRUE; WRITEDIR(LUNIT,LDIR) END END ELSE (*FHEADER D: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN AND (FWINDOW <> SYSTERM^.FWINDOW) THEN BEGIN NOT IN DIRECTORY*) WITH FHEADER DO BEGIN (*DIRECT UNIT OPEN, SET UP DUMMY FHEADER*) DFIRSTBLK := 0; DLASTBLK : IF FISBLKD THEN WITH FHEADER DO IF LENGTH(DTID) > 0 THEN BEGIN (*FILE IN A DISK DIRECTORY...FIXUP MAYBE*) IF F= MMAXINT; IF UISBLKD THEN DLASTBLK := UEOVBLK; DFKIND := LKIND; DTID := ''; DLASTBYTE := FBLKSIZE; TYPE = CCRUNCH THEN BEGIN FMAXBLK := FNXTBLK; DACCESS.YEAR := 100; FTYPE := CLOCK; IF FSOFTBUF THEN FMAXBYTE :=  WITH DACCESS DO BEGIN MONTH := 0; DAY := 0; YEAR := 0 END END; IF FOPENOLD THEN FMAXBLK := FHEADER.DLASTBLK-FFNXTBYTE END; RESETER(F); IF FMODIFIED OR (DACCESS.YEAR = 100) OR (FTYPE = CPURGE) THEN BEGIN (*HAVE TO CHANGE DIRECHEADER.DFIRSTBLK ELSE FMAXBLK := 0; IF FSOFTBUF THEN BEGIN FNXTBYTE := FBLKSIZE; FBUFCHNGD := FALSE; IF FOPETORY ENTRY*) IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END; LINXE[LUNIT] DO BEGIN (*OK...OPEN UP FILE*) FISOPEN := TRUE; FMODIFIED := FALSE; FUNIT := LUNIT; FVID := LVID; FNXTBLK NOLD THEN FMAXBYTE := FHEADER.DLASTBYTE ELSE FMAXBYTE := FBLKSIZE; WITH FHEADER DO := 0; FISBLKD := UISBLKD; FSOFTBUF := UISBLKD AND (FRECSIZE <> 0); IF (LDIR <> NIL) AND (LENGTH(LTID) > 0) THEN BEGIN (* IF DFKIND = TEXTFILE THEN BEGIN FNXTBLK := 2; IF NOT FOPENOLD THEN BEGIN (*NEW .TEXT, PUT NULLS IN FIRST LOOKUP OR ENTER FHEADER IN DIRECTORY*) LINX := DIRSEARCH(LTID,FOPENOLD,LDIR); IF FOPENOLD THEN IF LINX = 0 TPAGE*) FILLCHAR(FBUFFER,SIZEOF(FBUFFER),0); UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK); UNITWRITE(FUHEN BEGIN SYSCOM^.IORSLT := INOFILE; GOTO 1 END ELSE FHEADER := LDIR^[LINX] ELSE (*OPEN NEW FILE*) IF LNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+1) END END END; IF FOPENOLD THEN FRESET(F) ELSE RESETER(F); (*NO GET!*) 1: IF INX > 0 THEN BEGIN SYSCOM^.IORSLT := IDUPFILE; GOTO 1 END ELSE BEGIN (*MAKE A TEMP ENTRY*) IF LKIND = UNTYPEDIORESULT <> ORD(INOERROR) THEN BEGIN FISOPEN := FALSE; FEOF := TRUE; FEOLN := TRUE END END; IF SWAPPED THEN B#  IF NOT FOUND THEN BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END; LINX := LINX - 1; (*CORRECT OVERRUN*) IF ((FTYPE = CNORMAL) AND (LDIR^[LINX].DACCESS.YEAR = 100)) OR (FTYPE = CPURGE) THEN  DELENTRY(LINX,LDIR) (*ZAP FILE OUT OF EXISTANCE*) ELSE BEGIN (*WELL...LOCK IN A PERM DIR ENTRY*) DUPINX := DIRSEARCH(DTID,TRUE,LDIR); IF (DUPINX <> 0) AND (DUPINX <> LINX) THEN BEGIN (*A DUPLICATE PERM ENTRY...ZAP OLD ONE*)  DELENTRY(DUPINX,LDIR); IF DUPINX < LINX THEN LINX := LINX-1 END; IF LDIR^[LINX].DACCESS.YEAR = 100 THEN IF DACCESS.YEAR = 100 THEN DACCESS := THEDATE ELSE (*LEAVE ALONE...FILER SPECIAL CASE*) ELSE IF FMODIFIED AN {$I GLOBALS } {$I SYSSEGS }  {$I SYSTEM.B } {$I SYSTEM.C } D (THEDATE.MONTH <> 0) THEN DACCESS := THEDATE ELSE DACCESS := LDIR^[LINX].DACCESS; DLASTBLK := DFIRSTBLK+FMAXBLK; IF FSOFTBUF THEN DLASTBYTE := FMAXBYTE; FMODIFIED := FALSE; LDIR^[LINX] := FHEADER END; WRITEDIR(FUNIT,LDIR) END END; IF FTYPE = CPURGE THEN IF LENGTH(FHEADER.DTID) = 0 THEN UNITABLE[FUNIT].UVID := ''; 1: FEOF := TRUE; FEOLN := TRUE; FISOPEN := FALSE END END (*FCLOSE*) ; O^ := 1; FOUND := FALSE; WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO BEGIN (*LOOK FOR FIRST BLOCK MATCH*)  FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND (LDIR^[LINX].DLASTBLK = DLASTBLK); LINX := LINX + 1 END; $ te this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from t END; FEOF := FALSE; FEOLN := FALSE; ,IF FSTATE <> FJANDW THEN FSTATE := FNEEDCHAR; (*RJH 2Mar78*) he Institute for Information Systems. *) $(* *) $(******************************************************************) $ (* INPUT-OUTPUT PRIMITIVES *) PROCEDURE XSEEK; BEGIN SYSCOO^M^.XEQERR := 11; { NOT IMP ERR } EXECERROR END (*XSEEK*) ; PROCEDURE XREADREAL; BEGIN SYSCOM^.XEQERR := 11; { NOT IMP ERR }JJ EXECERROR END (*XREADREAL*) ; PROCEDURE XWRITEREAL; BEGIN SYSCOM^.XEQERR := 11; { NOT IMP ERR } EXECERROR END (*XWRITEREAL*) ; FUNCTION CANTSTRETCH(VAR F: FIB): BOOLEAN; (*REPLACED BY RJH 2Mar78*) LABEL 1;  VAR LINX: DIRRANGE; FOUND: BOOLEAN; LAVAILBLK: INTEGER; LDIR: DIRP; BEGIN CANTSTRETCH := TRUE; "WITH F,FHEADER DO IF LENGTH(DTID) > 0 THEN BEGIN (*IN A DIRECTORY FOR SURE*) IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END; FOUND := FALSE; LINX := 1; WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO BEGIN FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND (LDIR^[LINX].DLASTBLK = DLASTBLK); LINX := LINX+1 END; IF NOT FOUND THEN BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END; (IF LINX > LDIR^[0].DNUMFILES THEN LAVAILBLK := LDIR^[0].DEOVBLK ELSE L  (******************************************************************) $(* AVAILBLK := LDIR^[LINX].DFIRSTBLK; IF (DLASTBLK < LAVAILBLK) OR (DLASTBYTE < FBLKSIZE) THEN BEGIN WITH LDIR^[LINX-1] DO *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribu BEGIN DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE; 0WRITEDIR(FUNIT,LDIR); IF IORESULT <> ORD(INOERROR) THEN GOTO 1% K) END; FBLOCKIO := NBLOCKS; RBLOCK := RBLOCK+NBLOCKS; FEOF := RBLOCK = DLASTBLK; FNXTBLK := RBLOCK-DFIRSTBLK; IF WRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1) END; IF IORESULT <> ORD(INOERROR) THEN GOTO 1; UNITREAD(FUFNXTBLK > FMAXBLK THEN FMAXBLK := FNXTBLK END END ELSE BEGIN FBLOCKIO := NBLOCKS; IF DOREAD THEN UNITRENIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK); IF IORESULT <> ORD(INOERROR) THEN GOTO 1; AD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK) ELSE UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK); IF IORESULT = ORD(INOERROR) THEN FNXTBLK := FNXTBLK+1; FNXTBYTE := 0 END UNTIL DONE END ELSE BEGIN UNITREAD(FUNIT,FWINDOW^,FRECSIZ IF DOREAD THEN BEGIN RBLOCK := NBLOCKS*FBLKSIZE; RBLOCK := RBLOCK+SCAN(-RBLOCK,<>CHR(0),A[RBLOCK-1]); RBLOCK :=E); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END; IF FRECSIZE = 1 THEN (*FILE OF CHAR*) BEGIN FEOLN := FALSE; I,DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE; DACCESS.YEAR := 100; CANTSTRETCH := FALSE END END; "IF FALSE THEN (RBLOCK+FBLKSIZE-1) DIV FBLKSIZE; FBLOCKIO := RBLOCK; FEOF := RBLOCK < NBLOCKS END ELSE ELSE FBLOCKIO := 0  1: BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END END (*CANTSTRETCH*) ; PROCEDURE FRESET(*VAR F: FIB*); BEGIN SYSCOM^.IORSLT := INEND ELSE SYSCOM^.IORSLT := INOTOPEN END (*FBLOCKIO*) ; PROCEDURE FGET(*VAR F: FIB*); LABEL 1, 2; VAR LEFTOGET,WINOERROR; WITH F DO IF FISOPEN THEN BEGIN RESETER(F); IF FRECSIZE > 0 THEN IF FSTATE = FJANDW THEN FGET(F) ELSEINX,LEFTINBUF,AMOUNT: INTEGER; DONE: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN  FSTATE := FNEEDCHAR END END (*FRESET*) ; FUNCTION FBLOCKIO(*VAR F: FIB; VAR A: WINDOW; NBLOCKS,RBLOCK: INTEGER; DOR BEGIN IF FREPTCNT > 0 THEN BEGIN FREPTCNT := FREPTCNT-1; IF FREPTCNT > 0 THEN GOTO 2 END; IF FSOFTBUF THEN WITH FHEAD: BOOLEAN*); BEGIN FBLOCKIO := 0; SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN AND (NBLOCKS >= 0) THEN IF FISEADER DO BEGIN LEFTOGET := FRECSIZE; WININX := 0; REPEAT IF FNXTBLK = FMAXBLK THEN IF FNXTBYTE+LEFTOGETBLKD THEN WITH FHEADER DO BEGIN IF RBLOCK < 0 THEN RBLOCK := FNXTBLK; RBLOCK := DFIRSTBLK+RBLOCK; IF RBLOCK+N > FMAXBYTE THEN GOTO 1 ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE; AMOUNT := LEFTOGET; BLOCKS > DLASTBLK THEN IF NOT DOREAD THEN IF CANTSTRETCH( F ) THEN; IF RBLOCK+NBLOCKS > DLASTBLK THEN NBLOCIF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF; IF AMOUNT > 0 THEN BEGIN MOVELEFT(FBUFFER[FNXTBYTE],FWINDOW^[WININX]KS := DLASTBLK-RBLOCK; FEOF := RBLOCK >= DLASTBLK; IF NOT FEOF THEN BEGIN IF DOREAD THEN ,AMOUNT); FNXTBYTE := FNXTBYTE+AMOUNT; WININX := WININX+AMOUNT; LEFTOGET := LEFTOGET-AMOUNT END; DONE := UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK) ELSE BEGIN FMODIFIED := TRUE; UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOC LEFTOGET = 0; IF NOT DONE THEN BEGIN IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNIT& 1: FEOF := TRUE; FEOLN := TRUE END; 2: END (*FGET*) ; PROCEDURE FPUT(*VAR F: FIB*); LABEL 1; VAR LEFTOPUT,WININX,LEFT] := CHR(0); FPUT(F) END END ELSE BEGIN UNITWRITE(FUNIT,FWINDOW^,FRECSIZE); IF IORESULT <> ORD(INOINBUF,AMOUNT: INTEGER; DONE: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN BEGIN IF FSERROR) THEN GOTO 1 END END ELSE BEGIN SYSCOM^.IORSLT := INOTOPEN; 1: FEOF := TRUE; FEOLN := TRUE END EOFTBUF THEN WITH FHEADER DO BEGIN LEFTOPUT := FRECSIZE; WININX := 0; REPEAT IF DFIRSTBLK+FNXTBLK = DLASTND (*FPUT*) ; FUNCTION FEOF(*VAR F: FIB*); BEGIN FEOF := F.FEOF END; (* TEXT FILE INTRINSICS *) BLK THEN IF FNXTBYTE+LEFTOPUT > DLASTBYTE THEN IF CANTSTRETCH( F ) THEN BEGIN SYSCOM^.IORSLT := INOROOM; GOTO 1 ENFUNCTION FEOLN(*VAR F: FIB*); BEGIN FEOLN := F.FEOLN END; PROCEDURE FWRITELN(*VAR F: FIB*); BEGIN F.FWINDOW^[0] := CHR(EOL); D ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE; AMFPUT(F) END (*FWRITELN*) ; PROCEDURE FWRITECHAR(*VAR F: FIB; CH: CHAR; RLENG: INTEGER*); LABEL 1; BEGIN WITH F DO IF FOUNT := LEFTOPUT; IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF; IF AMOUNT > 0 THEN BEGIN FBUFCHNGD := TRUE; MOVEISOPEN THEN IF FSOFTBUF THEN BEGIN WHILE RLENG > 1 DO BEGIN FWINDOW^[0] := ' '; FPUT(F); RLENG := RLENG-1 LEFT(FWINDOW^[WININX],FBUFFER[FNXTBYTE],AMOUNT); FNXTBYTE := FNXTBYTE+AMOUNT; WININX := WININX+AMOUNT; LEFTOPU END; FWINDOW^[0] := CH; FPUT(F) END ELSE BEGIN WHILE RLENG > 1 DO BEGIN FWINDOW^[0] := ' '; UNITWF FSTATE <> FJANDW THEN FSTATE := FGOTCHAR; IF FWINDOW^[0] = CHR(EOL) THEN BEGIN FWINDOW^[0] := ' '; FEOLN := TRUE; T := LEFTOPUT-AMOUNT END; DONE := LEFTOPUT = 0; IF NOT DONE THEN BEGIN IF FBUFCHNGD THEN GOTO 2 END; IF FWINDOW^[0] = CHR(DLE) THEN BEGIN FGET(F); AMOUNT := ORD(FWINDOW^[0])-32; IF (AMOUNT > 0) AND (AM BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1) END; OUNT <= 127) THEN BEGIN FWINDOW^[0] := ' '; FREPTCNT := AMOUNT; GOTO 2 END; FGET(F) END;  IF IORESULT <> ORD(INOERROR) THEN GOTO 1; IF FNXTBLK < FMAXBLK THEN UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNX IF FWINDOW^[0] = CHR(0) THEN BEGIN (*EOF HANDLING*) IF FSOFTBUF AND (FHEADER.DFKIND = TEXTFILE) THEN BEGIN (*END OTBLK) ELSE FILLCHAR(FBUFFER,FBLKSIZE,CHR(0)); IF IORESULT <> ORD(INOERROR) THEN GOTO 1; FNXTBLK := FNXF 2 BLOCK PAGE*) IF ODD(FNXTBLK) THEN FNXTBLK := FNXTBLK+1; FNXTBYTE := FBLKSIZE; FGET(F) END ELSE BEGIN FTBLK+1; FNXTBYTE := 0 END UNTIL DONE; IF FRECSIZE = 1 THEN IF FWINDOW^[0] = CHR(EOL) THEN IF DFKIND = TEWINDOW^[0] := ' '; GOTO 1 END END END END ELSE BEGIN SYSCOM^.IORSLT := INOTOPEN; XTFILE THEN IF (FNXTBYTE >= FBLKSIZE-127) AND NOT ODD(FNXTBLK) THEN BEGIN FNXTBYTE := FBLKSIZE-1; FWINDOW^[0' 0 THEN BEGIN I := ABS(I); S[1] := '-'; COL := 2; IF I = 0 THEN (*HARDWARE SPECIAL CASE*) HILE NOT FEOLN DO FGET(F) END END (*FREADSTRING*) ; PROCEDURE FWRITEBYTES(*VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGE BEGIN S := '-32768'; GOTO 1 END END; FOR POT := 4 DOWNTO 0 DO BEGIN CH := CHR(I DIV IPOT[POT] + ORD('0')); IF (R*); VAR AINX: INTEGER; BEGIN WITH F DO IF FISOPEN THEN BEGIN IF RLENG > ALENG THEN BEGIN FWRITECHAR(F,' ',RLECH = '0') AND (POT > 0) AND SUPPRESSING THEN ELSE (*FORMAT THE CHAR*) BEGIN SUPPRESSING := FALSE; S[COL] := CH; COL :=NG-ALENG); RLENG := ALENG END; IF FSOFTBUF THEN BEGIN AINX := 0; WHILE (AINX < RLENG) AND NOT FEOF DO BEGIN FWIN COL+1; IF CH <> '0' THEN I := I MOD IPOT[POT] END END; S[0] := CHR(COL-1); 1:IF RLENG < LENGTH(S) THEN RLENG := LDOW^[0] := A[AINX]; FPUT(F); AINX := AINX+1 END END ELSE UNITWRITE(FUNIT,A,RLENG) END ENGTH(S); FWRITESTRING(F,S,RLENG) END (*FWRITEINT*) ; PROCEDURE FWRITESTRING(*VAR F: FIB; VAR S: STRING; RLENG: INTEGER*);  ELSE SYSCOM^.IORSLT := INOTOPEN END (*FWRITEBYTES*) ; PROCEDURE FREADLN(*VAR F: FIB*); BEGIN WHILE NOT F.FEOLN DO FGET(F)VAR SINX: INTEGER; BEGIN WITH F DO IF FISOPEN THEN BEGIN IF RLENG <= 0 THEN RLENG := LENGTH(S); IF RLENG > LENGTH(; IF F.FSTATE = FJANDW THEN FGET(F) ELSE BEGIN F.FSTATE := FNEEDCHAR; F.FEOLN := FALSE END END (*FREADLN*) ; PROCEDURE S) THEN BEGIN FWRITECHAR(F,' ',RLENG-LENGTH(S)); RLENG := LENGTH(S) END; IF FSOFTBUF THEN BEGIN SINX := 1; WHILE (SIFREADCHAR(*VAR F: FIB; VAR CH: CHAR*); BEGIN WITH F DO BEGIN SYSCOM^.IORSLT := INOERROR; IF FSTATE = FNEEDCHAR THEN FGENX <= RLENG) AND NOT FEOF DO BEGIN FWINDOW^[0] := S[SINX]; FPUT(F); SINX := SINX+1 END END ELSE UNITWRITE(FUNIT,S[T(F); CH := FWINDOW^[0]; IF FSTATE = FJANDW THEN FGET(F) ELSE FSTATE := FNEEDCHAR END END (*FREADCHAR*) ; PROCEDURE FR1],RLENG) END ELSE SYSCOM^.IORSLT := INOTOPEN END (*FWRITESTRING*) ; EADINT(*VAR F: FIB; VAR I: INTEGER*); LABEL 1; VAR CH: CHAR; NEG,IVALID: BOOLEAN; SINX: INTEGER; BEGIN WITH F DO BEGPROCEDURE FREADSTRING(*VAR F: FIB; VAR S: STRING; SLENG: INTEGER*); VAR SINX: INTEGER; CH: CHAR; BEGIN WITH F DO BEGININ I := 0; NEG := FALSE; IVALID := FALSE; IF FSTATE = FNEEDCHAR THEN FGET(F); WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(FRITE(FUNIT,FWINDOW^,1); RLENG := RLENG-1 END; FWINDOW^[0] := CH; UNITWRITE(FUNIT,FWINDOW^,1) END ELSE SYS SINX := 1; IF FSTATE = FNEEDCHAR THEN FGET(F); S[0] := CHR(SLENG); (*NO INV INDEX*) WHILE (SINX <= SLENG) AND NOT (FEOLN OR COM^.IORSLT := INOTOPEN; 1: END (*FWRITECHAR*) ; PROCEDURE FWRITEINT(*VAR F: FIB; I,RLENG: INTEGER*); LABEL 1; VAR POT,COL:FEOF) DO BEGIN CH := FWINDOW^[0]; IF FUNIT = 1 THEN IF CHECKDEL(CH,SINX) THEN ELSE BEGIN S[SINX] := CH;  INTEGER; CH: CHAR; SUPPRESSING: BOOLEAN; S: STRING[10]; BEGIN COL := 1; S[0] := CHR(10); SUPPRESSING := TRUE; IF I < SINX := SINX + 1 END ELSE BEGIN S[SINX] := CH; SINX := SINX + 1 END; FGET(F) END; S[0] := CHR(SINX - 1); W( ); IF FEOF THEN GOTO 1; CH := FWINDOW^[0]; IF (CH = '+') OR (CH = '-') THEN BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^ DEST[0] := CHR(COPYLENG) END END (*SCOPY*) ; PROCEDURE SDELETE(*VAR DEST: STRING; DELINX,DELLENG: INTEGER*); VAR ONR[0] END; IF CH IN DIGITS THEN *BEGIN IVALID := TRUE; SINX := 1; ,REPEAT .I := I*10+ORD(CH)-ORD('0'); IGHT: INTEGER; BEGIN IF (DELINX > 0) AND (DELLENG > 0) THEN BEGIN ONRIGHT := LENGTH(DEST)-DELINX-DELLENG+1; IF.FGET(F); CH := FWINDOW^[0]; SINX := SINX+1; .IF FUNIT = 1 THEN 0WHILE CHECKDEL(CH,SINX) DO 2BEGIN 4IF SINX = 1 THEN I := 0 ONRIGHT = 0 THEN DEST[0] := CHR(DELINX-1) ELSE IF ONRIGHT > 0 THEN BEGIN MOVELEFT(DEST[DELINX+DELLENG],DEST[DELI ELSE I := I DIV 10; 4FGET(F); CH := FWINDOW^[0] 2END ,UNTIL NOT (CH IN DIGITS) OR FEOLN *END; IF IVALID OR FEOF THEN IFNX],ONRIGHT); DEST[0] := CHR(LENGTH(DEST)-DELLENG) END END END (*SDELETE*) ;  FUNCTION SPOS(*VAR TARGET, SRC: STRI NEG THEN I := -I ELSE (*NADA*) ELSE SYSCOM^.IORSLT := IBADFORMAT END; 1: END (*FREADINT*) ; (* STRING VARIABLE INTRINSING*);  LABEL 1;  VAR TEMPLOC,DIST: INTEGER;  FIRSTCH: CHAR; %TEMP: STRING;  BEGIN SPOS := 0; CS *) PROCEDURE SCONCAT(*VAR SRC,DEST: STRING; DESTLENG: INTEGER*); BEGIN IF LENGTH(SRC)+LENGTH(DEST) <= DESTLENG THEN BE"IF LENGTH(TARGET) > 0 THEN $BEGIN &FIRSTCH := TARGET[1]; &TEMPLOC := 1; &DIST := LENGTH(SRC)-LENGTH(TARGET) + 1; &TEMP[0]GIN MOVELEFT(SRC[1],DEST[LENGTH(DEST)+1],LENGTH(SRC)); DEST[0] := CHR(LENGTH(SRC)+LENGTH(DEST)) END END (*SCONCA := TARGET[0]; &WHILE TEMPLOC <= DIST DO (BEGIN *TEMPLOC := TEMPLOC + SCAN(DIST-TEMPLOC,=FIRSTCH,SRC[TEMPLOC]) ; *IF TEMPLOT*) ; PROCEDURE SINSERT(*VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER*); VAR ONRIGHT: INTEGER; BEGIN IF (INSINX > 0) AND C>DIST THEN -GOTO 1; *MOVELEFT(SRC[TEMPLOC],TEMP[1],LENGTH(TARGET)); *IF TEMP=TARGET THEN ,BEGIN SPOS := TEMPLOC; GOTO 1 END(LENGTH(SRC) > 0) AND (LENGTH(SRC)+LENGTH(DEST) <= DESTLENG) THEN BEGIN ONRIGHT := LENGTH(DEST)-INSINX+1; ; *TEMPLOC := TEMPLOC+1 (END $END;  1:  END (*SPOS*) ;  (* MAIN DRIVER OF SYSTEM *) PROCEDURE COMMAND; VAR T: INTEGER;IF ONRIGHT > 0 THEN BEGIN MOVERIGHT(DEST[INSINX],DEST[INSINX+LENGTH(SRC)],ONRIGHT); ONRIGHT := 0 END;  BEGIN STATE := HALTINIT; REPEAT RELEASE(EMPTYHEAP); WHILE UNITABLE[SYSCOM^.SYSUNIT].UVID <> SYVID DO BEGIN PL  IF ONRIGHT = 0 THEN BEGIN MOVELEFT(SRC[1],DEST[INSINX],LENGTH(SRC)); DEST[0] := CHR(LENGTH(DEST)+LENGTH(SRC)) END := 'Put in :'; INSERT(SYVID,PL,8); PROMPT; T := 4000; REPEAT T := T-1 UNTIL T = 0; IF FETCHDIR(SYSCOM^.SYSUNIT) THEN  END END (*SINSERT*) ; PROCEDURE SCOPY(*VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER*); BEGIN DEST := ''; IF (SRCINX > 0END; STATE := GETCMD(STATE); CASE STATE OF UPROGNOU,UPROGUOK,SYSPROG, COMPONLY,COMPANDGO,COMPDEBUG, LI) AND (COPYLENG > 0) AND (SRCINX+COPYLENG-1 <= LENGTH(SRC)) THEN BEGIN MOVELEFT(SRC[SRCINX],DEST[1],COPYLENG); NKANDGO,LINKDEBUG: USERPROGRAM(NIL,NIL); &DEBUGCALL: DEBUGGER END; IF STATE IN [UPROGNOU,UPROGUOK] THEN ) 8 *) (* I.5 SEPTEMBER, 1978 *)  (* *) (* WRITTEN BY ROGER T. SUMNER *) (* WINTER 1977 *) (*  *) (* INSTITUTE FOR INFORMATION SYSTEMS *) (* UC SAN DIEGO, LA JOLLA, CA *) ( BEGIN FCLOSE(GFILES[0]^,CNORMAL); FCLOSE(GFILES[1]^,CLOCK) END; IF UNITBUSY(1) OR UNITBUSY(2) THEN UNITCLEAR(1) UNTIL STATE = HALTINIT END (*COMMAND*) ; BEGIN (*UCSD PASCAL SYSTEM*) EMPTYHEAP := NIL; INITIALIZE; REPEAT COMMAND; IF EMPTYHEAP <> NIL THEN INITIALIZE UNTIL EMPTYHEAP = NIL END (*PASCALSYSTEM*) . (*$U-,S+*)   (******************************************************************) $(*  *) $(* Copyright (c) 1978 Regents of the University of California. *) $(* Permission to copy or distribute this software or documen- *) $(* tation in hard or soft copy granted only by written license *) $(* obtained from the Institute for Information Systems. *) $(*  *) $(******************************************************************) $ PROGRAM PASCALSYSTEM; (**************************O^**********************) (* *) (* UCSD PASCAL OPERATING SYSTEM *) (* *) (* RELEASE LEVEL: I.3 AUGUST, 1977 *) (* I.4 JANUARY, 197* PFILE,INOTCLOSED,INOTOPEN,IBADFORMAT, ISTRGOVFL); (*COMMAND STATES...SEE GETCMD*) CMDSTATE = (HALTINIT,DEBUGCALL,FIB = RECORD FWINDOW: WINDOWP; (*USER WINDOW...F^, USED BY GET-PUT*) FEOF,FEOLN: BOOLEAN; FSTATE: (FJANDW,FNEE UPROGNOU,UPROGUOK,SYSPROG, COMPONLY,COMPANDGO,COMPDEBUG, 1LINKANDGO,LINKDEBUG); (*ARCHIVAL INFO...THE DATE*) DCHAR,FGOTCHAR); FRECSIZE: INTEGER; (*IN BYTES...0=>BLOCKFILE, 1=>CHARFILE*) CASE FISOPEN: BOOLEAN OF  DATEREC = PACKED RECORD MONTH: 0..12; (*0 IMPLIES DATE NOT MEANINGFUL*) DAY: 0..31; (*DAY OF MONTH*) YEAR: 0..100 ( TRUE: (FISBLKD: BOOLEAN; (*FILE IS ON BLOCK DEVICE*) FUNIT: UNITNUM; (*PHYSICAL UNIT #*) FVID: VID; (*VO*100 IS TEMP DISK FLAG*) END (*DATEREC*) ; (*VOLUME TABLES*) UNITNUM = 0..MAXUNIT; VID = STRING[VIDLENG]LUME NAME*) FREPTCNT, (* # TIMES F^ VALID W/O GET*) FNXTBLK, (*NEXT REL BLOCK TO IO*) FMAXBLK: INTEGER; (*DISK DIRECTORIES*) DIRRANGE = 0..MAXDIR; TID = STRING[TIDLENG]; FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEF; (*MAX REL BLOCK ACCESSED*) FMODIFIED:BOOLEAN;(*PLEASE SET NEW DATE IN CLOSE*) FHEADER: DIRENTRY;(*COPY OF DISKILE,TEXTFILE, INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; (*FIRST PHYSICA DIR ENTRY*) CASE FSOFTBUF: BOOLEAN OF (*DISK GET-PUT STUFF*) TRUE: (FNXTBYTE,FMAXBYTE: INTEGER; FBUFCHNGD:* *) (* KENNETH L. BOWLES, DIRECTOR *) (* L DISK ADDR*) DLASTBLK: INTEGER; (*POINTS AT BLOCK FOLLOWING*) CASE DFKIND: FILEKIND OF SECUREDIR,  *) (************************************************) CONST MMAXINT = 32767; (*MAXIMUM INTEGER VALUE* UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*) (DVID: VID; (*NAME OF DISK VOLUME*) DEOVBLK: INTEGER; (*LASTBLK) MAXUNIT = 12; (*MAXIMUM PHYSICAL UNIT # FOR UREAD*) MAXDIR = 77; (*MAX NUMBER OF ENTRIES IN A DIRECTORY*) VIDLE OF VOLUME*) DNUMFILES: DIRRANGE; (*NUM FILES IN DIR*) DLOADTIME: INTEGER; (*TIME OF LAST ACCESS*) DLASTBOOT: DATEREC);NG = 7; (*NUMBER OF CHARS IN A VOLUME ID*) TIDLENG = 15; (*NUMBER OF CHARS IN TITLE ID*) MAXSEG = 15; (*MAX CODE SEGME (*MOST RECENT DATE SETTING*) XDSKFILE,CODEFILE,TEXTFILE,INFOFILE, DATAFILE,GRAFFILE,FOTOFILE: (DTID: TID; NT NUMBER*) FBLKSIZE = 512; (*STANDARD DISK BLOCK LENGTH*) DIRBLK = 2; (*DISK ADDR OF DIRECTORY*) AGELIMIT = 300; (*TITLE OF FILE*) DLASTBYTE: 1..FBLKSIZE; (*NUM BYTES IN LAST BLOCK*) DACCESS: DATEREC) (*LAST MODIFICATION DATE*) END  (*MAX AGE FOR GDIRP...IN TICKS*) EOL = 13; (*END-OF-LINE...ASCII CR*) DLE = 16; (*BLANK COMPRESSION CODE*) TYPE (*DIRENTRY*) ; DIRP = ^DIRECTORY; DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY; (*FILE INFORMATION*) CLOSETY IORSLTWD = (INOERROR,IBADBLOCK,IBADUNIT,IBADMODE,ITIMEOUT, ILOSTUNIT,ILOSTFILE,IBADTITLE,INOROOM,INOUNIT, INOFILE,IDUPE = (CNORMAL,CLOCK,CPURGE,CCRUNCH); WINDOWP = ^WINDOW; WINDOW = PACKED ARRAY [0..0] OF CHAR; FIBP = ^FIB; +  WORKTID,SYMTID,CODETID: TID (*PERM&CUR WORKFILES TITLE*) END (*INFOREC*) ; (*CODE SEGMENT LAYOUTS*) SEGRARL: PACKED RECORD RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR; BACKSPACE: CHAR; FILLCOUNT: 0..255; NGE = 0..MAXSEG; SEGDESC = RECORD DISKADDR: INTEGER; (*REL BLK IN CODE...ABS IN SYSCOM^*) CODELENG: INTEGER (*# BYTES EXPANSION: PACKED ARRAY [0..3] OF CHAR END; CRTINFO: PACKED RECORD WIDTH,HEIGHT: INTEGER;  TO READ IN*) END (*SEGDESC*) ; (*DEBUGGER STUFF*) BYTERANGE = 0..255; TRICKARRAY = ARRAY [0..0] OF INTRIGHT,LEFT,DOWN,UP: CHAR; BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR; ALTMODE,LINEDEL: CHAR; EGER; (* FOR MEMORY DIDDLING*) MSCWP = ^ MSCW; (*MARK STACK RECORD POINTER*) MSCW = RECORD STATLINK: MSCWP; (* EXPANSION: PACKED ARRAY [0..5] OF CHAR END; SEGTABLE: ARRAY [SEGRANGE] OF RECORD CODEUNIT: UPOINTER TO PARENT MSCW*) DYNLINK: MSCWP; (*POINTER TO CALLER'S MSCW*) MSSEG,MSJTAB: ^TRICKARRAY; MSIPC: INTNITNUM; CODEDESC: SEGDESC END END (*SYSCOM*); MISCINFOREC = RECORD MSYSCOM: SYSCOMREC END; EGER; LOCALDATA: TRICKARRAY END (*MSCW*) ; (*SYSTEM COMMUNICATION AREA*) (*SEE INTERPRETERS...NOTE *) VAR SYSCOM: ^SYSCOMREC; (*MAGIC PARAM...SET UP IN BOOT*) GFILES: ARRAY [0..5] OF FIBP; (*GLOBAL FILES, 0=INPUT, 1=OUTP (*THAT WE ASSUME BACKWARD *) (*FIELD ALLOCATION IS DONE *) SYSCOMREC = RECORD IORSLT: IORSLTWD; (*RESULT OF LUT*) USERINFO: INFOREC; (*WORK STUFF FOR COMPILER ETC*) EMPTYHEAP: ^INTEGER; (*HEAP MARK FOR MEM MANAGING*) INPUTAST IO CALL*) XEQERR: INTEGER; (*REASON FOR EXECERROR CALL*) SYSUNIT: UNITNUM; (*PHYSICAL UNIT OF BOOTLOAD*) FIB,OUTPUTFIB, (*CONSOLE FILES...GFILES ARE COPIES*) SYSTERM,SWAPFIB: FIBP; (*CONTROL AND SWAPSPACE FILES*) SYVID,DKV BUGSTATE: INTEGER; (*DEBUGGER INFO*) GDIRP: DIRP; (*GLOBAL DIR POINTER,SEE VOLSEARCH*) LASTMP,STKBASE,BOMBP: MSCID: VID; (*SYSUNIT VOLID & DEFAULT VOLID*) THEDATE: DATEREC; (*TODAY...SET IN FILER OR SIGN ON*) DEBUGINFO: ^INTEGER BOOLEAN; FBUFFER: PACKED ARRAY [0..FBLKSIZE] OF CHAR)) END (*FIB*) ; (*USER WORKFILE STUFF*) INFOREC WP; MEMTOP,SEG,JTAB: INTEGER; BOMBIPC: INTEGER; (*WHERE XEQERR BLOWUP WAS*) HLTLINE: INTEGER; (*MORE DEBUGGER STU= RECORD SYMFIBP,CODEFIBP: FIBP; (*WORKFILES FOR SCRATCH*) ERRSYM,ERRBLK,ERRNUM: INTEGER; (*ERROR STUFF IN EDIT*) SLOWTFF*) BRKPTS: ARRAY [0..3] OF INTEGER; RETRIES: INTEGER; (*DRIVERS PUT RETRY COUNTS*) EXPANSION: ARRAY [0..8] OF IERM,STUPID: BOOLEAN; (*STUDENT PROGRAMMER ID!!*) ALTMODE: CHAR; (*WASHOUT CHAR FOR COMPILER*) GOTSYM,GOTCODE: BOOLEAN; (NTEGER; HIGHTIME,LOWTIME: INTEGER; MISCINFO: PACKED RECORD NOBREAK,STUPID,SLOWTERM, HASXYCRT,HASLC*TITLES ARE MEANINGFUL*) WORKVID,SYMVID,CODEVID: VID; (*PERM&CUR WORKFILE VOLUMES*) CRT,HAS8510A,HASCLOCK: BOOLEAN; USERKIND:(NORMAL, AQUIZ, BOOKER, PQUIZ) END; CRTTYPE: INTEGER; CRTCT, E STRING...SEE PROMPT*) IPOT: ARRAY [0..4] OF INTEGER; (*INTEGER POWERS OF TEN*) RE FREADLN(VAR F: FIB); FORWARD; PROCEDURE FWRITELN(VAR F: FIB); FORWARD; PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG:  FILLER: STRING[11]; (*NULLS FOR CARRIAGE DELAY*) DIGITS: SET OF '0'..'9'; UNITABLE: ARRAY [UNITNUM] OF (*0 NOT USEINTEGER); FORWARD; PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER); FORWARD; PROCEDURE SCOPY(VAR SRC,DEST:D*) RECORD UVID: VID; (*VOLUME ID FOR UNIT*) CASE UISBLKD: BOOLEAN OF TRUE: (UEOVBLK: INTEGER) END (*UNITABLE* STRING; SRCINX,COPYLENG: INTEGER); FORWARD; PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER); FORWARD; FUNCTION) ; (*-------------------------------------------------------------------------*) (* SYSTEM PROCEDURE FORWARD DECLARATIONS *) ( SPOS(VAR TARGET,SRC: STRING): INTEGER; FORWARD; FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; * THESE ARE ADDRESSED BY OBJECT CODE... *) (* DO NOT MOVE WITHOUT CAREFUL THOUGHT *) PROCEDURE EXECERROR; FORWARD; PROCEDUR NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER; FORWARD; PROCEDURE FGOTOXY(X,Y: INTEGER); FORWARD; (* NON FIXED FORE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER); FORWARD; PROCEDURE FRESET(VAR F: FIB); FORWARD; PROCEDURE FOPEN(VARWARD DECLARATIONS *) FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP): UNITNUM; FORWARD; PROCEDURE W F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK: FIBP); FORWARD; PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE); FORWRITEDIR(FUNIT: UNITNUM; FDIR: DIRP); FORWARD; FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE; FOARD; PROCEDURE FGET(VAR F: FIB); FORWARD; PROCEDURE FPUT(VAR F: FIB); FORWARD; PROCEDURE XSEEK; FORWARD; FUNCTION FEOF(VARRWARD; FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID; VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN;  F: FIB): BOOLEAN; FORWARD; FUNCTION FEOLN(VAR F: FIB): BOOLEAN; FORWARD; PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER);  FORWARD; PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; F FORWARD; PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER); FORWARD; PROCEDURE XREADREAL; FORWARD; PROCEDURE XWRITEREAL; DIR: DIRP); FORWARD; PROCEDURE HOMECURSOR; FORWARD; PROCEDURE CLEARSCREEN; FORWARD; PROCEDURE CLEARLINE; FORWARD; PROCED FORWARD; PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR); FORWARD; PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER); URE PROMPT; FORWARD; FUNCTION SPACEWAIT(FLUSH: BOOLEAN): BOOLEAN; FORWARD; FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR; FORWARD FORWARD; PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER); FORWARD; PROCEDURE FWRITESTRING(VAR F: FIB; VAR S; PROCEDURE COMMAND; FORWARD; ; (*DEBUGGERS GLOBAL INFO WHILE RUNIN*) STATE: CMDSTATE; (*FOR GETCOMMAND*) $PL: STRING; (*PROMPTLIN: STRING; RLENG: INTEGER); FORWARD; PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER); FORWARD; PROCEDU-  (*FIELD ALLOCATION IS DONE *) SYSCOMREC = RECORD IORSLT: INTEGER ; (*RESULT OF LAST IO CALL*) XEQERR: INTEGER;PACKED ARRAY [0..7] OF CHAR; 0SEGKIND: ARRAY [SEGRANGE] OF INTEGER; 0EXTRA: ARRAY [SEGRANGE] OF INTEGER; 0FILLER: ARRAY [1.; (*REASON FOR EXECERROR CALL*) SYSUNIT: INTEGER; (*PHYSICAL UNIT OF BOOTLOAD*) BUGSTATE: INTEGER; (*DEBUGGER INFO*) .88] OF INTEGER; 0NOTICE: STRING[79] .END;  VAR NBLOCKS,RSLT,OUTBLOCK: INTEGER; $BUF: BLOCK0P; $DSEG,SSEG: SEGRANGE; VAR1 VAR2  O^ GDIRP: INTEGER; LASTMP,STKBASE,BOMBP: INTEGER; MEMTOP,SEG,JTAB: INTEGER; BOMBIPC: INTEGER; (*WHERE XEQERR BLOWUP WAS*) HLTLINE: INTEGER; (*MORE DEBUGGER STUFF*) BRKPTS: ARRAY [0..3] OF INTEGER; RETRIES: INTEGER; (*DRIVERS PUT RETRY COUNTS*) EXPANSION: ARRAY [0..8] OF INTEGER; HIGHTIME,LOWTIME: INTEGER; MISCINFO: PACKED RECORD  NOBREAK,STUPID,SLOWTERM, HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN END; CRTTYPE: INTEGER;  CRTCTRL: PACKED RECORD RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR; BACKSPACE: CHAR; FILLCOUNT: 0..255; EXPANSION: PACKED ARRAY [0..3] OF CHAR END; CRTINFO: PACKED RECORD WIDTH,HEIGHT: INTEGER;  RIGHT,LEFT,DOWN,UP: CHAR; BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR; ALTMODE,LINEDEL: CHAR; EXPANSION: PACKED ARRAY [0..5] OF CHAR END; SEGTABLE: ARRAY [SEGRANGE] OF RECORD CODEUNIT: INTEGER;  (*$U-*)  CONST %MAXSEG = 15; (*MAX CODE SEGMENT NUMBER*)  TYPE (*CODE SEGMENT LAYOUTS*) SEGRANGE = 0..MAXSEG;  CODEDESC: SEGDESC END END (*SYSCOM*); VAR SYSCOM: ^SYSCOMREC; (*MAGIC PARAM...SET UP IN BOOT*)  SEGMENT  SEGDESC = RECORD DISKADDR: INTEGER; (*REL BLK IN CODE...ABS IN SYSCOM^*) CODELENG: INTEGER (*# BYTES TO READ IN*) PROCEDURE LIBRARIAN(III,JJJ: INTEGER);  CONST "WINDOW = 2; "ERROR = 23; "MARKCODE = 15; "MARKIN = 5; "   TYPE %BLOCK0 END (*SEGDESC*) ; (*SYSTEM COMMUNICATION AREA*) (*SEE INTERPRETERS...NOTE *) (*THAT WE ASSUME BACKWARD *) P = ^BLOCK0; %BLOCK0 = RECORD 0SEGDSC: ARRAY [SEGRANGE] OF SEGDESC; 0SEGNAME: ARRAY [SEGRANGE] OF . (WRITE(T+4:5,'-',SEGNAME[T+4],SEGDSC[T+4].CODELENG:6); (WRITE(T+8:5,'-',SEGNAME[T+8],SEGDSC[T+8].CODELENG:6); (WRITELN(T+12:5,T(COPYINTERFACE); &CODETABLE^.EXTRA[DSEG] := OUTBLOCK; $ DONE := FALSE; &REPEAT '-',SEGNAME[T+12],SEGDSC[T+12].CODELENG:6) &END;  PL := 'Code file length - '; "PROMPT(12); "WRITE(OUTPUT,OUTBLOCK);  END(IF BLOCKREAD(INFILE, BUF, 2, START) <> 2 THEN *BEGIN ,PL := 'Interface read err'; ,PROMPT(ERROR); ,DONE := TRUE *END (EL;    PROCEDURE LINKCODE; "VAR NBLOCKS: INTEGER;  "PROCEDURE LINKIT; $ $PROCEDURE COPYLINKINFO(INFOBLK: INTEGER); $ SE *IF BLOCKWRITE(CODE, BUF, 2, OUTBLOCK) <> 2 THEN ,BEGIN .PL := 'Interface write err'; .PROMPT(ERROR); .DONE := TRUE ,ENVAR N, NRECS: INTEGER; *DONE: BOOLEAN; *REC: ARRAY [0..7] OF INTEGER; *BUF: ARRAY [0..31, 0..7] OF INTEGER; $ (PROCEDURE GED *ELSE ,BEGIN .START := START+2; .OUTBLOCK := OUTBLOCK+2; .J := 0; .REPEAT 0IF BUF[J] IN ['A'..'Z', 'a'..'z'] THEN 2BEGTREC; (BEGIN *IF NRECS = 0 THEN ,IF BLOCKREAD(INFILE, BUF, 1, INFOBLK) <> 1 THEN .BEGIN 0PL := 'Link info read err'; 0PROMIN 4IDSEARCH(J,BUF); 4DONE := S = IMPLMTSY; 2 IF DONE THEN 6IF J < 510 THEN 8OUTBLOCK := OUTBLOCK-1 2END; 0IF BUF[J] = CPL,TITLE: STRING; CODETBL: BLOCK0; CODE,INFILE: FILE;  PROCEDURE NEWLINKER;  VAR CCH: CHAR; $INTBL: BLOCK0P; $NTITPT(ERROR); 0DONE := TRUE .END ,ELSE .IF BLOCKWRITE(CODE, BUF, 1, OUTBLOCK) <> 1 THEN 0BEGIN 2PL := 'Code file overflow'; LE: STRING; $CODETABLE: BLOCK0P; $PL: STRING;   PROCEDURE PROMPT(AT: INTEGER);  BEGIN "GOTOXY(0,AT); "IF AT = ERROR THEN2PROMPT(ERROR); 2DONE := TRUE 0END .ELSE 0BEGIN 2OUTBLOCK := OUTBLOCK+1; 2INFOBLK := INFOBLK+1; 2NRECS := 32 0END; *IF WRITE(CHR(7)); "WRITE(PL); "WITH SYSCOM^.CRTCTRL DO WRITE(ESCAPE,ERASEEOL);  END;   FUNCTION CHECKIO:BOOLEAN;  VAR RSLT: NOT DONE THEN ,REC := BUF[32-NRECS]; *NRECS := NRECS-1 (END { GETREC } ; ( $BEGIN { COPYLINKINFO } $ NRECS := 0; DONE :=INTEGER;  BEGIN "CHECKIO:=IORESULT=0; "IF IORESULT <> 0 THEN $BEGIN &RSLT:=IORESULT; &PL := 'I/O error # '; &PROMPT(ERROR FALSE; &REPEAT (GETREC; (IF NOT (REC[4] IN [0..14]) THEN *BEGIN ,PL := 'Bad link info'; ,PROMPT(ERROR); ,REC[4] := 0 *E); &WRITE(OUTPUT,RSLT); $END;  END; (* CHECKIO *)   PROCEDURE OPENFILE;  BEGIN "REPEAT $PL := 'Link Code File -> '; $PND; (DONE := REC[4] = 0; (IF NOT DONE THEN *IF REC[4] IN [1..5,13,14] THEN ,BEGIN { COPY REF LIST } .N := (REC[6]+7) DIV 8;ROMPT(4); $READLN(INPUT,NTITLE); $IF LENGTH(NTITLE) > 0 THEN &BEGIN (TITLE := NTITLE; (RESET(INFILE,NTITLE); " END;  .WHILE N > 0 DO 0BEGIN GETREC; N := N-1 END ,END &UNTIL DONE $END { COPYLINKINFO } ; $ $PROCEDURE COPYINTERFACE(START: I"UNTIL (CHECKIO) OR (LENGTH(NTITLE) = 0);  END (*OPENFILE*) ;   PROCEDURE DISPLAY(AT: INTEGER; WHAT: BLOCK0P);  VAR "T: INTEGER); $ CONST IMPLMTSY = 52; &VAR J: INTEGER; { FIXED DECLARATION ORDER } *S: INTEGER; *O: INTEGER; *N: PACKED ARRAY [0NTEGER;  BEGIN "GOTOXY(0,AT); "WITH WHAT^ DO $FOR T := 0 TO 3 DO &BEGIN (WRITE(T:3,'-',SEGNAME[T],SEGDSC[T].CODELENG:6); ..7] OF CHAR; *DONE: BOOLEAN; *BUF: PACKED ARRAY [0..1023] OF CHAR; $BEGIN $ IF (START <= 0) OR (START > 200) THEN & EXI/ ISKADDR := OUTBLOCK; 0OUTBLOCK := OUTBLOCK+NBLOCKS; 0IF NOT (SEGKIND[SSEG] IN [0..4]) THEN 2SEGKIND[SSEG] := 0; 0CODETABLE^.UNTIL CCH IN ['N','Q','A','n','q','a']; "CLOSE(INFILE)  END (*LINKCODE*) ;   BEGIN "PAGE(OUTPUT); "PL := 'Pascal System LSEGKIND[DSEG] := SEGKIND[SSEG]; 0CODETABLE^.EXTRA[DSEG] := 0; 0IF SEGKIND[SSEG] <> 0 THEN 2COPYLINKINFO(DISKADDR+NBLOCKS); 0ibrarian'; "PROMPT(0); "NEW(CODETABLE); "NEW(INTBL); "PL := 'Output code file -> '; "REPEAT $PROMPT(11); IF (SEGKIND[SSEG] IN [3,4]) THEN 2COPYINTERFACE(EXTRA[SSEG]) .END (END; &DISPLAY(MARKCODE,CODETABLE); $END; $  FUNCTION C$READLN(INPUT,TITLE); $IF LENGTH(TITLE) = 0 THEN EXIT(LIBRARIAN) $ELSE REWRITE(CODE,TITLE) "UNTIL (LENGTH(TITLE) = 0) OR (CHONFIRM: BOOLEAN; "VAR $N: INTEGER; "BEGIN $CONFIRM:=FALSE; $(*get segment*) $N:= 0; $PL := ''; $PROMPT(WINDOW); $REPEATECKIO); "OUTBLOCK := 1; NEW(BUF); "IF SIZEOF(BLOCK0) <> 512 THEN $HALT; "FILLCHAR(CODETABLE^, SIZEOF(BLOCK0), 0); "WITH COD &READ(CCH); &IF CCH = CHR(8) THEN (N := N DIV 10; &IF CCH IN ['0'..'9'] THEN (N := N*10 + ORD(CCH)-ORD('0') $UNTIL NOT (CETABLE^ DO $FOR DSEG := 0 TO MAXSEG DO &SEGNAME[DSEG] := ' '; "REPEAT $OPENFILE; $LINKCODE; "UNTIL CCH IN ['Q','q',CH IN [CHR(8),'0'..'9']); $IF CCH <> ' ' THEN (*probably N or Q*) &EXIT(CONFIRM); $IF N IN [0..MAXSEG] THEN (*good segment nu'A','a']; "IF CCH IN ['A','a'] THEN EXIT(LIBRARIAN); "PL := 'Notice? '; "PROMPT(23); "READLN(CODETABLE^.NOTICE); "IF BLOCKWmber*) &WITH INTBL^ DO (IF SEGDSC[N].CODELENG > 0 THEN (*any chunk of code*) *BEGIN ,SSEG := N; ,REPEAT RITE(CODE,CODETABLE^,1,0) = 1 THEN " CLOSE(CODE,LOCK) "ELSE $WRITELN(OUTPUT,'Code write error ')  END { NEWLINKER } ;  { .PL := 'Seg to link into? '; .PROMPT(WINDOW); .READ(DSEG) ,UNTIL DSEG IN [0..MAXSEG]; ,READ(CCH); { EAT XTRA CHAR } ,CCH : FUNCTION CHECKIO:BOOLEAN; VAR RSLT:INTEGER; BEGIN CHECKIO:=IORESULT=0; IF IORESULT <> 0 THEN BEGIN RSLT:=IORESULT;HR(13) THEN 2IF BUF[J+1] = CHR(0) THEN 4J := 1023; 0J := J+1 .UNTIL DONE OR (J > 1023) ,END &UNTIL DONE $END { COPYINTERF= 'Y'; (* TRICK THE REPLACEMENT BELOW *) ,IF (CODETABLE^.SEGDSC[DSEG].CODELENG <> 0) THEN (*linking again*) .BEGIN 0PL :=  'ACE } ; $ $BEGIN &WITH INTBL^,SEGDSC[SSEG] DO (BEGIN *NBLOCKS := (CODELENG+511) DIV 512; *IF BLOCKREAD(INFILE,BUF^,NBLOCKSWARNING - Segment already linked. Please Reconfirm (y/n) - '; 0PROMPT(WINDOW); 0READ(INPUT,CCH); 0WRITELN(OUTPUT); .END; ,,DISKADDR) <> NBLOCKS THEN ,BEGIN .PL := 'Error reading seg '; .PROMPT(ERROR); .WRITE(OUTPUT,SSEG) * END *ELSE ,IF BLOCKCONFIRM := CCH IN ['Y','y'] *END; "END; (* CONFIRM *)   BEGIN "IF LENGTH(NTITLE)>0 THEN $IF BLOCKREAD(INFILE,INTBL^,1,0) WRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN .BEGIN 0PL := 'I/O error - no room on disk'; 0PROMPT(ERROR); .END ,ELSE = 1 THEN &DISPLAY(MARKIN,INTBL) $ELSE &BEGIN (RSLT:=IORESULT; (PL := 'Read error # '; (PROMPT(ERROR); (WRITE(OUTPUT,RSLT).BEGIN 0CODETABLE^.SEGNAME[DSEG] := SEGNAME[SSEG]; 0CODETABLE^.SEGDSC[DSEG].CODELENG := CODELENG; 0CODETABLE^.SEGDSC[DSEG].D; &END; "PL :=  'Segment # to link and , N(ew file, Q(uit, A(bort'; "PROMPT(0); "REPEAT $IF CONFIRM THEN LINKIT; "0  UNTIL (CHECKIO) OR (LENGTH(TITLE) = 0); OPENFILE := LENGTH(TITLE) > 0 END (*OPENFILE*) ; PROCEDURE LINKCODE; VAR NBLOCKS: &REPEAT (WRITE(OUTPUT,'Output code file? '); READLN(INPUT,TITLE); (IF LENGTH(TITLE) > 0 THEN REWRITE(CODE,TITLE) &UNTIL (LE INTEGER; INTBL: BLOCK0; FUNCTION CONFIRM:BOOLEAN; VAR CH:CHAR; BEGIN CONFIRM:=FALSE; WITH INTBL DO BNGTH(TITLE) = 0) OR (CHECKIO); &IF LENGTH(TITLE) > 0 THEN (BEGIN OUTBLOCK := 1; NEW(BUF); *WITH CODETBL DO ,FOR DSEG := 0 TOEGIN IF SEGDSC[DSEG].CODELENG > 24 THEN BEGIN WRITE(OUTPUT,'Linking ',SEGNAME[DSEG],'. Please Confirm (y/n)'); READ(IN MAXSEG DO .BEGIN SEGNAME[DSEG] := ' '; 0SEGDSC[DSEG].CODELENG := 0; 0SEGDSC[DSEG].DISKADDR := 0 .END; PUT,CH); WRITELN(OUTPUT); IF (CODETBL.SEGDSC[DSEG].CODELENG <> 0) AND (CH IN ['Y','y']) THEN BEGIN WRITE(OUTPUT, 'WARNIN*WHILE OPENFILE DO LINKCODE; *WRITE('Notice:'); *READLN(CODETBL.NOTICE); *IF BLOCKWRITE(CODE,CODETBL,1,0) = 1 THEN CLOSE(CODG - segment already linked. Please Reconfirm'); READ(INPUT,CH); WRITELN(OUTPUT); END; CONFIRM := CH IN ['y','Y']; ENE,LOCK) *ELSE ,WRITELN(OUTPUT,'Code file write error ') (END  END }  BEGIN "NEWLINKER  END { LIBRARIAN } ;  BEGIN ED; END; END; (* CONFIRM *) BEGIN IF BLOCKREAD(INFILE,INTBL,1,0) = 1 THEN BEGIN WITH INTBL DO FOR DSEG := 0ND.  TO MAXSEG DO WITH SEGDSC[DSEG] DO IF CONFIRM THEN BEGIN NBLOCKS := (CODELENG+511) DIV 512; IF BLOCKREAD(INFILE,BUF^,NBLOCKS,DISKADDR) <> NBLOCKS THEN WRITELN(OUTPUT,'Error reading seg ',DSEG) ELSE  IF BLOCKWRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN WRITELN(OUTPUT,'I/O error - no room on disk') ELSE BEGIN WRITELN(OUTPUT,SEGNAME[DSEG],' Seg # ',DSEG,', Block ', OUTBLOCK,', ',CODELENG,' Bytes'); CODETBL.SEGNAME[DSEG] := SEGNAME[DSEG]; CODETBL.SEGDSC[DSEG].CODELENG := CODELENG; CODETBL.SEGDSC[DSEG].DISKADDR := OUTBLOCK; OUTBLO WRITELN(OUTPUT,'I/O error # ',RSLT); END; END; (* CHECKIO *) FUNCTION OPENFILE: BOOLEAN; BEGIN REPEAT WRITE(OUTPCK := OUTBLOCK + NBLOCKS END END END ELSE BEGIN RSLT:=IORESULT; WRITELN(OUTPUT,'Input file read erroUT,'Link Code File? '); READLN(INPUT,TITLE); IF LENGTH(TITLE) > 0 THEN RESET(INFILE,TITLE); r # ',RSLT); END; CLOSE(INFILE) END (*LINKCODE*) ; BEGIN IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN NEWLINKER "ELSE $BEGIN1 ES THAT HAVE BYTE ZERO *)  (* AS THE MOST SIGNIFICANT BYTE *)  SEGMENT PROCEDURE HEXEDIT(A,B:INTEGER); CONST US = 31; FS =NOPEN, WHOLOUTOPEN, POUTOPEN, PINOPEN: BOOLEAN; "CONCOUNT, WHOLOUTCOUNT, POUTCOUNT, PINCOUNT: INTEGER; "CONO^ 28; LF = 10; BS = 8; EM = 25; RS = 30; DC1 = 17; EEOL = 29; TYPE CHARBLOCK = PACKED ARRAY[0..511] OF CHAR; HEXBLOCKyf = PACKED ARRAY[0..1023] OF 0..15; (* HEX DIGITS *) DECBLOCK = PACKED ARRAY[0..255] OF INTEGER; "OCTBLOCK = PACKED ARRAY[0..255] OF PACKED RECORD FLO5: 0..7; {HI: 0..1;} FLO4: 0..7; {LO1: 0..7;} "{COMMENTED DECLARATION IS FOR} LO3: 0..7; {LO2: 0..7;} "{MACHINES WHERE BYTE ZERO IS} LO2: 0..7; {LO3: 0..7;} "{IS THE MOST SIGNIFICANT BYTE} LO1: 0..7; {LO4: 0..7;} FHI: 0..1; {LO5: 0..7;} DEND; DECBYTE = PACKED ARRAY[0..511] OF 0..255; "OCTBYTE = PACKED ARRAY[0..255] OF PACKED RECORD "{ COMMENTED DECLARATION IS FOR } HI3: 0..7; {LO3: 0..7;} "{ MACHINES WHERE BYTE ZERO IS } HI2: 0..7; {LO2: 0..7;} "{ THE MOST SIGNIFICANT BYTE } HI1: 0..3; {LO1: 0..3;} GLO3: 0..7; {HI3: 0..7;} GLO2: 0..7; {HI2: 0..7;} GLO1: 0..3; {HI1: 0..3;} EEND; &  VAR UNITNUM: INTEGER; AL(* PATCH UTILITY VERSION I.5 *)  (* TERED: BOOLEAN; FILEIO: BOOLEAN; FILEOK,BLOCKOK: BOOLEAN; TTABLE: ARRAY[0..3] OF INTEGER; HTABLE: PACKED ARRAY[0..15] OF *)  (* REWRITTEN FROM I.4 VERSION AUGUST 30, 1978 BY DAVID STEINORE *)  (*$U-*)  (*$S+*)  (*$I  CHAR; CCH: CHAR; UPLINE,DOWNLINE,RIGHTCOL,LEFTCOL: CHAR; BUF: RECORD CASE INTEGER OF 1: (HEX: HEXBLOCK); 2: (CH: CHARELEASE:SGLOBALS.TEXT*) {THESE ARE THE STRIPPED GLOBALS}  (* THIS PROGRAM IS SETUP FOR A MACHINE WHERE BYTE ZERO IS THE LEAST RBLOCK); 3: (DEC: DECBLOCK); )4: (OCT: OCTBLOCK); " 5: (DECB: DECBYTE); )6: (OCTB: OCTBYTE); $END; *)  (* SIGNIFICANT BYTE. COMMENTS HAVE BEEN APPENDED TO THOSE AREAS OF *)  (* CODE THAT NEED TO BE CHANGED FOR THOSE MACHIN BYTEDEC,BYTEOCT,KRUNCH,HEXADECIMAL,DECIMAL,OCTAL,ASCII,SPACING: BOOLEAN;  PL: STRING; "BLOCK: INTEGER; "CONOPEN, WHOLI2 CKOK := FALSE; BLOCK := 0; "SPACING := FALSE;  HEXADECIMAL:=FALSE; DECIMAL:=FALSE; ASCII:=FALSE; "KRUNCH:= TRUE; OCTAL(WRITE(POUTNAME); &WRITELN; $WRITELN; $WRITE(' G( Hexadecimal '); BOOL(HEXADECIMAL); $WRITE(' H( ASCII ');:=FALSE; "BYTEDEC:=FALSE; BYTEOCT:=FALSE;  CONOPEN:=FALSE; WHOLINOPEN:=FALSE; WHOLOUTOPEN:=FALSE; PINOPEN:=FALSE; "POUTOPE BOOL(ASCII); $WRITE(' I( Decimal '); BOOL(DECIMAL); $WRITE(' J( Octal '); BOOL(OCTAL); $WRITE(' K( N:=FALSE; CONCOUNT:=0; WHOLOUTCOUNT:=0; POUTCOUNT:=0; "CONNAME:=''; WHOLINNAME:=''; WHOLOUTNAME:=''; PINNAME:=''; POUTNAMEDecimal Bytes '); BOOL(BYTEDEC); $WRITE(' L( Octal Bytes '); BOOL(BYTEOCT); $WRITE(' M( Krunch '); BOOL(KRU:='';  END;  PROCEDURE CLEARFIELD(X,Y:INTEGER);  BEGIN "GOTOXY(X,Y); "WITH SYSCOM^.CRTCTRL DO WRITE(ESCAPE,ERASEEOL); NCH); $WRITE(' N( Double Space '); BOOL(SPACING); $REPEAT &I:=0; &GOTOXY(2,4); &READ(CHA); &IF CHA IN ['A','B','C','ENAME, WHOLINNAME, WHOLOUTNAME, POUTNAME, PINNAME: STRING; "CONFILE, WHOLINFILE, WHOLOUTFILE, PINFILE: FIL "GOTOXY(X,Y);  END; (*CLEARFIELD*)   FUNCTION GETINT(X,Y:INTEGER): INTEGER;  VAR I:INTEGER;  CH: CHAR; E; " POUTFILE : TEXT; " "  PROCEDURE PROMPT;  BEGIN "GOTOXY(0,0); "WRITE(PL); "WITH  BEGIN "READ(I); "GOTOXY(X,Y); "IF I<0 THEN BEGIN CLEARFIELD(X,Y); WRITE('IMPOSSIBLE'); I:=0; END; "GETINT:=I;  READ(CH)SYSCOM^.CRTCTRL DO WRITE(ESCAPE,ERASEEOL);  END; (*PROMPT*)  PROCEDURE CLEARSCREEN;  BEGIN "GOTOXY(0,0); "WITH SYSCOM^.CRT;  END; (*GETINT*)    PROCEDURE PATCHWRITE;  VAR QUIT:BOOLEAN;  PINNUMBER,PINSTART,PINEND: INTEGER;   "PROCEDURCTRL DO WRITE(ESCAPE,ERASEEOS);  END; (*CLEARSCREEN*)   FUNCTION READCH: CHAR; VAR CH: CHAR; BEGIN WITH SYSCOM^.CRTINFE SETUP(VAR QUIT:BOOLEAN); "VAR CHA: CHAR; &I: INTEGER; $ $PROCEDURE BOOL(B: BOOLEAN); $BEGIN &IF B THEN WRITE('True') ELO DO $BEGIN &READ(KEYBOARD,CH); &IF (CH = '`') OR (CH = UP) THEN (READCH := 'U' &ELSE IF (CH = CHR(US)) OR (CH = ' ') OR (CSE WRITE('False'); &WRITELN; $END; $ $FUNCTION GETBOOL(X,Y:INTEGER): BOOLEAN; $VAR CH: CHAR; $BEGIN %READ(CH); %GOTOXY(H = RIGHT) THEN (READCH := 'R' &ELSE IF (CH = CHR(3)) OR (CH = DOWN) THEN (READCH := 'Z' X,Y); %BOOL((CH = 'Y') OR (CH = 'T')); %GETBOOL:=((CH = 'Y') OR (CH = 'T')); $END; (*GETBOOL*) " " "BEGIN (*SETUP*) $WR&ELSE IF (CH = CHR(DC1)) OR (CH = CHR(BS)) OR (CH = LEFT) THEN (READCH := 'L' &ELSE IF CH IN ['a'..'z'] THEN (READCH := CHR(ITELN('Type the prefix character of the option you want to change.'); $WRITELN('Type ''P'' to PRINT, ''Q'' to QUIT.'); $WRITELORD(CH)-32) &ELSE READCH := CH; $END; END;  PROCEDURE INITIALIZE; BEGIN CLEARSCREEN; HTABLE := '0123456789ABCDEF'; "UPLN; $WRITE(' A( Input File '); &IF PINOPEN THEN (WRITE(PINNAME); &WRITELN; $WRITELN(' B( Begin Block # ', PINSTARTINE := CHR(US); DOWNLINE := CHR(LF); RIGHTCOL := CHR(FS); LEFTCOL := CHR(BS); ALTERED := FALSE; FILEOK := FALSE; BLO); $WRITELN(' C( Num. of Blocks ', PINEND); $WRITELN; $WRITE(' E( Output File '); $ IF POUTOPEN THEN 3 ,' TRY AGAIN'); 5CLEARFIELD(21,9); 3END /END; *'G': BEGIN CLEARFIELD(21,11); HEXADECIMAL:=GETBOOL(21,11); END; *'H': E,OLINE); *IF SPACING THEN WRITELN(POUTFILE); (END; &IF BYTEDEC THEN (BEGIN *WRITE(POUTFILE,PRINTINX+PRINTINX:3,':| '); BEGIN CLEARFIELD(21,12); ASCII:=GETBOOL(21,12); END; *'I': BEGIN CLEARFIELD(21,13); DECIMAL:=GETBOOL(21,13); EN*IF ROW < 17 THEN ,FOR I:=0 TO 29 DO .WRITE(POUTFILE,DBLINE[I]:3,' ') *ELSE ,BEGIN .WRITE(POUTFILE,DBLINE[0]:3,' '); .WRID; *'J': BEGIN CLEARFIELD(21,14); OCTAL:=GETBOOL(21,14); END; *'K': BEGIN CLEARFIELD(21,15); BYTEDEC:=GETBOOL(21,TE(POUTFILE,DBLINE[1]:3,' '); ,END; *WRITELN(POUTFILE); *IF SPACING THEN WRITELN(POUTFILE); (END; &IF BYTEOCT THEN (BEGIN 15); END; *'L': BEGIN CLEARFIELD(21,16); BYTEOCT:=GETBOOL(21,16); END; *'M': BEGIN CLEARFIELD(21,17); KRUNCH:=GE*WRITE(POUTFILE,PRINTINX+PRINTINX:3,':|'); *WRITELN(POUTFILE,OBLINE); *IF SPACING THEN WRITELN(POUTFILE); (END; &IF NOT KRUTBOOL(21,17); END; *'N': BEGIN CLEARFIELD(21,18); SPACING:=GETBOOL(21,18); END; (END; $UNTIL (CHA = 'P') OR (CHANCH THEN WRITELN(POUTFILE); $END; (*PRINTOUT*) " "BEGIN $GOTOXY(2,4); $WRITELN('PRINTING...'); $ALPHA := [' '..PRED(CHR(12 = 'Q'); $QUIT:=(CHA = 'Q'); "END; (*SETUP*) , "PROCEDURE PRINT; "VAR $I,ROW,PRINTINX,INX,DIGIT,STOP: INTEGER; 7))]; $WRITELN(POUTFILE,' BLOCK[',PINCOUNT,'] '); $WRITELN(POUTFILE, )' |',' 0: 2: 4: 6: 8: 10: $DBINX: 0..29; $DINX: 0..14; $OBINX,HINX,OINX,CINX: 0..131; $TOGGLE: BOOLEAN; $ALPHA: SET OF CHAR; $OBLINE,OLINE,CLINE,HLI 12: ', )'14: 16: 18: 20: 22: 24: 26: 28: '); $FOR ROW := 0 TO 17 DO &BEGIN (INX := ROW','G'..'N'] THEN (CASE CHA OF *'A': BEGIN * CLEARFIELD(0,21); 1CLEARFIELD(21,5); 1CLOSE(PINFILE); 1PINOPEN:=TRUE; 1NE: PACKED ARRAY[0..131] OF CHAR; $DBLINE: PACKED ARRAY[0..29] OF 0..255; $DLINE: PACKED ARRAY[0..14] OF INTEGER; $ "PROCEDUREADLN(PINNAME); 1RESET(PINFILE,PINNAME); 1IF IORESULT <> 0 THEN 3BEGIN 5PINOPEN:=FALSE; 5I:=IORESULT; 5CLOSE(PINFILE); 5RE PRINTOUT; $BEGIN &IF HEXADECIMAL THEN (BEGIN *WRITE(POUTFILE,PRINTINX+PRINTINX:3,':|'); *WRITELN(POUTFILE,HLINE); *IF SGOTOXY(2,21); 5WRITELN('Ioresult was ',I:4,' Try Again'); 5CLEARFIELD(21,5); 3END; /END; *'B': BEGIN CLEARFIELD(21,6); PIPACING THEN WRITELN(POUTFILE); (END; &IF ASCII THEN (BEGIN *WRITE(POUTFILE,PRINTINX+PRINTINX:3,':|'); *WRITELN(POUTFILE,CLINSTART:=GETINT(21,6); END; *'C': BEGIN CLEARFIELD(21,7); PINNUMBER:=GETINT(21,7); END; *'E': BEGIN NE); *IF SPACING THEN WRITELN(POUTFILE); (END; &IF DECIMAL THEN (BEGIN *WRITE(POUTFILE,PRINTINX+PRINTINX:3,':|'); *IF ROW 1CLEARFIELD(0,21); 1CLEARFIELD(21,9); 1CLOSE(POUTFILE,LOCK); 1POUTOPEN:=TRUE; 1READLN(POUTNAME); 1REWRITE(POUTFILE,POUTNAM< 17 THEN ,FOR I:=0 TO 15 DO .WRITE(POUTFILE,DLINE[I]:6,' ') *ELSE ,WRITE(POUTFILE,DLINE[0]:6,' '); *WRITELN(POUTFILE); E); 1IF I <> 0 THEN 3BEGIN 5CLOSE(POUTFILE); 5POUTOPEN:=FALSE; 5I:=IORESULT; 5GOTOXY(2,21); 5WRITELN('IORESULT WAS ',I:4*IF SPACING THEN WRITELN(POUTFILE); (END; &IF OCTAL THEN (BEGIN *WRITE(POUTFILE,PRINTINX+PRINTINX:3,':|'); *WRITELN(POUTFIL4 HEN *STOP := ((ROW +1)*15) (ELSE *STOP :=((ROW*15)+1); (*FOR LAST TWO BYTES*) (WITH BUF DO *REPEAT ,IF HEXADECIMAL THEN OBLINE[OBINX+2]:=HTABLE[OCTB[INX].HI3]; 0OBINX:=OBINX+4; 0OBLINE[OBINX]:=HTABLE[OCTB[INX].LO1]; 0OBLINE[OB.BEGIN {!} 0HLINE[HINX] :=HTABLE[HEX[INX*4+1]];(*FOR A MACHINE WITH BYTE *) 0HLINE[HINX+1]:=HTABLINX+1]:=HTABLE[OCTB[INX].LO2]; 0OBLINE[OBINX+2]:=HTABLE[OCTB[INX].LO3]; 0OBINX:=OBINX+4; .END; , E[HEX[INX*4+0]]; (*ZERO AS THE MOST SIG-*) 0HLINE[HINX+2]:=HTABLE[HEX[INX*4+3]]; (*NIFICANT BYTE USE THE *) 0HLINE[HINX+3]:=,INX := INX +1; ( (UNTIL (INX >= STOP); (PRINTOUT; &END(* ROW = 0..16 *); "END; (*PRINT*) "  BEGIN (* PATCHWRITE *) "PIHTABLE[HEX[INX*4+2]]; (*FOLLOWING ORDER OF CON-*) 0HINX:=HINX+8; (*STANTS IN PLACE OF THOSE*) .END; NSTART:=0; "PINNUMBER:=0; "PINCOUNT:=0; "CLEARSCREEN; "WRITELN('This procedure will write out sequential blocks to any file' (*MARKED {!} : 3,2,1,0 *) ,IF ASCII THEN .BEGIN >{!} 0IF (CH[INX+INX+0] IN ALPHA) THEN (*F); "WRITELN('as a patch dump'); "SETUP(QUIT); "IF NOT QUIT THEN $FOR PINCOUNT:=PINSTART TO PINSTART+PINNUMBER-1 DO &BEGIN OR A MACHINE AS ABOVE *) 2CLINE[CINX]:=CH[INX+INX+0]; (*EXCHANGE THE VALUE OF THE*) 0CINX:=CINX+2; {!} (IF FILEIO THEN *IF BLOCKREAD(PINFILE,BUF,1,PINCOUNT) <> 1 THEN ,BEGIN .BLOCKOK:=FALSE; .WRITE('Error reading block[',PINCO(*CONSTANTS MARKED {!} *) >{!} (*ZERO FOR ONE; ONE FOR ZERO*) 0IF (CH[INX+INX+1] IN ALPHA) THEN UNT,']. Type to continue'); , READ(CCH); , EXIT(PATCHWRITE); ,END *ELSE ,BLOCKOK:=TRUE (ELSE *BEGIN ,UNITREAD(2CLINE[CINX+1]:=CH[INX+INX+1]; 0CINX:=CINX+6; {!} .END; ,IF DECIMAL THEN .BEGIN 0DLINE[DINX] := DEC[INX]; 0UNITNUM,BUF,512,PINCOUNT); ,BLOCKOK:=(IORESULT = 0); * IF NOT BLOCKOK THEN .BEGIN .WRITE('Error reading block[',PINCOUNT,']DINX:=DINX+1; .END; ,IF OCTAL THEN .BEGIN 0OLINE[OINX] := HTABLE[OCT[INX].HI]; 0OLINE[OINX+1] := HTABLE[OCT[INX].LO1]; 0. Type to continue'); * READ(CCH); 0EXIT(PATCHWRITE); .END; *END; (PRINT; &END; (*FOR *)  END; (*PATCHWRITEOLINE[OINX+2] := HTABLE[OCT[INX].LO2]; 0OLINE[OINX+3] := HTABLE[OCT[INX].LO3]; 0OLINE[OINX+4] := HTABLE[OCT[INX].LO4]; 0OLINE*)   (*$I PATCH2.TEXT *) *15; (*INX IS A WORD INDEX*) (PRINTINX:=INX; (DBINX:=0; OBINX:=1; HINX:=1; OINX:=1; CINX:=1; DINX := 0; (FILLCHAR(HLINE,[OINX+5] := HTABLE[OCT[INX].LO5]; 0OINX:=OINX+8; .END; ,IF BYTEDEC THEN .BEGIN {!} {FOR MACHINES ASIZEOF(HLINE),' '); (FILLCHAR(DLINE,SIZEOF(DLINE),0); (FILLCHAR(CLINE,SIZEOF(CLINE),' '); S ABOVE TREAT} 0DBLINE[DBINX]:=DECB[INX+INX+0]; {AS FOR ASCII} 0DBLINE[DBINX+1]:=DECB[INX+INX+1]; 0DBINX:=DBINX+2; (FILLCHAR(OLINE,SIZEOF(OLINE),' '); (FILLCHAR(OBLINE,SIZEOF(OBLINE),' '); (FILLCHAR(DBLINE,SIZEOF(DBLINE),0); (IF ROW < 17 T {!} .END; ,IF BYTEOCT THEN .BEGIN 0OBLINE[OBINX]:=HTABLE[OCTB[INX].HI1]; 0OBLINE[OBINX+1]:=HTABLE[OCTB[INX].HI2]; 05 O^); ,END *ELSE ,WHOLOUTCOUNT:=WHOLOUTCOUNT+1; (I:=I+1; &END; (*WHILE*) $IF NOT BLOCKOK THEN &BEGIN (GOTOXY(2,13); (WRIT)fELN('Something wrong, File Locked, Loop Terminated'); (CLOSE(WHOLOUTFILE); (WHOLOUTOPEN:=FALSE; (WHOLOUTCOUNT:=0; (GOTOXY(2,15); (WRITELN('Type to continue'); (READLN(CHA); &END;  END; (* WRITING *) "  BEGIN (* WHOLEWRITE *) "START:=0; "NUMBER:=0; "CLEARSCREEN; "WRITELN('This procedure writes any number of blocks from an exsisting file'); "WRITELN('to a new file, unchanged. Simply specify the necessary paramters'); "WRITELN('Type ''P'' to PUT, ''Q'' to QUIT'); "WRITELN;  WRITE(' I(nput File '); $IF WHOLINOPEN THEN &WRITE(WHOLINNAME); $WRITELN; "WRITELN(' S(tart Block ',START); "WRITELN(' N(mber of Blcks ',NUMBER); "WRITELN; "WRITE(' O(utput File '); " IF WHOLOUTOPEN THEN &WRITE(WHOLOUTNAME); $WRITELN; "WRITELN; "REPEAT $GOTOXY(2,3); $READ (CHA); $I:=0; $IF CHA IN ['I','O','S','N'] THEN &CASE CHA OF ('I': BEGIN"  PROCEDURE WHOLEWRITE;  VAR I,J,START,NUMBER: INTEGER; $CHA: CHAR; $BUFFER: PACKED ARRAY[0..511] OF CHAR;  " "PROCE /WHOLINOPEN:=TRUE; /CLEARFIELD(0,11); /CLEARFIELD(20,4); /CLOSE(WHOLINFILE); /READLN(WHOLINNAME); /RESET(WHOLINFILE,WHOLIDURE WRITING; "BEGIN $GOTOXY(2,3); $WRITELN('WRITING...'); $I:=START; $BLOCKOK:=TRUE; $GOTOXY(2,11); $WHILE BLOCKOK AND (NNAME); /IF IORESULT <> 0 THEN 1BEGIN 3I:=IORESULT; 3CLOSE(WHOLINFILE); 3WHOLINOPEN:=FALSE; 3CLEARFIELD(20,5); 3GOTOXY(0,I <= START+NUMBER-1) DO &BEGIN (IF BLOCKREAD(WHOLINFILE,BUFFER,1,I) <> 1 THEN *BEGIN ,BLOCKOK := FALSE; ,WRITELN(IORESULT,'11); 3WRITELN(' Ioresult was ', I:4, ' Try again'); 1END; -END; - ('O': BEGIN /CLEARFIELD(0,11); /CLEARFIELD(20,8);  is IORESULT. Error occured reading block[', 8I,']'); *END; (IF BLOCKOK THEN *IF BLOCKWRITE(WHOLOUTFILE,BUFFER,1,WHOLOUTCO/CLOSE(WHOLOUTFILE,LOCK); /READLN(WHOLOUTNAME); /REWRITE(WHOLOUTFILE,WHOLOUTNAME); /WHOLOUTCOUNT:=0; /WHOLOUTOPEN:=TRUE; /UNT) <> 1 THEN ,BEGIN .BLOCKOK:=FALSE; .WRITELN(IORESULT,' is IORESULT.', :'Error occured writing block[',WHOLOUTCOUNT,']'IF IORESULT <> 0 THEN 1BEGIN 3WHOLOUTOPEN:=FALSE; 3I:=IORESULT; 3CLOSE(WHOLOUTFILE); 3GOTOXY(2,11); 3WRITELN('Ioresult wa6 10] IN ALPHA) THEN &WRITE(BUF.CH[510]:2) $ELSE &BEGIN (WRITE(HTABLE[BUF.HEX[1021]]); (WRITE(HTABLE[BUF.HEX[1020]]); &END; ROMPT; /WRITE(CHR(RS),CHR(37+COL+(COL DIV 4)),CHR(34+ROW)); -END; ('U': (* MOVE CURSOR UP *) ,IF ROW > 0 THEN .BEGIN 0ROW $IF CHARSOK AND (BUF.CH[511] IN ALPHA) THEN &WRITE(BUF.CH[511]:2) $ELSE &BEGIN (WRITE(HTABLE[BUF.HEX[1023]]); (WRITE(HTABL:= ROW-1; 0WRITE(UPLINE); .END; ('Z': (* MOVE CURSOR DOWN *) ,IF ROW < MAXROW THEN .BEGIN 0ROW := ROW+1; 0WRITE(DOWNLINE)E[BUF.HEX[1022]]); &END; $WRITELN; "END; (*DISPLAYHEX*) " "PROCEDURE FIXIT(USECHARS: BOOLEAN); "CONST $MAXROW = 17; $MAX; .END; ('R': (* MOVE CURSOR RIGHT *) ADVANCE; ('L': (* MOVE CURSOR LEFT *) ,IF COL > 0 THEN .BEGIN 0COL := COL-1; 0IF ((s ',I:4,' Try again'); / CLEARFIELD(20,8); 1END; -END; ('S': BEGIN CLEARFIELD(20,5); START:=GETINT(20,5); END; ('N':COL = 59; "VAR $CCH: CHAR; $ROW,COL: INTEGER; $INX: INTEGER; $VAL,BYTES: INTEGER; " "PROCEDURE ADVANCE; "BEGIN  BEGIN CLEARFIELD(20,6); NUMBER:=GETINT(20,6); END; &END; "UNTIL (CHA = 'Q') OR (CHA = 'P'); "IF CHA <> 'Q' THEN WRITING;$IF COL < MAXCOL THEN &BEGIN (COL := COL +1; (WRITE(RIGHTCOL); (IF (COL MOD 4) = 0 THEN WRITE(RIGHTCOL) &END $ELSE &IF R  END;(*WHOLEWRITE*)   PROCEDURE CONSOLE;  VAR TITLE: STRING; $CH: CHAR; $TESTNUM: INTEGER; $ "PROCEDURE DISPLAYHEX(CHAOW < MAXROW THEN (BEGIN *ROW := ROW +1; *COL := 0; *WRITE(CHR(RS),CHR(37),CHR(34+ROW)); (END "END; " "PROCEDURE GETVAL; RSOK: BOOLEAN); "VAR $DIGIT,STOP: INTEGER; $INX,ROW,TINX: INTEGER; $TOGGLE: BOOLEAN; $ALPHA: SET OF CHAR; $TLINE: PACKED A"BEGIN $CLEARSCREEN; $WRITE('Fill with what hex pair:'); $REPEAT &CCH := READCH $UNTIL CCH IN ['0'..'9','A'..'F']; $IF CCRRAY[0..73] OF CHAR; "BEGIN $ALPHA := [' '..PRED(CHR(127))]; $CLEARSCREEN; $WRITELN; $WRITELN(' |', "' 0: 2: 4: 6H IN ['0'..'9'] THEN VAL := ORD(CCH)-ORD('0') $ELSE VAL := ORD(CCH)-ORD('A')+10; $WRITE(CCH); $REPEAT &CCH := READCH $UNTIL: 8: 10: 12: 14: 16: 18: 20: 22: 24: 26: 28:'); $FOR ROW := 0 TO 16 DO &BEGIN (INX := ROW*30;  CCH IN ['0'..'9','A'..'F']; $IF CCH IN ['0'..'9'] THEN VAL := VAL*16+ORD(CCH)-ORD('0') $ELSE VAL := VAL*16+ORD(CCH)-ORD('A')+(WRITE(INX:3,':|'); (TINX := 1; (FILLCHAR(TLINE,SIZEOF(TLINE),' '); (STOP := ((ROW +1)*30); (WITH BUF DO *REPEAT ,IF CHAR10; $WRITE(CCH) "END; " "BEGIN $DISPLAYHEX(USECHARS); $ROW := 0; $COL := 0; $PL := 'Alter: pad vector 1,5,3,0 0..F hex SOK AND (CH[(INX)] IN ALPHA) THEN .TLINE[TINX] := CH[(INX)] ,ELSE .BEGIN 0TLINE[TINX] := HTABLE[HEX[INX+INX]]; 0TLINE[TINX-characters, S(tuff Q(uit'; $PROMPT; $WRITE(CHR(RS),CHR(37),CHR(34)); (* GO TO 0,0 FOR THE HEX DUMP *) $REPEAT &CCH := READCH1] := HTABLE[HEX[INX+INX+1]] .END; ,INX := INX +1; ,IF ODD(INX) THEN .TINX := TINX +2 ,ELSE .TINX := TINX +3; *UNTIL (INX; &CASE CCH OF ('S': (* STUFF BUFFER *) -BEGIN /ALTERED := TRUE; /INX := ((ROW*60)+COL) DIV 2; /CLEARSCREEN;  >= STOP); (WRITELN(TLINE); &END(* ROW = 0..16 *); $(* NOW DO THE PARTIAL ROW *) $WRITE('512:|'); $IF CHARSOK AND (BUF.CH[5/WRITE('Stuff for how many bytes: '); /READLN(BYTES); /GETVAL; /FILLCHAR(BUF.CH[INX],BYTES,VAL); /DISPLAYHEX(USECHARS); /P7 ve,',PL,POS(':',PL)+1); $IF FILEOK THEN INSERT(' R(ead,',PL,POS(':',PL)+1); $PROMPT; $IF BLOCKOK THEN WRITE(' [',BLOCK,']'); 5UNITCLEAR(UNITNUM); 5IF IORESULT <> 0 THEN 7BEGIN 9WRITELN('No such unit. Type to continue.'); 9READ(CH); 9FILEO$CH := READCH; $CLEARSCREEN; $CASE CH OF &'H','M': IF BLOCKOK THEN FIXIT(CH = 'M'); &'S': IF ALTERED THEN ,BEGIN .ALTEREDK:=FALSE; 7END 5ELSE 7FILEOK:=TRUE; / END; /END; +END; &END; (* CASE *) " UNTIL CH = 'Q'; "END;(* CONSOLE *) "  B := FALSE; .IF FILEIO THEN 0IF BLOCKWRITE(CONFILE,BUF,1,BLOCK) <> 1 THEN (* OOPS *) ELSE .ELSE 0UNITWRITE(UNITNUM,BUF,512,BLEGIN (* MAIN *) "INITIALIZE; "REPEAT $CLEARSCREEN; $PL:='C(onsole, P(atchwrite, W(holewrite, Q(uit '; $PROMPT; $READ(CCH);OCK); ,END; &'R': IF FILEOK THEN -BEGIN /ALTERED := FALSE; /WRITE('BLOCK: '); /READLN(BLOCK); /IF FILEIO THEN 1IF BLOCKR $IF CCH IN ['C','P','W'] THEN &CASE CCH OF ('C': CONSOLE; ('P': PATCHWRITE; ('W': WHOLEWRITE; &END; $UNTIL CCH = 'Q'; EAD(CONFILE,BUF,1,BLOCK) <> 1 THEN 3BEGIN 5BLOCKOK := FALSE; 5WRITE(' Error reading block ') 3END $CLOSE(PINFILE); "CLOSE(POUTFILE,LOCK); "CLOSE(WHOLINFILE); "CLOSE(WHOLOUTFILE,LOCK); "CLOSE(CONFILE); END;   BEGIN  END1ELSE (*alls well that reads well*) BLOCKOK := TRUE /ELSE 1BEGIN 3UNITREAD(UNITNUM,BUF,512,BLOCK); 3BLOCKOK := (IORESULT = .  (COL+1) MOD 4) = 0) THEN 2WRITE(LEFTCOL); 0WRITE(LEFTCOL); .END; ('0','1','2','3','4','5','6','7','8','9':(* CHANGE HEX DIGI0); 1END -END; &'G': BEGIN -ALTERED := FALSE; -BLOCKOK := FALSE; -CLOSE(CONFILE); -PL:='Filename: '; -PT *) ,BEGIN .IF ODD(COL) THEN 0INX := (ROW*60)+COL-1 .ELSE 0INX := (ROW*60)+COL+1; .IF INX < 1024 THEN 0BEGIN 2BUF.HEX[IROMPT; -READLN(TITLE); -FILEIO := (LENGTH(TITLE) > 0); -IF FILEIO THEN /BEGIN 1RESET(CONFILE,TITLE); 1FILEOK := (IORESULT NX] := ORD(CCH)-ORD('0'); 2WRITE(CCH,LEFTCOL); 2ADVANCE; 2ALTERED := TRUE; 0END; ,END; ('A','B','C','D','E','F': ,BEGIN = 0); 1IF (TITLE[1] = '#') AND (TITLE[LENGTH(TITLE)] = ':') THEN 3BEGIN 5DELETE(TITLE,1,1); 5DELETE(TITLE,LENGTH(TITLE),1); .IF ODD(COL) THEN 0INX := (ROW*60)+COL-1 .ELSE 0INX := (ROW*60)+COL+1; .IF INX < 1024 THEN 0BEGIN 5IF LENGTH(TITLE) = 2 THEN 7TESTNUM:=10*(ORD(TITLE[1])-ORD('0')) + (ORD(TITLE[2]) - FORD('0')) 6ELSE 8TESTNUM:=ORD(TITLE[12BUF.HEX[INX] := ORD(CCH)-ORD('A')+10; 2WRITE(CCH,LEFTCOL); 2ADVANCE; 2ALTERED := TRUE; 0END; ,END &END (* CASE ON CCH *)]) - ORD('0'); 6UNITCLEAR(TESTNUM); 6FILEOK:= (IORESULT = 0); 4END; 1IF NOT FILEOK THEN 3BEGIN 0WRITELN(IORESULT,' error o $UNTIL CCH = 'Q'; "END; "  BEGIN (* CONSOLE *) "BLOCKOK := FALSE; "ALTERED := FALSE; "FILEOK := FALSE; "REPEAT $CLEARn ',TITLE,' Type to continue'); 5READ(CH); 3END; /END -ELSE /BEGIN 1PL:=' Unitnum to patch [4,5,9..12] (0 will QuSCREEN; $PL := 'Patch: G(et, Q(uit'; $IF BLOCKOK THEN INSERT(' H(ex, M(ixed',PL,POS(':',PL)+1); $IF ALTERED THEN INSERT(' S(ait) '; 1PROMPT; 1REPEAT 3READ(UNITNUM); 1UNTIL UNITNUM IN [0,4,5,9..12]; 1IF UNITNUM <> 0 THEN 3BEGIN 8 O^*{$S+}  {$I GLOBALS.TEXT}  {$I FILER.A.TEXT}  {$I FILER.B.TEXT}  {$I FILER.C.TEXT}  {$I FILER.D.TEXT}  O^**9 DLER }  { }  { RELEASE LEVEL: F.5 SEPTEMBER, 1978 } LONGSTRING = STRING[255]; { Longest string available } "SHORTSTRING = STRING[SHSTRLENG]; { For handling volume & file names }  { }  { }  { WRITTEN BY ROGER T. "STRNG = STRING[MAXTITLE]; { For handling concatted volume & filenames }   VAR SUMNER }  { WINTER, 1977 }  { MODIFIED AND UPDATED BY STEVEN S THOMSON }  "GS : STRING; { General purpose string. Used primarily for prompt lines } "CH : CHAR; { General purpose character { SEPTEMBER, 1978 }  { }  { INSTITUTE FOR INFORMA} "GDIR : DIRP; { Global pointer to the directory } "GINX : DIRRANGE; { 0..77 } "GKIND : FILEKIND; { UNTYPEDFILE, XDSKFTION SYSTEMS }  { UC SAN DIEGO, LA JOLLA, CA }  { }  {ILE, CODEFILE, TEXTFILE } 4{ INFOFILE,DATAFILE, GRAFFILE, FOTOFILE } " "SAVEUNIT, GUNIT : UNITNUM; { 0..12 } "GBUF: WINDOWP KENNETH L. BOWLES, DIRECTOR }  { }  { ; { Pointer to buffer window } "FOUND, QUESTION, WILDCARD, { For wildcard information only! } "OK, DONE, { General  }  {**********************************************}   purpose booleans } "BADCOMMAND, { Check for incorrect input to general prompt line } "SYMSAVED, CODESAVED : BOOLEAN; { W { Copyright (C) 1978 Regents of the University of California. }  { Permission to copy or distribute this softwareorkfile information } "VOLNAME1, VOLNAME2, { Volume names for source and dest. respectively } "SAVEGVID, SAVEVID, { Used in  or documen- }  { tation in hard or soft copy granted only by written license }  { obtained from the Institutsearchdir and savework to save VID's } "GVID, { General purpose VID } "GVID2 : VID; { Unmodified VID. Usee for Information Systems. }    SEGMENT PROCEDURE FILEHANDLER(ZZZZZ,ZZZZZZ : INTEGER); "  CONST SHSTRLENG = 25d in savework } "GBUFBLKS, { Keeps track of number of blocks available in buffer } ; MAXTITLE = 40;   TYPE "ERRANGE = 0..100; { Range of error messages } "ERRORS = SET OF ERRANGE; { Set of error me"X, I : INTEGER; { General purpose integers } "STRING1, STRING2, { Wildcard scan strings source file } "STRING3, STRING4, {ssage numbers. Used in scaninput } "CHECKS = (BADTITLE, NOVOL, BADDIR, BADFILE, UNBLKDVOL, OKDIR, OKFILE); <{ Possible states  Wildcard replacement strings destination } "NEWSTRING, { String left after removing scan strings from filename } "SAVE {**********************************************}  { }  { UCSD PASCAL FILEHANof a file or volume name } " "CHCKS = SET OF CHECKS; { Set of states that a file can be in. } <{ Used in scaninput } " ": *CODESAVED := TRUE &END; $ $FINIT(GFIB,NIL,-1); $MARK(GBUF); $ ${ Set GBUFBLKS equal to the number of blocks available in { IBADTITLE } (8: GS := 'No room on vol'; { INOROOM } (9: GS := 'No such vol on-line'; { INOUNIT } '10: GS the buffer } $ $GBUFBLKS := 0; $I := SIZEOF(DIRECTORY)+SIZEOF(FIB)+2048; { QUITSIZE } $REPEAT &NEW(ONEBLOCK); &GBUFBLKS : := 'File not found'; { INOFILE } '11: GS := 'Dup dir entry'; { IDUPFILE } '12: GS := 'Filer error!!' GTID, { Used in savework to save GTID } "GTID : TID; { General purpose TID } "FROMWHERE, TOWHERE : STRNG; { Sour= GBUFBLKS+1; &X := ORD(SYSCOM^.LASTMP)-ORD(ONEBLOCK)-FBLKSIZE { GAPSIZE } ce $ destination strings respectively } "FILENAM1, FILENAM2 : SHORTSTRING; { Source & dest. filenames respectively. } D{ None $UNTIL ((X > 0) AND (X < I)) OR (GBUFBLKS = 63) {PREVENT INTEGER OFLOW} "END {FILERINIT} ; # # "PROCEDURE CLEAR;  "BEGINwildcard only } "INSTRING : LONGSTRING; { For input off of main prompt line } "GFIB : FIB; { General purpose FIB } "MON { CLEAR } $GVID := ''; $GVID2 := ''; $GTID := ''; $STRING1 := ''; $STRING2 := ''; $STRING3 := ''; $STRING4 := ''; THS : ARRAY [0..15] OF STRING[3]; { Holds abbreviations for valid months }   "PROCEDURE FILERINIT; " "TYPE $ABLOCK = PA { Used to clear selected global strings & booleans } $VOLNAME1 := ''; { between commands in the outer block of the filerCKED ARRAY [1..FBLKSIZE] OF CHAR; " "VAR $ONEBLOCK: ^ABLOCK; " "BEGIN { FILERINIT } +{ Initializes the months } $ $MONTH } $VOLNAME2 := ''; { and under error conditions } $FILENAM1 := ''; $FILENAM2 := ''; $TOWHERE := ''; $FROMWHERE := ''S[ 0] := '???'; MONTHS[ 1] := 'Jan'; $MONTHS[ 2] := 'Feb'; MONTHS[ 3] := 'Mar'; $MONTHS[ 4] := 'Apr'; MONTHS[ 5] := 'May'; ; $WILDCARD := FALSE; $QUESTION := FALSE; "END { CLEAR }; # ! "PROCEDURE CLWRITELN(STR : STRING); " "{ Commonly used for$MONTHS[ 6] := 'Jun'; MONTHS[ 7] := 'Jul'; $MONTHS[ 8] := 'Aug'; MONTHS[ 9] := 'Sep'; $MONTHS[10] := 'Oct'; MONTHS[11] := 'Nomat for output } " "BEGIN { CLWRITELNO } $WRITE(OUTPUT,STR); $CLEARLINE; $WRITELN(OUTPUT) "END { CLWRITELNO }; ! ! "PROv'; $MONTHS[12] := 'Dec'; MONTHS[13] := '???'; $MONTHS[14] := '???'; MONTHS[15] := '???'; $ ${ If an updated file exists in CEDURE MESSAGES(NUMBER : ERRANGE); " $PROCEDURE FILERERRORS; $ $BEGIN { FILERERRORS } &CASE NUMBER OF (1: GS := 'Parity (the workfile and it hasn't been saved } ${ yet, then set symsaved and codesaved to false if their respective files } ${ haCRC) error'; { IBADBLOCK } (2: GS := 'Bad unit number'; { IBADUNIT } ve not been saved. Otherwise, set symsaved and codesaved to false } $ $WITH USERINFO DO &BEGIN (IF GOTSYM THEN *SYMSAVED(3: GS := 'Bad IO operation'; { IBADMODE } (4: GS := 'Timeout error'; { ITIMEOUT } (5: GS := 'Vol went off-li := SYMTID <> 'SYSTEM.WRK.TEXT' (ELSE *SYMSAVED := TRUE; (IF GOTCODE THEN *CODESAVED := CODETID <> 'SYSTEM.WRK.CODE' (ELSE ne'; { ILOSTUNIT } (6: GS := 'File lost in dir'; { ILOSTFILE } { I/O error messages } (7: GS := 'Bad file name'; ; := CONCAT('No ',GS) 4END; (52,53,54 : 3BEGIN 5CASE NUMBER OF 752 : GS := 'file'; 753,54 : GS := 'volume' 5END; STRG[I] >= 'a' ) AND ( STRG[I] <= 'z' ) THEN (STRG[I] := CHR( ORD( STRG[I] ) - ORD( 'a' ) + ORD ('A' )) "END { TOUPPER }; " 5GS := CONCAT('Illegal ',GS,' name'); 5IF NUMBER <> 54 THEN 7GS := CONCAT(GS,' ') 3END; (60,61 : BEGIN 5CASE N& "PROCEDURE EATSPACES(VAR STRG : LONGSTRING); " "VAR $I : INTEGER; $ "{ Removes unprintable characters & blanks from STRGUMBER OF 760 : GS := 'Vol to file name'; 761 : GS := 'File to vol name' 5END; 5GS := CONCAT('Illegal change <',GS, } " "BEGIN {EATSPACES} $I := 1; $WHILE I <= LENGTH(STRG) DO &IF STRG[I] > ' ' THEN (I := I + 1 &ELSE (DELETE(STRG,I,1) '>') 3END; (64 : GS := ' file name '; (65 : GS := ' scan string '; (66 : GS := ' volume name '; "END {EATSPACES} ; ! ! "FUNCTION NGETCHAR(TEMP : BOOLEAN) : CHAR; " "{ Very frequent structure for calling getchar } " "(67 : GS := '- Illegal format'; (68 : GS := ' - char. max >'; (69 : GS := 'No directory on volume'; (70 : BEGIN $CLEARLINE; $NGETCHAR := GETCHAR(TEMP); $IF NOT EOLN(INPUT) THEN &WRITELN(OUTPUT); "END;  { INOTCLOSED } &END $END; { FILERERRORS } # ' $PROCEDURE EXPECTED; $ $BEGIN { EXPECTED } &{ Messages giving information GS := 'File found'; (72 : GS := 'Volume already on line'; (73 : GS := 'Output file full'; (75 : GS := as to the type } &{ of file that was expected on input } & &CASE NUMBER OF (79,80 : GS := 'Blkd volume'; (78,81 : GS := ' 'Workfile already saved'; (76 : GS := 'No workfile to save'; (78,79,80,81,82,83,84,85,86 : EXPECTED; (90,91 : BEGIUnblkd volume'; (82,83,84 : -BEGIN /IF NUMBER <> 82 THEN 1BEGIN 3GS := ' or '; 3IF NUMBER = 83 THEN 5GS := CONCAT(GS,'un'N 5IF NUMBER = 90 THEN 7GS := 'Text' 5ELSE 7GS := 'Code'; 5GS := CONCAT(GS,' file lost ') 3END; (100 : CLWRITELN( 5); 3GS := CONCAT(GS,'blkd vol') 1END; /GS := CONCAT('File name',GS) -END; (85 : GS := 'File or vol name'; 'Dangerous! Suggest using ? on wildcards to same vol') &END; $WRITE(OUTPUT,GS); $CLEARLINE "END; { MESSAGES } & & "FUNCTI(86 : GS := 'Volume name' &END; &IF NOT (NUMBER IN [78,79]) THEN (GS := CONCAT(GS,' expected') $END; { EXPECTED } # "BEGION CHECKRSLT(RSLT : ERRANGE) : BOOLEAN; " "{ Returns as true if the result of the I/O operation passed to it was } "{ equal tN { MESSAGES } { General messages & error messages } $GS := ''; $IF NUMBER <> 0 THEN &CASE NUMBER OF (1,2,3,4,5,6,7,8,9,10o zero. Otherwise, prints error message and returns as false } " "BEGIN $CHECKRSLT := RSLT = 0; $IF RSLT <> 0 THEN &MESSAGE,11,12 : FILERERRORS; (40 : GS := 'Wildcard not allowed'; (41,42 : BEGIN 5IF NUMBER = 42 THEN 7GS := 'not '; 5GS :S(RSLT) "END; " " "PROCEDURE TOUPPER(VAR STRG : LONGSTRING; START,STOP : INTEGER); " "VAR $I : INTEGER; $ = CONCAT('First vol/file name was ',GS,'a wildcard') 3END; (50,51 : 3BEGIN 5GS := 'file loaded'; 5IF NUMBER = 51 THEN 7GS "{ Changes STRG [START] through STRG [STOP] into uppercase letters } " "BEGIN { TOUPPER } $FOR I := START TO STOP DO &IF ( < 4(OLDUNIT = VID1); { Valid directory on line } &END "END { INSERTVOLUME }; * * "FUNCTION SCANINPUT(GTITLE : STRNG; CHECK : CHCKS; 9ERROR,WHERE : ERRANGE) : BOOLEAN; " "VAR $DUMMY : ^INTEGER; $GSEGS : INTEGER; " $PROCEDURE MAKECALL(ERR : ERRANGE; ERRS : ERRORS; SAVETEST : CHECKS); $ $BEGIN &SCANINPUT := SAVETEST IN CHECK; { Was GTITLE of an acceptable state } &IF NOT (SAVETEST IN CHECK) THEN { If not scaninput is false } (IF (GTITLE <> '') AND (ERROR <> 0) THEN *BEGIN ,IF GTITLE [1] = ':' THEN .GTITLE := CONCAT(DKVID,GTITLE); ,IF GTITLE [1] = '*' THEN , BEGIN 0DELETE(GTITLE,1,1); 0IF GTITLE <> '' THEN 2IF "FUNCTION INSERTVOLUME(INTUNIT : INTEGER; VID1 : VID; DCHECK : BOOLEAN) : BOOLEAN; " "VAR $OLDUNIT, NEWUNIT : VID; $OK : GTITLE [1] = ':' THEN 4DELETE(GTITLE,1,1); 0GTITLE := CONCAT(SYVID,':',GTITLE) .END; ,HOMECURSOR; ,CLWRITELN(''); ,WRITE(OBOOLEAN; " "BEGIN { INSERTVOLUME } $OLDUNIT := '# '; $IF (INTUNIT DIV 10) = 1 THEN &OLDUNIT [2] := '1'; $OLDUNIT [3] := CUTPUT,GTITLE,' - '); { Write string in error } ,MESSAGES(ERR); { Write the state of the string } ,IF NOT SYSCOM^.HR(ORD('0') + INTUNIT MOD 10); $EATSPACES(OLDUNIT); $NEWUNIT := OLDUNIT; $INSERTVOLUME := TRUE; $OK := FALSE; $IF CHECK THEMISCINFO.SLOWTERM THEN { Not a slow terminal } .BEGIN 0IF ERROR IN ERRS THEN { It's appropriate to write out what } N { Check if there's a valid directory on-line } &IF VOLSEARCH(VID1,TRUE,GDIR) = INTUNIT THEN (OK := TRUE &ELSE (IF VOLSEARCH(NEWUNIT,TRUE,GDIR) <> 0 THEN *IF NEWUNIT = VID1 THEN { Valid directory on line } ,OK := TRUE; $IF NOT OK THEN { Need to inO^sert correct volume } &BEGIN (IF CHECK THEN *WRITE(OUTPUT,'Put ',VID1,': in unit ',OLDUNIT) (ELSE *WRITE(OUTPUT,'Put in ',VJID1,':'); (CLWRITELN(''); (CLEARLINE; (IF SPACEWAIT(TRUE) THEN *INSERTVOLUME := FALSE { User wishes to abort } (ELSE *IF CHECK THEN { Check if there's a valid directory on-line } ,INSERTVOLUME := (VOLSEARCH(OLDUNIT,TRUE,GDIR) <> 0) AND = INE *END $END; & & "BEGIN { SCANINPUT } $EATSPACES(GTITLE); { Remove spaces and non-printable characters } $IF SCANTITLE(LE } &NEWSTRING := ''; &LENTITLE := LENGTH(SEARCHTITLE); { Filename to be checked } GTITLE,GVID,GTID,GSEGS,GKIND) THEN { Break up input string } &BEGIN (MARK(DUMMY); { Force the reading of a new directory. Kl&LENSTART := LENGTH(STRING1); { Starting string to be matched } &LENSTOP := LENGTH(STRING2); { Ending string to be maudge } 7{ for when two disks on-line have the same name } (GVID2 := GVID; { Save present GVID. Used in savework } (GUNIT := Vtched } &SEARCHFILE := FALSE; &IF (LENSTART + LENSTOP) <= LENTITLE THEN (BEGIN { String1 & string2 will noOLSEARCH(GVID,TRUE,GDIR); { Search for proper volume } (IF GUNIT = 0 THEN *MAKECALL(9,[80,81,82,83,84],NOVOL) { No sucht overlap } *TEMP[0] := STRING1[0]; 1 *{ Set TEMP equal to the first LENSTART char. of SEARCHTITLE } *MOVELEFT(SEARCHTITLE[1 volume was on-line } (ELSE *IF GDIR = NIL THEN ,IF UNITABLE [GUNIT].UISBLKD THEN .MAKECALL(69,[82],BADDIR) { Volum],TEMP[1],LENSTART); *IF TEMP = STRING1 THEN { They match. Everything is o.k. } ,BEGIN .TEMP[0] := STRING2[0]; . .{ Set tee was blocked, but no } ,ELSE { directory was on it } mp equal to the last lenstop char. of SEATCHTITLE } .MOVELEFT(SEARCHTITLE[LENTITLE - LENSTOP + 1],TEMP[1],LENSTOP); .IF TEMP =.MAKECALL(78,[80,82,84],UNBLKDVOL) { Volume was not blocked } *ELSE ,IF DIRSEARCH(GTID,TRUE,GDIR) <> 0 THEN .MAKECALL(70,[80 STRING2 THEN { They match. Everything is still o.k. } 0BEGIN 2{ Set NEWSTRING equal to the string left between } 2{ START1 $,81,86],OKFILE) { File was found } ,ELSE .IF GTID = '' THEN 0MAKECALL(79,[81,82,83],OKDIR) { Volume was blocked & the }  START2 in SEARCHTITLE } 2NEWSTRING := COPY(SEARCHTITLE,LENSTART + 1, FLENTITLE - LENSTART - LENSTOP); 2IF LENGTH(NEWSTRING) .ELSE { directory is ok } 0MAKECALL(10,[80,81,86],BADFILE) { Volume was blocked & ok, but } &END+ LENGTH(STRING3) + LENGTH(STRING4) >> TIDLENG THEN { Resulting string is too long } 4NEWSTRING := '' 2ELSE  { the file was not found } $ELSE &IF GVID = '' THEN (MAKECALL(53,[82],BADTITLE) { File4BEGIN { Create new destination filename } 6FILENAM2 := CONCAT(STRING3,NEWSTRING,STRING4); 6SEARCHFILE := (FILENAM2 <> '')  name was to long } &ELSE (MAKECALL(52,[80,81,86],BADTITLE) { Volume name was to long } "END { SCANINPUT }; " " "FUNCTION OR NODEST; 6TOWHERE := CONCAT(VOLNAME2,':',FILENAM2) 4END 0END ,END (END $END { SEARCHFILE }; $ " "BEGIN { SEARCHDIR } 2BEGIN { state(s) was/were expected } 4WRITE(OUTPUT,', '); 4MESSAGES(ERROR) 2END; 0IF WHERE <> 0 THEN { WheSEARCHDIR(MESSAGE : STRNG; VAR GINX : INTEGER; ENODEST, SCREENCLEAR : BOOLEAN) : BOOLEAN; " "VAR $DONE : BOOLEAN; " $FUNCTre did the error occur } 2IF WHERE < 0 THEN 4WRITE(OUTPUT,' ') 2ELSE 4WRITE(OUTPUT,' ') .END; ,CLEARLION SEARCHFILE(SEARCHTITLE : TID) : BOOLEAN; $ $VAR &LENTITLE,LENSTART,LENSTOP : INTEGER; &TEMP : TID; & $BEGIN { SEARCHFI> :END 6END 4ELSE 2ELSE 4DONE := FALSE { Go on to next file } .END *END (ELSE *BEGIN { Completed search through directory LOCATION < LENGTH(TEMPSTRING) THEN ,DELETE(TEMPSTRING,1,LOCATION+1) *ELSE ,TEMPSTRING := ''; * *LERROR := 1; { There's an $DONE := FALSE; $SEARCHDIR := TRUE; $IF GINX = 0 THEN &BEGIN (IF SCREENCLEAR THEN *CLEARSCREEN; (WRITELN(OUTPUT); (FOUND } ,SEARCHDIR := FALSE; ,DONE := TRUE; ,IF NOT FOUND THEN { No files matched. Write error message }  := FALSE; (IF SCANINPUT(FROMWHERE,[OKDIR],80,0) THEN *BEGIN ,SAVEUNIT := GUNIT; ,SAVEVID := GDIR^[0].DVID { For future call.IF CHECKRSLT(ORD(INOFILE)) THEN; *END &UNTIL DONE $ELSE &BEGIN (FOUND := FALSE; (SEARCHDIR := FALSE &END "END { SEARCHs to this routine } *END (ELSE *BEGIN { Directory wasn't found leave } ,SEARCHDIR := FALSE; ,EXIT(SEARCHDIR) *END &END; DIR }; & & "FUNCTION CHECKFILE(MSG,MESSAGE : SHORTSTRING; DEFAULT : INTEGER; WILD,WHAT : -BOOLEAN; CHECK1 : CHCKS; ERROR1,ER$IF INSERTVOLUME(SAVEUNIT,SAVEVID,TRUE) THEN &REPEAT (GINX := GINX + 1; { Look at the next directory entry } (WHILE (NOT DONEROR2 : ERRANGE) : BOOLEAN; " "VAR $SAVEVID : VID; $TEMPSTRING : LONGSTRING; $CHECK2 : CHCKS; $SAVEUNIT, I, LOCATION : INTE) AND (GINX <= GDIR^[0].DNUMFILES) DO *IF SEARCHFILE(GDIR^[GINX].DTID) THEN ,DONE := TRUE { File has been found that matches }GER; $ $PROCEDURE ERROR (NUMBER : ERRANGE); $ $BEGIN { ERROR } &MESSAGES(NUMBER); &INSTRING := ''; &CLEAR; &EXIT(CHECKFI *ELSE ,GINX := GINX+1; { Look at the next file } (IF DONE THEN { File was found that matches } *BEGIN LE) $END { ERROR }; $ $ $FUNCTION LOOK(CH1,CH2 : CHAR) : BOOLEAN; $ ${ Check for spacial characters CH1 & CH2 in TEMPSTRIN,FILENAM1 := GDIR^[GINX].DTID; ,FROMWHERE := CONCAT(VOLNAME1,':',FILENAM1); { Set source file name } ,FOUND := TRUE; ,IF (MEG. If either one } ${ exists LOOK is set to true and LOCOTION is set to the location of the } ${ character preceding either CHSSAGE <> '') AND QUESTION THEN { Confirm operation } .BEGIN 0IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN 2WRITE(MESSAGE); 0WRITE(O1 or CH2. } $ $BEGIN { LOOK } &LOOK := FALSE; &I := LENGTH(TEMPSTRING); &LOCATION := I; &IF I <> 0 THEN (BEGIN *LOCATIONUTPUT,FILENAM1,' ? '); 0CH := NGETCHAR(FALSE); 0IF CH = SYSCOM^.CRTINFO.ALTMODE THEN { User wants to abort } 2BEGIN 4FOUND : := SCAN(I, = CH1,TEMPSTRING[1]); *IF LOCATION = I THEN ,LOCATION := SCAN(I, = CH2,TEMPSTRING[1]); *LOOK := (LOCATION < I) = FALSE; 4SEARCHDIR := FALSE 2END 0ELSE 2IF CH IN ['Y','P'] THEN { User wants to continue operation } 4IF CH = 'P' THEN { U(END $END { LOOK }; $ $ $PROCEDURE FINDDELIM(SIZE,MESSAGE : INTEGER; VAR STRIING : STRNG); $ $VAR &LERROR : INTEGER; & ser wants to send a form-feed to dest. } 6BEGIN 8CH := CHR(12); 8IF SCANINPUT(TOWHERE,[UNBLKDVOL],0,0) THEN :BEGIN BEGIN @FOUND := FALSE; @SEARCHDIR := FALSE >END STRIING := ''; { LOCATION is way too long } &IF LOCATION <= SIZE THEN (BEGIN *{ Delete proper portion of source string } *IF?  that point & INSTRING is set to the string } &{ following the comma } &IF LOOK(',',',') THEN; &TEMPSTRING := COPY(INSTRING,1NINPUT(FROMWHERE,CHECK1,ERROR1,I) THEN .OK := TRUE; ( (IF NOT OK THEN *ERROR(0) { Wrong disk in drive or bad formatting, abo,LOCATION); &IF LOCATION < LENGTH(INSTRING) THEN (DELETE(INSTRING,1,LOCATION + 1) &ELSE (INSTRING := ''; & &IF NOT QUESTIOrt } &END; $ $BEGIN { SCANNER } &{ For wildcards only. Appropriate state for destination } &IF ERROR2 = 0 THEN (CHECK2 := N THEN { Check if user wishes to verify operations } (QUESTION := SCAN(LENGTH(TEMPSTRING),= '?', [] &ELSE (CHECK2 := [OKDIR]; & &FINDVOL(VOLNAME1); { Find volume name } &IF LOOK('=','?') THEN { Check for wildcards } (BE=TEMPSTRING[1]) < LENGTH(TEMPSTRING); & &{ Check for volume name in TEMPSTRING } &IF LOOK(':',':') THEN (FINDDELIM(VIDLENG,GIN *IF WILD THEN ,WILDCARD := TRUE { Everythings o.k. } *ELSE ,ERROR(40); { Wildcards not allowed } *FINDWILD(STRING1,STRIerror. Illegal character } *IF SCAN(LOCATION,= '$',STRIING[1]) = LOCATION THEN ,IF SCAN(LOCATION,= '=',STRIING[1]) = LOCATION 3,VOLNAME) { Colon found, preceding is volume name } &ELSE (IF TEMPSTRING[1] = '*' THEN { Volume refers to booted device } *BTHEN .IF SCAN(LOCATION,= '?',STRIING[1]) = LOCATION THEN 0LERROR := 0 { Everythings o.k. } (END &ELSE (LERROR := -1; { TherEGIN ,DELETE(TEMPSTRING,1,1); ,VOLNAME := '*' *END (ELSE *IF TEMPSTRING [1] = '#' THEN { Pound sign, TEMPSTRING } ,FINDDe's an error. Strings too long } &IF LERROR <> 0 THEN { Error condition } (BEGIN *IF (NOT SYSCOM^.MISCINFO.SLOWTERM) AND (STRELIM(VIDLENG,3,VOLNAME) { is a volume name } $END; $ $ $PROCEDURE FINDWILD(VAR STR1,STR2 : TID); $ $BEGIN &{ Set scan strIING <> '') THEN ,BEGIN .WRITE(OUTPUT,STRIING); { Write string that's in error } .IF LERROR < 0 THEN ings for wildcards } &FINDDELIM(TIDLENG,2,STR1); &LOCATION := LENGTH(TEMPSTRING); &FINDDELIM(TIDLENG,2,STR2); & &IF (LENGTH0WRITE(OUTPUT,'...too long <'); .CASE MESSAGE OF 01 : MESSAGES(64); 02 : MESSAGES(65); { Write type of string } 03 : MES(STR2) + LENGTH(STR1)) > TIDLENG THEN (BEGIN { Combined scan strings are to long } *WRITE(OUTPUT,'Only ',TIDLENG, 5' char.SAGES(66); .END; .IF LERROR < 0 THEN 0BEGIN 2IF MESSAGE = 3 THEN 4WRITE(OUTPUT,VIDLENG) 2ELSE { Write total allowed in a wildcard search'); *ERROR(0) (END $END; $ $ $PROCEDURE SCANNER; $ &PROCEDURE CHECKSOURCE(I : INTEGER length expected if string } 4WRITE(OUTPUT,TIDLENG); { was too long } 2ERROR(68) 0END .ELSE 0ERROR(67) { Write appro); & &VAR (OK : BOOLEAN; & &BEGIN (OK := FALSE; (IF I > 0 THEN { Check to see if the disk was removed } priate error message } ,END *ELSE ,ERROR(0) (END $END { FINDDELIM }; $ $ $PROCEDURE FINDVOL(VAR VOLNAME : VID); $ $BEG*IF INSERTVOLUME(SAVEUNIT,SAVEVID,TRUE) THEN ,I := -1; { The proper disk is now in place } (IF I <= 0 THEN * *{ Check sourcIN &TEMPSTRING := INSTRING; & &{ Search for a comma in TEMPSTRING. If one exists, TEMPSTRING is set } &{ to the string up toe file for proper format } *IF WILDCARD THEN ,IF SCANINPUT(FROMWHERE,CHECK2,ERROR2,I) THEN .OK := TRUE ,ELSE *ELSE ,IF SCA@ nput, abort } 0ERROR(0); .TOUPPER(INSTRING,1,LENGTH(INSTRING)) { Change to upper-case } ,END *ELSE ,IF INSTRING = '' THEN {pper-case } $IF INSTRING <> '' THEN &SCANNER "END { CHECKFILE }; ! ! "PROCEDURE WHATWORK; " "BEGIN $WITH USERINFO DO & Destination string not req. & not present } .BEGIN 0CHECKFILE := TRUE; 0EXIT(CHECKFILE) .END; *FINDVOL(VOLNAME2); { Find dBEGIN (CLWRITELN(''); (IF GOTSYM OR GOTCODE THEN { There's a code or text file loaded } *BEGIN ,WRITE(OUTPUT,'Workfile is ')estination volume name } *IF TEMPSTRING = '$' THEN ,BEGIN .{ Special case. Destination filename same as source filename } .S; ,IF WORKTID <> '' THEN .WRITE(OUTPUT,WORKTID) ,ELSE .WRITE(OUTPUT,'not named'); ,IF NOT (SYMSAVED AND CODESAVED) THEN .WTRING3 := STRING1; { Copy source scan strings } .STRING4 := STRING2; .FILENAM2 := FILENAM1 { Copy source filename } ,END RITE(OUTPUT,' (not saved)') *END (ELSE *WRITE(OUTPUT,'No workfile'); (CLEARLINE &END "END {WHATWORK} ; ! ! "PROCEDURE C*ELSE ,IF LOOK('=','?') THEN { Check for wildcards } .BEGIN 0IF NOT WILDCARD THEN { Wildcards not allowed, abort } 2ERROR(4LEARWORK; " "{ Used in NEWWORK & GETWORK to clear the workfile } "BEGIN $WITH USERINFO DO &BEGIN (GOTSYM := FALSE; (GOTCO2); 0FINDWILD(STRING3,STRING4) { Set dest. replacement strings } .END ,ELSE .BEGIN 0IF WILDCARD AND (DEFAULT = 0) THEN 2{ DE := FALSE; (WORKTID := ''; (SYMTID := ''; (CODETID := '' &END "END; " " "PROCEDURE NEWWORK(GIVEBLURB: BOOLEAN); " "BSpecial case, wildcard to unblocked volume } 2IF NOT SCANINPUT(CONCAT(VOLNAME2,':'),[UNBLKDVOL],0,0) THEN 4ERROR(41); { Error EGIN { NEWWORK } $CH := 'Y'; $WITH USERINFO DO &BEGIN (IF NOT (SYMSAVED AND CODESAVED) THEN NG2) { Set scan strings in for source file } (END &ELSE (FINDDELIM(SHSTRLENG,1,FILENAM1); { Not a wildcard. Set source filenawildcard to none wildcard } 0FINDDELIM(SHSTRLENG,1,FILENAM2) { Set destination filename } .END; *TOWHERE := CONCAT(VOLNAME2,'me } &FROMWHERE := CONCAT(VOLNAME1,':',FILENAM1); { Set source string } & :',FILENAM2); { Set destination string } *CHECKSOURCE(1) { Is the source disk still in the drive } (END; &CHECKFILE := TRUE &{ Check out the source string for proper formatting } &IF (INSTRING <> '') AND (DEFAULT <= 0) THEN (I := -1 &ELSE (I := 0;$END { SCANNER }; # ! "BEGIN { CHECKFILE } $CLEAR; { Clear most global strings & booleans } $CHECKFILE := FALSE; $IF INSTR &CHECKSOURCE(I); &SAVEUNIT := GUNIT; &SAVEVID := GVID; & &IF DEFAULT <= 0 THEN { Source & Destination strings required or ING = '' THEN { Nothing present to process } &BEGIN (WRITE(OUTPUT,MSG); (IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN *IF WHAT THENallowed } (BEGIN *IF (INSTRING = '') AND (DEFAULT = 0) THEN { Source string required } ,BEGIN .WRITE(OUTPUT,MESSAGE); .CLEA ,WRITE(OUTPUT,' what file') *ELSE ,WRITE(OUTPUT,' what vol'); (WRITE(' ? '); (CLEARLINE; (READLN(INPUT,INSTRING); RLINE; .READLN(INPUT,INSTRING); .EATSPACES(INSTRING); { Remove spaces & non-printable char. } .IF INSTRING = '' THEN { Null i(EATSPACES(INSTRING); { Remove spaces & non-printable characters } &END; $TOUPPER(INSTRING,1,LENGTH(INSTRING)); { Change to uA D; ,IF NOT CODESAVED THEN { Code file exists, remove it } .BEGIN 0GS := '*SYSTEM.WRK.CODE'; 0FOPEN(GFIB,GS,TRUE,NIL); 0FCLOO^SE(GFIB,CPURGE) .END; ,IF NOT (SYMSAVED AND CODESAVED) THEN { Remove *SYSTEM.LST.TEXT } .BEGIN 0GS := '*SYSTEM.LST.TEXT'; 0*FOPEN(GFIB,GS,TRUE,NIL); 0IF GFIB.FISOPEN THEN 2FCLOSE(GFIB,CPURGE) .END; ,GS := CONCAT('*',WORKTID,'.BACK'); ,IF SCANINPUT(GS,[OKFILE],0,0) THEN { A .back file exists } .BEGIN 0WRITE(OUTPUT,'Remove ',WORKTID,'.BACK ? '); 0IF 'Y' = NGETCHAR(TRUE) THEN { Remove .back file } 2BEGIN 4FOPEN(GFIB,GS,TRUE,NIL); 4FCLOSE(GFIB,CPURGE) 2END .END; ,SYMSAVED := TRUE; ,CODESAVED := TRUE; ,IF GIVEBLURB THEN .BEGIN 0WRITE(OUTPUT,'Workfile cleared'); 0CLEARLINE; 0CLEARWORK .END *END &END "END { NEWWORK };  { Copyright (C) 1978 Regents of the University of California. }  { Permission to copy or distribute this software or documen- }  { tation in hard or soft copy granted only by written license }  { obtained from the Institut*BEGIN { Current workfile hasn't been saved } ,WRITE('Throw away current workfile ? '); ,CH := NGETCHAR(FALSE) *END (ELSE *IF GIVEBLURB THEN ,CLWRITELN(''); (IF CH = 'Y' THEN { Everythings o.k. remove old workfile } *BEGIN ,IF NOT SYMSAVED THEN { Text file exists, remove it } .BEGIN 0GS := '*SYSTEM.WRK.TEXT'; 0FOPEN(GFIB,GS,TRUE,NIL); 0FCLOSE(GFIB,CPURGE) .ENB e for Information Systems. }   PROCEDURE GETWORK; " "PROCEDURE LOADFILE; " "BEGIN { LOADFILE } $DONE := TRUE;END; .OK := FALSE ,UNTIL DONE *END "END {GETWORK} ;   "PROCEDURE FINDSAME(DOO : BOOLEAN); " "VAR $LFIB: FIB; "  $WITH USERINFO DO &BEGIN (IF GOTSYM THEN { Load text file } *BEGIN ,SYMTID := CONCAT(WORKTID,'.TEXT'); ,SYMVID := WORKVID"{ Checks for existing files that are endangered by changes, transfers, } "{ makes and sometimes the save command. If a file i; ,WRITE(OUTPUT,'Text ') *END; (IF GOTCODE THEN { Load code file } *BEGIN ,IF GOTSYM THEN .WRITE(OUTPUT,'and '); ,WRITE(Os endangered then } "{ the user will be asked if he/she wishes to remove the endangered file.} "BEGIN $CH := CHR(0); $IF SCAUTPUT,'Code '); ,CODETID := CONCAT(WORKTID,'.CODE'); ,CODEVID := WORKVID *END; (MESSAGES(50); (CLEARLINE &END $END { LOADNINPUT(TOWHERE,[OKFILE],0,0) THEN { The file already exists } &IF DOO OR (FILENAM1 <> GTID) OR (VOLNAME1 <> VOLNAME2) THEN (BEFILE }; " " "BEGIN { GETWORK } $NEWWORK(FALSE); { Clear existing workfile } $WITH USERINFO DO &IF CH = 'Y' THEN { ExistingGIN { A file is endangered } *WRITE(OUTPUT,GVID,':',GTID,' exists...remove it ? '); *CH := NGETCHAR(TRUE); *IF CH = 'Y' THEN  workfile has been cleared } (IF CHECKFILE('Get','',1,FALSE,TRUE,[BADFILE,OKFILE],82,0) THEN *BEGIN { Remove the endangered file } ,BEGIN .FINIT(LFIB,NIL,-1); .FOPEN(LFIB,TOWHERE,TRUE,NIL); .FCLOSE(LFIB,CPURGE) ,END (END ,CLEARWORK; { Clear workfile names } ,WORKVID := GVID; ,WORKTID := GTID; ,X := LENGTH(WORKTID); ,OK := X <= TIDLENG-5; { Ca"END; " " "PROCEDURE CHANGER; $ "VAR $LERROR: BOOLEAN; " "BEGIN { CHANGER } $REPEAT &I := 0; &OK := FALSE; &DONE := n a '.TEXT' or '.CODE' suffix be added } ,REPEAT .DONE := NOT OK; .IF DONE AND (X > 5) THEN { Suffix may already exist } 0IFTRUE; &IF CHECKFILE('Change','Change to what ? ',0,TRUE,TRUE,[OKFILE,OKDIR], B84,80) THEN (IF WILDCARD THEN *BEGIN ,OK := T (COPY(WORKTID,X - 4,5) = '.TEXT') OR 6(COPY(WORKTID,X - 4,5) = '.CODE') THEN 2DELETE(WORKTID,X - 4,5) { Remove '.TEXT' or '.CRUE; ,DONE := FALSE *END (ELSE *IF (FILENAM1 = '') AND (FILENAM2 <> '') THEN ODE' suffix } 0ELSE 2BEGIN 4MESSAGES(51); { File wasn't found } 4CLEARWORK; 2END; .IF (LENGTH(WORKTID) <= TIDLENG-5) AND ,MESSAGES(60) { Illegal change, volume name to file name } *ELSE ,IF (FILENAM1 <> '') AND (FILENAM2 = '') THEN .MESSAGES(61)(WORKTID <> '') THEN 0BEGIN 2GOTSYM := SCANINPUT(CONCAT(WORKVID,':',WORKTID,'.TEXT'), 4[OKFILE],0,0); { Check for text file } { Illegal change, file name to volume name } ,ELSE .OK := TRUE; { Everythings o.k. } &IF OK THEN (REPEAT *IF WILDCARD THEN 2GOTCODE := SCANINPUT(CONCAT(WORKVID,':',WORKTID,'.CODE'), 5[OKFILE],0,0); { Check for code file } 2IF GOTSYM OR GOTCODE THE ,BEGIN .LERROR := FALSE; .OK := SEARCHDIR('Change ',I,FALSE,TRUE); { Get source file } .DONE := NOT OK ,END; *IF FILENAM2N { Code or text file found } 4LOADFILE 2ELSE 4IF NOT OK THEN 6BEGIN 8CLEARWORK; 8MESSAGES(51) { No file found } 6END 0 <> '' THEN { Change, volume names must be the same } ,BEGIN .VOLNAME2 := VOLNAME1; .TOWHERE := CONCAT(VOLNAME1,':',FILENAM2)C 6ELSE 8LERROR := FALSE 2END 0ELSE 2{ Foramatting of destination string was incorrect } 2IF SCANINPUT(TOWHERE,[OKDIR],84,1) R(SAVEUNIT,GDIR) 6END 2END .END *END (ELSE *BEGIN ,FOPEN(GFIB,FROMWHERE,TRUE,NIL); ,IF CHECKRSLT(IORESULT) THEN .BEGIN THEN { Bad state } 2 BEGIN 6HOMECURSOR; 6WRITELN(OUTPUT); 6MESSAGES(72) { Volume on-line } 4END; 0FCLOSE(GFIB,CPURGE); 0IF CHECKRSLT(IORESULT) THEN 2CLWRITELN(CONCAT(GVID,':',GTID,' removed')) 0ELSE 2INSTRING := '' .END.FCLOSE(GFIB,CNORMAL); .LERROR := NOT CHECKRSLT(IORESULT) ,END (UNTIL DONE OR LERROR; (IF LERROR THEN INSTRING := '' $UNTI *END; "1: $UNTIL INSTRING = '' "END {REMOVER} ; " " "PROCEDURE TRANSFER; "LABEL 1;  "VAR $NBLOCKS, SAVEUNIT : INTEG ,END; *IF OK THEN ,BEGIN .LERROR := TRUE; .FOPEN(GFIB,FROMWHERE,TRUE,NIL); { Open source file } .IF CHECKRSLT(IORESULT) TL INSTRING = '' "END {CHANGER} ;   "PROCEDURE REMOVER; " "LABEL 1; " "VAR $CHUNIT : VID; $TEMP : PACKED ARRAY [1..MAHEN { I/O result is o.k. } 0IF SCANINPUT(TOWHERE,[NOVOL, BADFILE, OKFILE],0,0) THEN 2BEGIN { Destination formatting is o.k. } XDIR] OF BOOLEAN; $DUMMY : ^INTEGER; " "BEGIN { REMOVER } $REPEAT &IF CHECKFILE('Remove','',1,TRUE,TRUE,[OKFILE],82,80) THE4FINDSAME(FALSE); { Check for endangered files } 4WITH GFIB DO 4IF CH <> SYSCOM^.CRTINFO.ALTMODE THEN { Keep going } 6IF (CHN (IF WILDCARD THEN *BEGIN ,FILLCHAR(TEMP,SIZEOF(TEMP),CHR(0)); ,X := 0; ,I := 0; ,WHILE SEARCHDIR('Remove ',I,TRUE,TRUE)  = CHR(0)) OR (CH = 'Y') THEN 8{ Go ahead with operation } 8IF FILENAM2 = '' THEN { Changing volume name } :BEGIN DO { Get filename } .BEGIN 0IF NOT QUESTION THEN 2BEGIN 4WRITE(OUTPUT,GVID,':',GDIR^[I].DTID); 4IF NOT SYSCOM^.MISCINFO.SLOBEGIN ?CLWRITEIGHT - 1)) = 0 THEN 6IF SPACEWAIT(FALSE) THEN 2 GOTO 1 6ELSE 8CLEARSCREEN 2END; 0TEMP [I] := TRUE { Mark file in TEMPLN(CONCAT(FVID,': changed to ',GVID,':')); @UNITABLE[FUNIT].UVID := GVID; @IF (SYVID = FVID) AND K(SYSCOM^.SYSUNIT = FUNIT)  array } .END; ,IF FOUND THEN { Confirm removal of files } .BEGIN 0WRITE(OUTPUT,'Update directory ? ');  THEN BSYVID := GVID; @FVID := GVID >END :END 8ELSE :BEGIN { Changing file name } BEGIN @WRITE(OUTPUT,FVID,':',FHEADER.DTID); @IF WILDCARD THEN BWRITE(OUTPUT,' ':19 - LENGa new directory } 4IF INSERTVOLUME(SAVEUNIT,SAVEVID,TRUE) THEN 6BEGIN 8WHILE I - X <= GDIR^ [0].DNUMFILES DO :BEGIN END; BEGIN @DELENTRY(I - X,GDIR); @X := X + 1 >END;  'Y' THEN 8(CH = 'Y') THEN { Everything is o.k. } 4BEGIN 6FINIT(LFIB,NIL,-1); 6FOPEN(LFIB,TOWHERE,FALSE,NIL); { Open dest. file } 6IF NCH := SYSCOM^.CRTINFO.ALTMODE 4END ,END (END &ELSE (IF NOT SCANINPUT(TOWHERE,[],85,1) THEN *CH := SYSCOM^.CRTINFO.ALTMODE;OT CHECKRSLT(IORESULT) THEN { I/O result is no good } 8BEGIN :FCLOSE(GFIB,CNORMAL); :EXIT(TRANSFER) 8END; 6IF LFIB.FISBLKD  &IF CH = CHR(0) THEN (BEGIN *CH := SYSCOM^.CRTINFO.ALTMODE; *IF SCANINPUT(TOWHERE,[BADDIR],0,1) THEN { No directory on destTHEN { Destination file is blocked } 8BEGIN :IF (LFIB.FHEADER.DTID = '') AND @(UNITABLE[LFIB.FUNIT].UVID <> '') THEN ER; $FIRSTCALL, LERROR : BOOLEAN; $LFIB: FIB; $TEMP : VID; " $PROCEDURE WHERETO; $ $VAR &X : INTEGER; $ &PROCEDURE CHA. disk } ,IF GVID <> '' THEN .IF GVID [1] = '#' THEN { Binary transfer, don't need directory } 0CH := CHR(0); *IF CH = SYSCONGEDISK; & &BEGIN { CHANGEDISK } (CLEARSCREEN; (IF X = 0 THEN { Specific destination volume needed } M^.CRTINFO.ALTMODE THEN ,BEGIN .FINDSAME(FALSE); { Check for endangered files } .IF CH = CHR(0) THEN { Go ahead with transfer*WRITE(OUTPUT,'Put in ',TEMP,':') (ELSE *{ Unspecific destination volume expected } *WRITE(OUTPUT,'Put destination disk in u } 0IF SCANINPUT(TOWHERE,[BADFILE,OKDIR,UNBLKDVOL,OKFILE],85,1) THEN 2IF (X = 1) OR (X = 2) THEN 4CLEARSCREEN 2ELSE 0ELSE nit #',GUNIT); (WRITELN(OUTPUT); (IF SPACEWAIT(TRUE) THEN { Wait for destination disk to be inserted } *CH := SYSCOM^.CRTIN2CH := SYSCOM^.CRTINFO.ALTMODE { Abort transfer } ,END (END $END { WHERETO }; " " "BEGIN { TRANSFER } $REPEAT &FIRSTCALLFO.ALTMODE (ELSE *CH := CHR(0) &END { CHANGEDISK }; $ $BEGIN { WHERETO } &IF SCANTITLE(TOWHERE,TEMP,GTID,X,GKIND) THEN (B := TRUE; &I := 0; &OK := FALSE; &DONE := TRUE; &IF (FROMWHERE <> '') THEN { Case entering from SAVEWORK } EGIN { General formatting of destination string is o.k. } *CH := TEMP [1]; *X := VOLSEARCH(TEMP,TRUE,GDIR); { Is the dest. vol(OK := SCANINPUT(FROMWHERE,[OKFILE],82,-1) &ELSE (IF CHECKFILE('Transfer','To where ? ',0,TRUE,TRUE, ,[BADDIR,OKFILE,OKDIR,Uume on-line } *IF CH = '#' THEN { Unspecific destination } ,IF (X = SAVEUNIT) AND UNITABLE [X].UISBLKD THEN .CHANGEDISK { MuNBLKDVOL],85,86) THEN *OK := TRUE; &SAVEUNIT := GUNIT; { Unit source volume is from } &IF OK THEN (REPEAT *IF WILDCARD THENE transfer } 6WHILE NBLOCKS > 0 DO { Still more to transfer } 8BEGIN :X := FBLOCKIO(LFIB,GBUF^,NBLOCKS,-1,FALSE); :IF (IORESULWORK(VAR SECONDCALL : BOOLEAN) : BOOLEAN; " "VAR $GETNEWTID: BOOLEAN; ( $ $PROCEDURE FETCHTITLE(MSG : SHORTSTRING); $ $BT = 0) AND (X = NBLOCKS) THEN NBLOCKS := 0 { Last transfer } BEGIN @IF OK THEN { Single disk traEGIN { FETCHTITLE } &IF NOT CHECKFILE(CONCAT('Save ',MSG,'as'),'',1,FALSE,TRUE, 1[NOVOL,BADDIR,BADFILE,OKDIR,UNBLKDVOL,OKFILE]nsfer } BIF NOT INSERTVOLUME(0,GFIB.FVID,FALSE) THEN DGOTO 1; @NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS, V-1,TRUE); @IF NOT ,85,0) THEN (EXIT(SAVEWORK) $END { FETCHTITLE }; " $ $PROCEDURE SPECIALSAVE; $ $ &FUNCTION MAKECALL(TYPEFILE : SHORTSTRICHECKRSLT(IORESULT) THEN { Bad I/O rslt } "1: BEGIN NBLOCKS := 0; DFCLOSE(LFIB,CPURGE) BEND NG) : BOOLEAN; & &VAR (STR : STRING[4]; & &BEGIN { MAKECALL } (MAKECALL := FALSE; (STR := TYPEFILE; (TOUPPER(TYPEFILE,1,>END :ELSE { Bad I/O operation } NBLOCKS := 0; >IF CHECKRSLT(IORESULT) THEN { No room on volume } @MESSAGES(73); 4); { Change to upper-case } (IF SAVEGTID = '' THEN { Don't have a title yet } *GTID := CONCAT('the ',STR,' file') (ELSE *GT>FCLOSE(LFIB,CPURGE)  0) THEN { Single disk transfer } GOTO 1 8END; 6IF LFIB.FISOPEN THEN { Transfer was succesful } 8BEGIN :{ Initialize FHEADER } :WITH LFIB,GFIB.FHEADER DOSE); (IF CH = SYSCOM^.CRTINFO.ALTMODE THEN { Abort SAVEWORK } *EXIT(SAVEWORK) (ELSE  FHEADER.DLASTBYTE := DLASTBYTE; >FHEADER.DFKIND := DFKIND; >FHEADER.DACCESS := DACCESS; >IF (DACCESS.MONTH = 0) AN*IF CH = 'Y' THEN { User wants to save file } ,BEGIN .MAKECALL := TRUE; .IF SAVEGTID = '' THEN { Still don't have a title } D A(THEDATE.MONTH > 0) THEN @FHEADER.DACCESS := THEDATE WRITE(CONCAT('Possibly destroy directory of ', VLFIB.FVID,': ? ')); >IF NGETCHAR(TRUE) <> 'Y' THne it } >BEGIN @LERROR := FALSE; @WRITE(OUTPUT,GFIB.FVID,':',GFIB.FHEADER.DTID); @IF WILDCARD THEN WRITE(OUTPUT, E' ':1EN @BEGIN BFCLOSE(LFIB,CNORMAL); BNBLOCKS := 0 @END END 8END 4END 2ELE) THEN :BEGIN { Disk to char. device don't transfer heading }  SYSCOM^.CRTINFO.ALTMODE THEN 6LERROR := FALSE { Abort transfer } 0END; .FCLOSE(GFIB,CNORMAL) ,END GBUF^,NBLOCKS*FBLKSIZE) :END; 6OK := (LFIB.FVID <> GFIB.FVID) AND { If OK then single } <(LFIB.FUNIT = GFIB.FUNIT); { disk (UNTIL DONE OR LERROR; &CLEAR; &IF LERROR THEN INSTRING := '' $UNTIL INSTRING = '' "END { TRANSFER }; " " "FUNCTION SAVEF NAM2); { Set dest. string } .FILENAM1 := CONCAT('SYSTEM.WRK.',TYPEFILE); { Set source file } .FROMWHERE := CONCAT('*',FILENAM1,IF GOTSYM OR GOTCODE THEN .MESSAGES(75) { Workfile already saved } ,ELSE .MESSAGES(76); { No workfile to save } ,EXIT) { Set source string } ,END &END { MAKECALL }; , $BEGIN { SPECIALSAVE } &IF SECONDCALL THEN (CLWRITELN('') &ELSE (CLEAR(SAVEWORK) *END; (OK := FALSE; (IF WORKVID <> SYVID THEN WORKTID := ''; (GETNEWTID := WORKTID = ''; (IF NOT GETNEWTID THEN SCREEN; &INSTRING := ''; &OK := FALSE; &IF NOT (SYMSAVED OR SECONDCALL) THEN { Firstime and textfile exists } (OK := MAKECAL{ Already have a filename } *BEGIN ,WRITE(OUTPUT,'Save as ',WORKTID,' ? '); ,GETNEWTID := NGETCHAR(FALSE) <> 'Y' *END; (IF L('text'); &IF NOT (OK OR CODESAVED) THEN { Try code file, it exists } (BEGIN *OK := MAKECALL('code'); *SECONDCALL := TRUE GETNEWTID THEN { Need a new filename } *BEGIN ,FETCHTITLE(''); ,IF LENGTH(GTID) > TIDLENG-5 THEN { Filename is too long } .B(END; &SAVEWORK := OK; &EXIT(SAVEWORK) $END { SPECIALSAVE }; . " $PROCEDURE SAVEIT(WHATFILE : STRNG); $ EGIN 0MESSAGES(52); 0EXIT(SAVEWORK) .END; ,OK := TRUE; ,IF (GVID2 = SYVID) THEN .IF (GTID <> '') THEN { Standard save to s$BEGIN { SAVEIT } &WITH USERINFO DO (BEGIN *FROMWHERE := CONCAT('*SYSTEM.WRK.',WHATFILE); { Set source string } *FOPEN(GFIBystem disk } 0BEGIN 2OK := FALSE; 2WORKVID := GVID; 2WORKTID := GTID 0END *END; (IF OK THEN *BEGIN ,SAVEGVID := GVID2; ,FROMWHERE,TRUE,NIL); { Open source file } *IF GFIB.FISOPEN THEN *WITH GFIB.FHEADER DO ,BEGIN .DACCESS.YEAR := 100; .IF WHA,SAVEGTID := GTID; ,SPECIALSAVE *END (ELSE *BEGIN { Standard save routine } ,IF NOT SYMSAVED THEN { Text file needs to be TFILE = 'TEXT' THEN { Change text file to its new name } 0BEGIN 2SYMTID := CONCAT(WORKTID,'.TEXT'); 2DTID := SYMTID; 2SYMSAVsaved } .BEGIN 0SAVEIT('TEXT'); 0IF SYMSAVED AND CODESAVED THEN 2BEGIN { No code file to be saved, Remove old one } ED := TRUE 0END .ELSE 0BEGIN { Change code file to its new name } 2CODETID := CONCAT(WORKTID,'.CODE'); 2DTID := CODETID; 24GS := CONCAT('*',WORKTID,'.CODE'); 4FOPEN(GFIB,GS,TRUE,NIL); 4IF GFIB.FISOPEN THEN 6WRITE(OUTPUT,'Old code removed, '); 4FCODESAVED := TRUE 0END; .FCLOSE(GFIB,CNORMAL) ,END *ELSE ,BEGIN { I/O error } .IF WHATFILE = 'TEXT' THEN 0BEGIN 2GOTSYM CLOSE(GFIB,CPURGE) 2END; 0IF SYMSAVED THEN 2WRITE(OUTPUT,'Text file saved ') { Everything went o.k. } 0ELSE 2SYMSAVED := T:= FALSE; 2MESSAGES(90) 0END .ELSE 0BEGIN 2GOTCODE := FALSE; 2MESSAGES(91) 0END ,END (END $END { SAVEIT }; $ $ "BEGRUE; { Lost text file } 0IF NOT CODESAVED THEN 2WRITE(OUTPUT,'& ') .END; ,IF NOT CODESAVED THEN { Code file needs to beIN { SAVEWORK } $SAVEWORK := FALSE; $GVID2 := SYVID; $IF SECONDCALL THEN { Returning from transfer } &SPECIALSAVE; $WITH US saved } .BEGIN 0SAVEIT('CODE'); 0IF CODESAVED THEN 2WRITE(OUTPUT,'Code file saved') { Everything went o.k. } 0ELSE 2CODESon filename } 0END .ELSE 0FILENAM2 := CONCAT(SAVEGTID,'.',TYPEFILE); { Set dest. file } .TOWHERE := CONCAT(SAVEGVID,':',FILEERINFO DO &BEGIN (IF SYMSAVED AND CODESAVED THEN { Error nothing to save } *BEGIN ,CLWRITELN(''); G  $VAR &OUT : TEXT; &SAVEVID : VID; &LINE,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER; & &PROCEDURE WRITELINE(FIRSTCALL: BOO^OLEAN); &BEGIN (IF FIRSTCALL OR (LINE = SYSCOM^.CRTINFO.HEIGHT) THEN *BEGIN { May need to wait or write out heading } ,IF OKAVED := TRUE { Lost code file } .END; ,CLEARLINE *END &END "END {SAVEWORK} ;  " "PROCEDURE MAKEFILE; " "BEGIN {** MAKEFILE } $REPEAT &DONE := TRUE; &IF CHECKFILE('Make','',1,FALSE,TRUE,[BADFILE,OKFILE],82,0) THEN (BEGIN *TOWHERE := FROMWHERE; *FINDSAME(TRUE); { Check for endangered files } *IF (CH <> CHR(0)) AND (CH <> 'Y') THEN { Somethimgs wrong } ,IF CH = SYSCOM^.CRTINFO.ALTMODE THEN { Abort make } ,ELSE .DONE := FALSE { Don't make this file } *ELSE ,BEGIN { Everything is o.k. } .FOPEN(GFIB,FROMWHERE,FALSE,NIL); { Open file } .IF CHECKRSLT(IORESULT) THEN { I/O result is good } 0BEGIN 2WITH GFIB DO 4FMAXBLK := FHEADER.DLASTBLK-FHEADER.DFIRSTBLK; 2FCLOSE(GFIB,CLOCK); 2IF CHECKRSLT(IORESULT) THEN { I/O result is o.k. } 4BEGIN 6CLWRITELN(CONCAT(GVID,':',GTID,' made')); 6DONE := FALSE 4END 0END ,END (END $UNTIL DONE OR (INSTRING = '') "END {MAKEFILE} ;  { Permission to copy or distribute this software or documen- }  { tation in hard or soft copy granted only by written license }  { obtained from the Institute for Information Systems. }   $PROCEDURE PREFIXER; $BEGIN { PREFIXER } &IF CHECKFILE('Prefix titles by','',1,FALSE,FALSE,[NOVOL,BADDIR,OKDIR, >UNBLKDVOL],86,0) THEN (BEGIN *DKVID := GVID; *WRITE(OUTPUT,'Prefix is ',DKVID,':'); *CLEARLINE (END $END {PREFIXER} ; $ $ $PROCEDURE LISTDIR(DETAIL: BOOLEAN);H tween these files } *BEGIN ,FREEBLKS := FREEBLKS+FREEAREA; { Running totla of free blocks } ,IF DETAIL THEN { Extended listinWHERE,[BADFILE,OKFILE,UNBLKDVOL],83,1) THEN ,BEGIN { Not listing to default volume } .DONE := UNITABLE [GUNIT].UISBLKD; .OK :g } .BEGIN 0WRITE(OUT,'< UNUSED > ', :FREEAREA:4,' ':11,FIRSTOPEN:6); 0WRITELINE(FALSE) ,END *END; = FALSE; .GS := TOWHERE ,END *ELSE ,GS := ''; { Bad destination name, abort LISTDIR } (IF GS <> '' THEN *BEGIN ,REWRITE(O$END {FREECHECK} ;   $PROCEDURE SHOWDIR; $ $BEGIN &IF DONE AND (NOT QUESTION) THEN { Listing to a file } (BEGIN *IF XUT,GS); { Change output to appropriate device } ,IF NOT CHECKRSLT(IORESULT) THEN { Bad I/O result } .GS := '' *END; (IF GS = = 0 THEN { First call to procedure } ,BEGIN .WRITE(OUTPUT,'Writing'); .CLEARLINE ,END *ELSE ,WRITE(OUTPUT,'.') { Show pro '' THEN *EXIT(LISTDIR); (FREEBLKS := 0; (USEDBLKS := 0; (LARGEST := 0; (LINE := 0; (IF FILENAM1 = '' THEN *WRITELINE(TRUgress of listing } (END; &X := X + 1; &WITH GDIR^[I] DO (BEGIN *FREECHECK(GDIR^[I-1].DLASTBLK,DFIRSTBLK); { Check for free E); (I := 0; (IF SCANINPUT(FROMWHERE,[OKDIR,OKFILE],84,-1) THEN *IF WILDCARD THEN  THEN .BEGIN { Listing to console } 0IF NOT (FIRSTCALL OR QUESTION) THEN 2BEGIN { Must wait before continuing } 4HOMECURSOR;blocks } *USEDAREA := DLASTBLK-DFIRSTBLK; { Area used } *USEDBLKS := USEDBLKS+USEDAREA; { Running total of used blocks } *WR 4CLEARLINE; 4IF SPACEWAIT(FALSE) THEN EXIT(LISTDIR); 2END; 0CLEARSCREEN; 0LINE := 2; 0WRITELN(OUT); ITE(OUT,DTID,' ':TIDLENG-LENGTH(DTID)+1,USEDAREA:4); *IF DACCESS.MONTH > 0 THEN ,WRITE(OUT,' ':2,DACCESS.DAY:2,'-', 4MONTHS[D0WRITE(OUT,SAVEVID,':') .END ,ELSE .IF FIRSTCALL THEN 0BEGIN { Not listing to console } 2IF NOT DONE THEN { Listing to unbACCESS.MONTH],'-',DACCESS.YEAR:2); *IF DETAIL THEN { Extended listing } ,BEGIN .IF DACCESS.MONTH = 0 THEN WRITE(OUT,' ':11); locked device } 4CLEARSCREEN; 2HOMECURSOR; 2WRITELN(OUT); 2WRITE(OUT,SAVEVID,':') 0END; ,IF FIRSTCALL AND DONE THEN { Corr.WRITE(OUT,DFIRSTBLK:6,DLASTBYTE:6); .GS := 'ILLEGAL'; .CASE DFKIND OF 0XDSKFILE: GS := 'Bad disk'; 0CODEFILE: GS := 'Codefects cursor positioning } .BEGIN 0HOMECURSOR; 0IF NOT WILDCARD THEN 2CLWRITELN('') .END *END; (IF NOT (OK AND FIRSTCALL Aile'; 0TEXTFILE: GS := 'Textfile'; 0INFOFILE: GS := 'Infofile'; 0DATAFILE: GS := 'Datafile'; 0GRAFFILE: GS := 'Graffile'; ND WILDCARD) THEN { For cursor positioning } *WRITELN(OUT); (LINE := LINE+1 &END {WRITELINE} ; " &PROCEDURE FREECHECK(FIRST0FOTOFILE: GS := 'Fotofile' .END; .WRITE(OUT,' ':2,GS) ,END; *WRITELINE(FALSE) (END; $END; " $ "BEGIN {LISTDIR} $DONEOPEN,NEXTUSED: INTEGER); ( &VAR (FREEAREA: INTEGER; & &BEGIN (FREEAREA := NEXTUSED-FIRSTOPEN; { Finds space bet. last & ne := FALSE; $X := 0; $OK := TRUE; $IF CHECKFILE('Dir listing of','',-1,TRUE,FALSE,[OKDIR,OKFILE],84,84) THEN &BEGIN (FOUND :xt file } (IF FREEAREA > LARGEST THEN LARGEST := FREEAREA; { Is this the biggest } (IF FREEAREA > 0 THEN { There is a space be= TRUE; (SAVEVID := GVID; (IF TOWHERE = '' THEN { Default destination is console } *GS := 'CONSOLE:' (ELSE *IF SCANINPUT(TOI ',FREEBLKS,' unused'); .IF DETAIL THEN 0WRITE(OUT,', ',LARGEST,' in largest area'); .IF DONE THEN 0BEGIN 0WRITELN(OUTPUT); $LASTBLK := 6; { Leave room for directory and bootstrap } $IF CHECKFILE('Zero dir of','',1,FALSE,FALSE,[OKDIR,BADDIR],80,0) TH0WRITELN(OUT) .END ,END; ,IF CHECKRSLT(IORESULT) THEN .BEGIN 0OK := TRUE; 0CLOSE(OUT,LOCK) .END *END; (IF NOT OK THEN EN &BEGIN (UNITCLEAR(GUNIT); (IF CHECKRSLT(IORESULT) THEN { Unit is on-line } *BEGIN ,IF GDIR <> NIL THEN { There's a direc*CLOSE(OUT,NORMAL) &END "END {LISTDIR} ;   "PROCEDURE LISTVOLS; " "BEGIN { LISTVOLS } tory on this volume } .BEGIN 0WRITE(OUTPUT,'Destroy ',GVID,': ? '); 0IF NGETCHAR(TRUE) <> 'Y' THEN 2GOTO 1 .END; ,WRITE(OU$GUNIT := VOLSEARCH(GVID,TRUE,GDIR); { Update unitable } $CLEARSCREEN; $WRITELN(OUTPUT); $WRITELN(OUTPUT,'Volumes on-line:')TPUT,'Duplicate dir ? '); ,CH := NGETCHAR(TRUE); ,IF CH = 'Y' THEN { Leave room for a duplicate directory } .LASTBLK := 10 ,; $FOR GUNIT := 1 TO MAXUNIT DO %WITH UNITABLE[GUNIT] DO &IF UVID <> '' THEN { Volume is on-line } (BEGIN *WRITE(OUTPUT,GUNELSE .IF CH = SYSCOM^.CRTINFO.ALTMODE THEN { Abort ZEROVOLUME } 0GOTO 1; ,CH := 'N'; ,IF GDIR <> NIL THEN { There's a directIT:3); *IF UVID = SYVID THEN ,WRITE(OUTPUT,' * ') { This volume is the booted device } *ELSE ,IF UISBLKD THEN .WRITE(OUTPUTory on this volume } .IF (GDIR^[0].DEOVBLK >=LASTBLK) AND A(GDIR^[0].DEOVBLK <= 10000) THEN ,' # ') { Blocked unit } ,ELSE .WRITE(OUTPUT,' '); { Unblocked unit } *WRITELN(OUTPUT,UVID,':') (END; $WRITELN(OUTPUT,'Pr0BEGIN { The number of blocks present may be valid } 2WRITE(OUTPUT,GDIR^[0].DEOVBLK,' blocks ? '); 2CH := NGETCHAefix is - ',DKVID,':') { Prefix } "END {LISTVOLS} ;  "PROCEDURE BADBLOCKS; " "VAR $A: PACKED ARRAY [0..FBLKSIZE] OF CHAR;R(TRUE); 2IF CH = SYSCOM^.CRTINFO.ALTMODE THEN 4GOTO 1 { Abort ZEROVOLUME } 2ELSE 4IF CH = 'Y' THEN 8NBLOCKS := GDIR^[0].DE,WHILE SEARCHDIR('List ',I,TRUE,FALSE) DO { Get file to be listed } .SHOWDIR *ELSE ,FOR I := 1 TO GDIR^[0].DNUMFILES DO .BE " "BEGIN { BADBLOCKS } $CLEARSCREEN; $IF CHECKFILE('Bad blocks scan of','',1,FALSE,FALSE, :[OKDIR,BADDIR],80,0) THEN &BEGGIN 0IF FILENAM1 = '' THEN { List all the files } 2SHOWDIR 0ELSE 2IF GDIR^[I].DTID = FILENAM1 THEN { List only this file } IN (UNITCLEAR(GUNIT); (IF CHECKRSLT(IORESULT) THEN { Unit is on-line } *BEGIN ,X := 0; ,FOR I := 0 TO UNITABLE[GUNIT].UEOVB4SHOWDIR .END; (OK := FALSE; (IF FOUND THEN *BEGIN ,IF (FILENAM1 = '') OR WILDCARD THEN ,BEGIN .FREECHECK(GDIR^[I-1].DLASLK-1 DO .BEGIN 0UNITREAD(GUNIT,A,FBLKSIZE,I); 0IF SYSCOM^.IORSLT <> INOERROR THEN 2BEGIN 4X := X+1; TBLK,GDIR^[0].DEOVBLK); .WRITE(OUT,X,'/',GDIR^[0].DNUMFILES,' files'); .IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN 0WRITE(OUT,''); .WRITE(OUT,', ',USEDBLKS); .IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN 0WRITE(OUT,' blocks'); .WRITE(OUT,' used, EDURE ZEROVOLUME; $ "LABEL 1; $ "VAR $NBLOCKS,LASTBLK: INTEGER; $LDE: DIRENTRY; " "BEGIN { ZEROVOLUME } $CLEARSCREEN; J s, abort ZEROVOLUME } 4WRITE(OUTPUT,'Bad # blocks'); 4GOTO 1 2END .END; ,WRITE(OUTPUT,'New vol name ? '); ,READLN(INPUT,GSUNTIL (GS = '') OR (GS[1] IN DELIMS) OR (I > 31); (IF (I > 0) AND (I < 32) THEN *THEDATE.DAY := I &END; $IF FINDDELIM AND (L); ,EATSPACES(GS); ,IF GS = '' THEN GOTO 1; ,IF GS[LENGTH(GS)] = ':' THEN .DELETE(GS,LENGTH(GS),1); ,IF (GS = '') OR (LENGTENGTH(GS) > 2) THEN &BEGIN (GVID := ' '; (TOUPPER(GS,1,1); { Change to upper-case } (FOR I := 2 TO 3 DO *IF ( GS[I] >= 'AH(GS) > VIDLENG) THEN .BEGIN MESSAGES(54); GOTO 1 END; ,TOUPPER(GS,1,LENGTH(GS)); { Change to upper-case } ,WITH LDE DO .BEG' ) AND ( GS[I] <= 'Z' ) THEN -GS[I] := CHR( ORD( GS[I] )-ORD( 'A' )+ORD( 'a' )); (MOVELEFT(GS[1],GVID[1],3); (FOR I := 1 TO IN 0DFIRSTBLK := 0; 0DLASTBLK := LASTBLK; 0DFKIND := UNTYPEDFILE; 0DVID := GS; 0DEOVBLK := NBLOCKS; 0DLOADTIME := 0; 12 DO *IF MONTHS[I] = GVID THEN ,THEDATE.MONTH := I &END; $IF FINDDELIM THEN &BEGIN (OK := FALSE; (I := 0; (REPEAT *IF 0DLASTBOOT := THEDATE; 0DNUMFILES := 0; 0WRITE(OUTPUT,DVID,': correct ? '); 0IF NGETCHAR(TRUE) = 'Y' THEN 2BEGIN 4UNITWRITGS[1] IN DIGITS THEN ,BEGIN .I := I*10+ORD(GS[1])-ORD('0'); .OK := I <= 99 ,END; *DELETE(GS,1,1) (UNTIL (GS = ''); (IF OKE(GUNIT,LDE,SIZEOF(LDE),DIRBLK); 4IF CHECKRSLT(IORESULT) THEN { I/O result is good } 6WRITE(OUTPUT,DVID,': zeroed') 2END .EN THEN *THEDATE.YEAR := I &END; $GUNIT := VOLSEARCH(SYVID,FALSE,GDIR); $IF GUNIT = SYSCOM^.SYSUNIT THEN &BEGIN (GDIR^[0].DLD *END &END;  1: "END {ZEROVOLUME} ;  "PROCEDURE DATESET; $VAR &DELIMS: SET OF '-'..'/';  $FUNCTION FINDDELIM : BOOLASTBOOT := THEDATE; (WRITEDIR(GUNIT,GDIR) &END; $WITH THEDATE DO EAN; $ $BEGIN { FINDDELIM } &OK := TRUE; &WHILE OK AND (GS <> '') DO (BEGIN *IF GS[1] IN DELIMS THEN ,OK := FALSE; *DELE&WRITE(OUTPUT,'New date is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2) "END { DATESET } ; " " "PROCEDURE XBLOCKS; " "LABEL 1; TE(GS,1,1) (END; &FINDDELIM := GS <> '' $END { FINDDELIM }; ( " "BEGIN {DATESET} $CLEARSCREEN; $DELIMS := ['-','/']; $P" "VAR $CONFLICT : BOOLEAN; $FIRSTBLK,LASTBLK,MAXBLK,MINBLK : INTEGER; $LDE : DIRENTRY; $A,B : ARRAY [0..255] OF INTEGER; L := 'Date set: <1..31>--<00..99> OR '; $PROMPT; $WRITELN(OUTPUT); $WITH THEDATE DO &IF MONTH = 0 THEN (W" "BEGIN { XBLOCKS } $CLEARSCREEN; $IF CHECKFILE('Examine blocks on','',1,FALSE,FALSE,[OKDIR],80,0) THEN &BEGIN (CONFLICT :RITELN(OUTPUT,'No current date') &ELSE (WRITELN(OUTPUT,'Today is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2); $WRITE(OUTPUT,'New da= FALSE; (MINBLK := 32767; (MAXBLK := -1; (FIRSTBLK := 0; (LASTBLK := 0; (WRITE(OUTPUT,'Block number-range ? '); (READ(INPOVBLK { Keep the present number } 0END; ,IF CH <> 'Y' THEN .BEGIN { Need to get a new number of blocks on disk } 0WRITE(OUTPte ? '); $READLN(INPUT,GS); $EATSPACES(GS); { Remove spaces and non-printable characters } $IF GS <> '' THEN &BEGIN UT,'# of blocks ? '); 0NBLOCKS := 0; 0READLN(INPUT,NBLOCKS); 0IF NBLOCKS < LASTBLK THEN 2BEGIN { Not a valid number of block(I := 0; (REPEAT *IF GS[1] IN DIGITS THEN ,I := I*10+ORD(GS[1])-ORD('0'); *IF NOT(GS[1] IN DELIMS) THEN ,DELETE(GS,1,1) (K (WRITE(OUTPUT,'Mark them'); (IF CONFLICT THEN *WRITE(OUTPUT,' (may remove files!)'); (WRITE(OUTPUT,' ? '); (IF NGETCHAR(TRU) THEN .BEGIN 0WRITELN(OUTPUT,'Moving ',DTID); 0REBOOT := REBOOT OR :((DTID = 'SYSTEM.PASCAL') AND (GVID=SYVID)); 0NBLOCKS UT,FIRSTBLK); (IF EOLN(INPUT) THEN *LASTBLK := FIRSTBLK (ELSE *BEGIN ,READ(INPUT,LASTBLK); ,IF NOT EOLN(INPUT) THEN .WRITE) <> 'Y' THEN GOTO 1; (IF CONFLICT THEN *BEGIN ,X := 1; {ZAP CONFLICTS} ,WHILE X <= GDIR^[0].DNUMFILES DO .WITH GDIR^[X] ELN(OUTPUT); ,IF LASTBLK < 0 THEN .LASTBLK := ABS(LASTBLK); ,IF LASTBLK < FIRSTBLK THEN .BEGIN 0I := FIRSTBLK; 0FIRSTBLK :DO 0IF (MINBLK < DLASTBLK) AND (MAXBLK >= DFIRSTBLK) THEN 2DELENTRY(X,GDIR) 0ELSE 2X := X+1 *END; (IF GDIR^[0].DNUMFILES == LASTBLK; 0LASTBLK := I .END *END; (IF FIRSTBLK < GDIR^[0].DLASTBLK THEN *BEGIN { Directory is endangered } ,WRITE(OUTPUT MAXDIR THEN *BEGIN ,IF CHECKRSLT(ORD(INOROOM)) THEN; ,GOTO 1 *END; (WITH LDE DO *BEGIN ,DFIRSTBLK := MINBLK; ,DLASTBLK ,'Risk the dir ? '); ,IF NGETCHAR(TRUE) <> 'Y' THEN GOTO 1 *END; (FOR X := 1 TO GDIR^[0].DNUMFILES DO *WITH GDIR^[X] DO := MAXBLK+1; ,DFKIND := XDSKFILE; ,DLASTBYTE := FBLKSIZE; ,DACCESS := THEDATE; ,DTID := 'BAD.xxxxx.BAD'; ,FIRSTBLK := MINBL,IF (FIRSTBLK < DLASTBLK) AND (LASTBLK >= DFIRSTBLK) THEN .BEGIN { The block is located in a file } 0IF NOT CONFLICT THEN 2BK; ,FOR I := 4 DOWNTO 0 DO .BEGIN 0DTID[9-I] := CHR(FIRSTBLK DIV IPOT[I] + ORD('0')); 0FIRSTBLK := FIRSTBLK MOD IPOT[I] .ENEGIN 4CONFLICT := TRUE; 4WRITELN(OUTPUT,'File(s) endangered:') 2END; 0WRITELN(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1, 8DFIRD *END; (X := GDIR^[0].DNUMFILES; (WHILE MINBLK < GDIR^[X].DLASTBLK DO *X := X - 1; (INSENTRY(LDE,X+1,GDIR); (WRITEDIR(GUNSTBLK:6,DLASTBLK:6) .END; (IF CONFLICT THEN *BEGIN { Files are endangered } ,WRITE(OUTPUT,'Try to fix them ? '); ,IF NGETCHIT,GDIR); (WRITE(OUTPUT,LDE.DTID,' marked') &END;  1: "END {XBLOCKS} ;  "PROCEDURE KRUNCH; " "LABEL 1; "VAR AR(TRUE) <> 'Y' THEN GOTO 1 *END; (FOR X := FIRSTBLK TO LASTBLK DO *BEGIN ,WRITE(OUTPUT,'Block ',X); ,UNITREAD(GUNIT,A,FBLK$LINX: DIRRANGE; $NBLOCKS,DESTBLK,RELBLOCK,CHUNKSIZE,AINX,LBLOCK: INTEGER; $REBOOT: BOOLEAN; " "BEGIN { KRUNCH } $CLEARSCSIZE,X); ,B := A; ,UNITWRITE(GUNIT,A,FBLKSIZE,X); ,IF IORESULT = 0 THEN .UNITREAD(GUNIT,B,FBLKSIZE,X); ,IF (IORESULT = 0) AREEN; $IF CHECKFILE('Crunch','',1,FALSE,FALSE,[OKDIR],80,0) THEN &BEGIN (WRITE(OUTPUT,'Are you sure'); (IF NOT SYSCOM^.MISCND (A = B) THEN .WRITELN(OUTPUT,' may be ok') ,ELSE .BEGIN 0WRITELN(OUTPUT,' is bad'); 0IF X < MINBLK THEN MINBLK := X; 0IINFO.SLOWTERM THEN *WRITE(OUTPUT,' you want to crunch ',GVID,':'); (WRITE(OUTPUT,' ? '); (IF NGETCHAR(TRUE) <> 'Y' THEN GOTO F X > MAXBLK THEN MAXBLK := X .END *END; (IF MAXBLK < 0 THEN GOTO 1; (IF MINBLK = MAXBLK THEN *WRITELN(OUTPUT,'Block ',MINB1; { Abort CRUNCH } (REBOOT := FALSE; { Will be set to true if *SYSTEM.PASCAL is moved } (SYSCOM^.MISCINFO.NOBREAK := TRUE; (LK,' is still bad') (ELSE *WRITELN(OUTPUT,'Blocks ',MINBLK,' thru ',MAXBLK, 8' are still bad'); FOR LINX := 1 TO GDIR^[0].DNUMFILES DO *WITH GDIR^[LINX] DO ,IF (DFKIND <> XDSKFILE) AND 0(DFIRSTBLK > GDIR^[LINX-1].DLASTBLKL SE *END; (SYSCOM^.MISCINFO.NOBREAK := FALSE &END;  1: "END {KRUNCH} ;  " "PROCEDURE CALLPROMPT; " "BEGIN $PROMPT; $CH := GETCHAR(BADCOMMAND); $IF CH = ' ' THEN &CLEARSCREEN $ELSE &BEGIN (HOMECURSOR; (CLEARLINE; (IF CH = 'Q' THEN EXIT(REPEAT &PL :=  'Filer: G(et, S(ave, W(hat, N(ew, L(dir, R(em, C(hng, T(rans, D(ate, Q(uit [F.5]'; &CALLPROMPT; &IF CH = '?' := DLASTBLK-DFIRSTBLK; { Number of blocks in file } 0DESTBLK := GDIR^[LINX-1].DLASTBLK; { Were is this file going } 0RELBLOCK THEN (BEGIN *PL :=  'Filer: B(ad-blks, E(xt-dir, K(rnch, M(ake, P(refix, V(ols, X(amine, Z(ero [F.5]'; (CALLPROMPT &END; &:= 0; 0REPEAT 2CHUNKSIZE := NBLOCKS-RELBLOCK; 2IF CHUNKSIZE > GBUFBLKS THEN CHUNKSIZE := GBUFBLKS; 2IF CHUNKSIZE > 0 THEN BADCOMMAND := NOT (CH IN ['B','C','D','E','G','K','L','M','N', C'P','R','S','T','V','W','X','Z']); $UNTIL NOT BADCOMMAND; $PL4BEGIN AINX := 0; 6FOR LBLOCK := DFIRSTBLK+RELBLOCK TO HDFIRSTBLK+RELBLOCK+CHUNKSIZE-1 DO 8BEGIN :UNITREAD(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK); :IF IORESULT <> 0 THEN WRITELN(OUTPUT,'Read error, rel ', @LBLOCK-DFIRSTBLK,', abs ',LBLOCK); >R': REMOVER; &'T': TRANSFER; &'S': IF SAVEWORK(BADCOMMAND) THEN .BEGIN { Saving workfile on a different disk } 0TRANSFER;EXIT(KRUNCH)  0 THEN WRITELN(OUTPUT,'Write error, rel6TRANSFER 2END .END; &'P': PREFIXER; &'W': WHATWORK; &'M': MAKEFILE; &'V': LISTVOLS; &'B': BADBLOCKS; &'Z': ZEROV ', @LBLOCK-DESTBLK,', abs ',LBLOCK); >EXIT(KRUNCH)