>>>>ALLSOURCESS<<<<
%constant %integer ssobjfiletype= 1
%constant %integer ssdirfiletype= 2
%constant %integer sscharfiletype= 3
%constant %integer ssdatafiletype= 4
%constant %integer sscorruptobjfiletype=5
%constant %integer sspdfiletype= 6
%constant %integer ssoptfiletype= 9
%constant %integer usingworkfile=0
%record %format connect report format(%integer connect address, file type,
    data start, data end)
%record %format contf(%integer dataend, datastart, psize, filetype, sum,
    datetime, spare1, spare2, mark, null1, ugla, astk, ustk, null2, itwidth,
    ldelim, rdelim, journal, searchdircount, arraydiag, initworksize, spare,
    itinsize, itoutsize, nobl, istk, %long %integer initparms,
    %integer dataecho, terminal, i23, i24, i25, i26, i27, i28, i29, i30, i31,
    i32, %string (31) fstartfile, bstartfile, preloadfile, moddir, cfaults,
    s6, s7, s8, s9, s10, s11, s12, s13, s14, s15, s16, s17, s18, s19, s20,
    s21, s22, s23, s24, s25, s26, s27, s28, s29, s30, s31, s32,
    %string (31) %array searchdir(1:16))
%record %format arf(%string (31) name, %integer type)
%system %routine %spec setpar(%string (255) s)
%system %string (255) %function %spec spar(%integer ep)
%system %routine %spec ssmessa(%integer fail, %string (63) fname)
%system %routine %spec disconnect(%string (31) file, %integer %name flag)
%system %routine %spec connect(%string (31) file, %integer mode, hole,
    protection, %record (connect report format) %name report,
    %integer %name flag)
%system %routine %spec fileanal(%string (31) file,
    %record (arf) %array %name r, %integer %name count, flag)
%external %routine %spec clear(%string (255) s)
%external %routine %spec define(%string (255) s)
%external %integer %function %spec exist(%string (31) file)
%routine %spec anal(%string (31) file)
%own %integer full= 0, filing=0, conmode=0
%own %record (connect report format) r

%integer %function check error(%integer flag, %string (63) fmess)
   %result = 0 %if flag = 0
   ssmessa(flag, fmess)
   newline
   %result = flag
%end

%routine history(%string (255) file)
   %routine note(%string (31) file)
      selectoutput(0)
      printstring(file)
      newline
      selectoutput(2)
   %end

   %routine check for source(%string (255) files)
      %string (255) others, file, owner1, owner2
      others = files
      others -> owner1.(".").files
      %while others # "" %cycle
         %unless others -  > file.("+").others %start
            file = others
            others = ""
         %finish
         %if file -  > owner2.(".").file %then file = owner2.".".file %else %c
            file = owner1.".".file
         length(file) = 31 %if length(file) > 31
         %if exist(file) # 0 %start
            %if filing = 1 %then note(file)
            printstring("*** ".file." exists")
         %finish %else printstring("    ".file." does not exist")
         newline
         disconnect(file, flag)
      %repeat
   %end;                                 !of check for source

   %record (connect report  format) rr
   %integer flag, lda, p, conad
   %string (255) source, source1, source2
   connect(file, conmode, 0, 0, rr, flag)
   %return %if 0 # check error(flag, file)
   conad = rr_connect address
   lda = conad + integer(conad + 24);    !start of load data
   p = conad + integer(lda + 48);        !start of object data
   %while byteinteger(p) # 0 %cycle
      %if byteinteger(p) = 1 {source file type} %start
         source = string(p + 1)
         %if source -  > source1.("+").source2 %start
            source = source1."+".source2
            printstring("    (Source file(s):".source.")")
            newline
         %finish
         check for source(source)
      %finish
      p = p + byteinteger(p + 1) + 2;    !point to next item
   %repeat
   newline
%end

%routine print file size
   %integer %function file length(%record (connect report format) %name r)
      %result = r_data end - r_data start
   %end
   printstring("( ")
   write(file length(r), 1)
   printstring(" Bytes)")
%end


%routine objanal(%string (31) file)
   %constant %byte %integer %array headoffset(16:20)=  4,16,28,32,36
   %constant %byte %integer %array idenoffset(16:20)=  8,16,8,8,12
   %constant %string (255) %array list name(16:20)= %c
      "    Procedure Entries:" ,
      "    Data Entries:"    ,
      "    Procedure References:",
      "    Dynamic Procedure References:"    ,
      "    Data References:"
   %record (connect report format) rr
   %integer lda, list, link, conad, flag, i, newl, lists
   connect(file, conmode, 0, 0, rr, flag)
   %return %if 0 # check error(flag, file)
   conad = rr_connect address
   newl = 0
   printstring("Object: ".file."     ")
   print file size
   newline
   lda = conad + integer(conad + 24);    !abs addr ldata
   %if full = 1 %then lists = 20 %else lists = 16
   %cycle list = 16, 1, lists
      i = 0
      link = integer(lda + headoffset(list)); !head of right list
      %while link # 0 %cycle
         newl = 0
         %if i = 0 %then printstring(list name(list).":".tostring(nl))
         printstring("    ")
         printstring(string(conad + link + idenoffset(list)))
         i = i + 1
         %if i = 5 %then i = 1 %and newline %and newl = 1
         link = integer(conad + link)
      %repeat
      %if newl # 1 %and i > 0 %then newline
   %repeat
   history(file)
   disconnect(file, flag)
%end

%routine pdanal(%string (31) file)
   %record (arf) %array r(1:500)
   %integer flag, count, i
   printstring("PD file: ".file."     ")
   print file size
   newline
   count = 500
   fileanal(file, r, count, flag)
   %return %if 0 # check error(flag, file)
   %for i = 1, 1, count %cycle
      anal(file."_".r(i)_name) %if r(i)_type = 19
   %repeat
   disconnect(file, flag)
%end

%routine charanal(%string (31) file)
   %integer flag
   printstring("Character file: ".file."     ")
   print file size
   newline
   disconnect(file, flag)
%end

%routine datanal(%string (31) file)
   %integer flag
   printstring("Data File: ".file."     ")
   print file size
   newline
   disconnect(file, flag)
%end

%routine diranal(%string (31) file)
   %record (arf) %array r(1:500)
   %integer flag, count, i
   printstring("Directory: ".file)
   newline
   count = 500
   fileanal(file, r, count, flag)
   %return %if 0 # check error(flag, file)
   %for i = 1, 1, count %cycle
      anal(r(i)_name) %if r(i)_type = 1
   %repeat
   disconnect(file, flag)
%end

%routine optanal(%string (31) file)
   %record (contf) %name opt
   %record (connect report format) r
   %string (6) user
   %integer i, flag
   %if file -  > user.(".").file %then file = user.".".file %else user = ""
   connect(file, conmode, 0, 0, r, flag)
   %return %if 0 # check error(flag, file)
   opt == record(r_connect address)
   printstring("Options file: ".file)
   newline
   printstring("              Accessing the following directories:")
   newline
   printstring("              ")
   %if user # "" %then printstring(user.".".opt_moddir) %else %c
      printstring(opt_moddir)
   printstring("  (active directory)")
   newline
   %for i = 1, 1, opt_searchdircount %cycle
      printstring("              ".opt_searchdir(i))
      newline
   %repeat
   %if user # "" %then anal(user.".".opt_moddir) %else anal(opt_moddir)
   %for i = 1, 1, opt_searchdircount %cycle
      anal(opt_searchdir(i))
   %repeat
   disconnect(file, flag)
%end

%routine anal(%string (31) file)
   %integer flag
   connect(file, conmode, 0, 0, r, flag)
   %return %if 0 # check error(flag, file)
   %if r_filetype = ssobjfiletype %then objanal(file)
   %if r_filetype = sspdfiletype %then pdanal(file)
   %if r_filetype = ssdirfiletype %then diranal(file)
   %if r_filetype = ssoptfiletype %then optanal(file)
   %if r_filetype = sscharfiletype %then charanal(file)
   %if r_filetype = ssdatafiletype %then datanal(file)
%end

%external %routine all sources(%string (255) s)
   %string (31) file
   setpar(s)
   file = spar(1)
   %if spar(2) = "*" %then full = 1 %else full = 0
   %if spar(3) # "" %then %start
      filing = 1
      define("2,".spar(3))
      selectoutput(2)
   %finish %else filing = 0
   file = "SS#OPT" %if file = ""
   anal(file)
   %if filing # 0 %start
      selectoutput(0)
      closestream(2)
      clear("2")
   %finish
%end

%external %routine ss all sources(%string (255) s)
   %string (31) file
   setpar(s)
   file = spar(1)
   conmode = 9
   %if spar(2) = "*" %then full = 1 %else full = 0
   %if spar(3) # "" %then %start
      filing = 1
      define("2,".spar(3))
      selectoutput(2)
   %finish %else filing = 0
   file = "SS#OPT" %if file = ""
   anal(file)
   %if filing # 0 %start
      selectoutput(0)
      closestream(2)
      clear("2")
   %finish
%end

%end %of %file
>>>>ANALS<<<<
%constant %integer ssdatafiletype= 4
%constant %integer ssobjfiletype= 1
%constant %integer sscorruptobjfiletype=5
%constant %integer ssdirfiletype= 2
%constant %integer sscharfiletype= 3
%constant %integer sspdfiletype= 6
%constant %integer ssoptfiletype= 9
%record %format arf(%string (31) name, %integer type)
%record %format pdhf(%integer dataend, datastart, size, filetype, sum,
       datetime, adir, count)
%record %format rf(%integer conad, filetype, datastart, dataend)
%record %format dhf(%integer dataend, datastart, size, filetype, sum,
       datetime, pstart, spare)
%record %format lnf(%byte %integer type, %string (6) name, %integer rest,
       point, dr1)
%record %format frf(%integer conad, filetype, datastart, datend, size, rup,
       eep, mode, users, arch, %string (6) tran, %string (8) date, time,
       %integer count, spare1, spare2)
%record %format hf(%integer dataend, datastart, filesize, filetype, sum,
       datetime, format, records)
%record %format dahf(%integer dataend, datastart, size, filetype, date, time,
       format, records)
%system %routine %spec setwork(%integer %name ad, flag)
%external %string %function %spec fromstring(%string %name s, %integer i, j)
%system %routine %spec connect(%string (31) file, %integer mode, hole, prot,
       %record (rf) %name r, %integer %name flag)
%system %routine fileanal(%string (31) file, %record (arf) %array %name r,
       %integer %name count, flag)
   %integer pstart, hashconst, i, conad, point, max, lda, list
   %integer link, mark
   %constant %byte %integer %array headoffset(16:20)= %c
   4,16,28,32,36
   %constant %byte %integer %array idenoffset(16:20)= %c
8,16,8,8,12
   %string (255) s
   %record (pdhf) %name pdh
   %record (dhf) %name dh
   %record (rf) rr
   %record (lnf) %array %format haf(0:10000)
   %record (lnf) %array %name h
      max = count; !max no of elements in array r
      count = 0; !number filled by analyse
      connect(file, 0, 0, 0, rr, flag)
      ->err %if flag # 0
      conad = rr_conad
      %if rr_filetype = ssobjfiletype %start; !object file
         lda = conad + integer(conad + 24); !abs addr ldata
         %cycle list = 16, 1, 20
            link = integer(lda + headoffset(list)); !head of right list
            %while link # 0 %cycle
               count = count + 1
               ->full %if count > max
               r(count)_name = string(conad + link + idenoffset(list))
               r(count)_type = list
               link = integer(conad + link)
            %repeat
         %repeat
         ->err
      %finish
      %if rr_filetype = ssdirfiletype %start; !directory file
         dh == record(conad); !directory header
         hashconst = integer(conad + dh_datastart); !no of items in hash table
         h == array(conad + dh_datastart + 4, haf); !map onto hash arrray
         pstart = conad + dh_pstart
         point = 4; !first string
         !cycle through plist
         %while byteinteger(point + pstart) # 0 %cycle
            s = string(point + pstart)
            %if '=' # charno(s, 1) # 255 %and length(s) > 7 %and %c
                  charno(s, 7) = '.' %then %start
               ! not an alias or empty string
               count = count + 1
               ->full %if count > max; !array r is full
               r(count)_name = s
               r(count)_type = ssobjfiletype
               !now look for entry names that point to this name
               %cycle mark = 0, 1, 1; ! 0 for procedure entries, 1 for data entries.
                  %cycle i = 0, 1, hashconst - 1
                     %if h(i)_point = point %and h(i)_name # ".EMPTY" %and %c
                           h(i)_name # "" %and h(i)_type & 1 = mark %then %c
                           %start
                        count = count + 1
                        ->full %if count > max
                        %if h(i)_type & X'80' # 0 %then %c
                              r(count)_name = h(i)_name.string %c
                              (conad + dh_pstart + h(i)_rest) %else %c
                              r(count)_name = h(i)_name
                        r(count)_type = mark + 16; ! 16 for procedure, 17 for data.
                     %finish
                  %repeat
               %repeat
            %finish
            point = point + length(s) + 1; !move on to next string in plist
         %repeat
         !now look for aliases
         point = 4; !first string in pointer list
         %while byteinteger(point + pstart) # 0 %cycle
            s = string(point + pstart)
            %if charno(s, 1) = '=' %start
               count = count + 1
               ->full %if count > max
               r(count)_name = fromstring(s, 2, length(s))
               !remove '='
               r(count)_type = 21; !aliased name
               !now look for aliases that point here.
               %cycle i = 0, 1, hashconst - 1
                  %if h(i)_point = point %and h(i)_name # ".EMPTY" %and %c
                        h(i)_name # "" %then %start
                     count = count + 1
                     ->full %if count > max
                     %if h(i)_type & X'80' # 0 %then %c
                           r(count)_name = h(i)_name.string %c
                           (conad + dh_pstart + h(i)_rest) %else %c
                           r(count)_name = h(i)_name
                     r(count)_type = 16
                  %finish
               %repeat
            %finish
            point = point + length(s) + 1; !move on to next string in plist
         %repeat
         ->err
      %finish; !end of directory file
      %if rr_filetype = sspdfiletype %start; !partitioned file
         pdh == record(conad)
         %if pdh_count <= max %then count = pdh_count %else %start
            flag = 300
            count = max
         %finish
         !check if enough room in array r
         ->err %if count = 0; !no members
         point = conad + pdh_adir + 4
         %cycle i = 1, 1, count
            r(i)_name = string(point + (i - 1) * 32)
            r(i)_type = 19; !member of a pdfile
         %repeat
         ->err
      %finish
full:

      flag = 300; !user did not provide enough room in r
      count = count - 1; !reset count
err:

%end; !of fileanal

%external %routine testanal(%string (255) file)
   %integer i, flag, count, ad
   %constant %integer maxrecs=10000
   %record (arf) %array %format arfaf(1:maxrecs)
   %record (arf) %array %name r
      ad = maxrecs * (32 + 8)
      setwork(ad, flag)
      r == array(ad, arfaf)
      count = maxrecs
      flag = 0
      fileanal(file, r, count, flag)
      write(flag, 1); newline
      %for i = 1, 1, count %cycle
         %exit %if r(i)_name = ""
         printstring(r(i)_name."  is of type ")
         write(r(i)_type, 1)
         newline
      %repeat
%end
%end %of %file
>>>>AWAITS<<<<
%externalstringfnspec vdus(%integer i)
%externalroutinespec printchs(%string(255)s)
%recordformat parmf(%integer dest,srce,p1,p2,p3,p4,p5,p6)
%dynamicroutinespec dpoff(%record(parmf)%name p)
%dynamicintegerfnspec ddelay(%integer secs)
%externalroutine await(%string(255) s)
%record(parmf) p
%integer i
printchs(vdus(1))
newlines(5)
printstring("         This terminal is still in use - please do not try to use it")
newlines(5)
i=ddelay(2)
p=0
      dpoff(p)
      %end; ! AWAIT
%endoffile
>>>>BELLSS<<<<
%externalroutine bells(%string(255)dummy)
%integer i
%cycle i=1,1,20
      printch    (7)
      spaces(4)
%repeat
%end
%endoffile
>>>>CLNEWUSRS<<<<
%externalroutine clnewusers(%string(255)par)
%externalroutinespec newusers(%string(255)s)
%externalroutinespec clearscreen(%string(255)s)
clearscreen("")
newline
newusers(par)
%end
%endoffile
>>>>CLRSCREENS<<<<
%externalstringfnspec vdus(%integer i)
%externalroutinespec printchs(%string(255)s)
%externalroutine clearscreen(%string(255)s)
printchs(vdus(1))
%end
%endoffile
>>>>CLSS<<<<
%externalroutinespec printchs(%string(255)s)
%externalstringfnspec vdus(%integer ep)
%externalroutine cls(%string(255)s)
%if s#"" %then printchs(vdus(0))
printchs(vdus(1))
%end
%endoffile
>>>>COMPARS<<<<
%constinteger max base commands=12
%conststring(255)%array base commands(1:max base commands)=%C
"alias","remove","monitor","stop","quit","launch","broadcast","tell",
"autoattack","surrender","dump","resources"
!"B","C","D","E","F","G","H","I","J","K","AL","LI","RE","ST"
%recordformat com form (%string(80)comstr,%byteinteger base,type)
%constinteger max possible commands=20
%ownrecord(com form)%array commands(1:max possible commands)
%owninteger max commands=0

%routine sort(%record(com form)%arrayname r,%integer lo,hi)
!%routine sort(%stringarrayname r,%integer lo,hi)
%integer i,j,k,l,n
%record(com form)x
!%string(255)x
l=lo-1
n=hi
!%while n<hi-l %cycle
!  n=2*n
!%repeat
! <=> 1<<((32- shz{shift while not zero}(hi-l-1))&31)
!n contains smallest +ve integral power of 2 not less that hi-lo+1
*lss_n;*isb_l;*isb_1;*shz_%tos;*lb_32;*sbb_%tos;*lss_1;*rot_%b;*st_n
%cycle
 n=n//2
 %returnif n=0
 i=l
 %cycle
  i=i+1
  j=i+n
  %exitif j>hi
  k=i
  %while r(j)_comstr<r(k)_comstr %cycle
!  %while r(j)<r(k) %cycle
   x=r(j)
   r(j)=r(k)
   r(k)=x
   j=k
   k=k-n
   %exitif k<lo
  %repeat
 %repeat
%repeat
%end


%integerfn search(%record(com form)%arrayname tab,%integer lo,hi,%string(255)wanted)
!%integerfn search(%stringarrayname tab,%integer lo,hi,%string(255)wanted)
%integer pos
hi=hi+1
lo=lo-1
%while hi-lo-1>0 %cycle
  pos=(lo+hi)//2
  %result=pos %if tab(pos)_comstr=wanted
!  %result=pos %if tab(pos)=wanted
  %if tab(pos)_comstr<wanted %then lo=pos %else hi=pos
!%if tab(pos)<wanted %then lo=pos %else hi=pos
%repeat
%result=0
%end

%routine initialise commands
%integer i
%for i=1,1,max base commands %cycle
  commands(i)_comstr=base commands(i)
  commands(i)_base=i
  commands(i)_type=1
%repeat
max commands=max base commands
sort(commands,1,max commands)
%end

%routine add alias(%string(80)com,al)
%integer i,j
i=search(commands,1,max commands,com)
%if i=0 %then printstring("original com not found")%and newline %andreturn
j=search(commands,1,max commands,al )
%if j=0 %and max commands=max possible commands %start
   printstring("no room for alias")
   newline
   %return
%finish
%if j=0 %start
   max commands=max commands+1
   j=max commands
%finishelsestart
   %if commands(j)_type=1 %start
      printstring("cannot overwrite base command")
      newline
      %return
   %finish
%finish
commands(j)_comstr=al
commands(j)_base=commands(i)_base
commands(j)_type=2
sort(commands,1,max commands)
%end

%routine remove alias(%string(80)al)
%integer i
i=search(commands,1,max commands,al)
%if i=0 %start
   printstring("alias not found")
   newline
   %return
%finish
%if commands(i)_type#2 %start
   printstring("this was not an alias")
   newline
   %return
%finish
commands(i)_base=0
commands(i)_type=0
commands(i)_comstr="".tostring(127)
length(commands(i)_comstr)=80
sort(commands,1,max commands)
max commands=max commands-1
%end

%integerfn get com no(%string(80)s)
%integer i
i=search(commands,1,max commands,s)
%result=0 %if i=0
%result=commands(i)_base
%end

%externalroutine zz(%string(255)dummy)
%string(255)s,c,al
%integer i
initialise commands
!%for i=1,1,max commands %cycle
!   readstring(commands(i))
!%repeat
!printstring("Commands now read in")
!newline
!sort(commands,1,max commands)
!%for i=1,1, max commands %cycle
!  printstring(commands(i))
!  newline
!%repeat
%cycle
   readstring(s)
i=get com no(s)
!   i=search(base commands,1,max base commands,s)
   %if i>0 %start
         printstring(s." is command number ")
         write(i,1)
   %finishelse printstring(s." not known")
  newline
%if i=1 %start{alias}
  readstring(c);readstring(al)
  add alias(c,al)
%finish
%if i=2 %start{remove}
  readstring(al)
  remove alias(al)
%finish
%if i=3 %start{list}
  %for i=1,1,max commands %cycle
     write(i,3)
     printstring("   ".commands(i)_comstr)
     write(commands(i)_base,5)
     write(commands(i)_type,5)
     newline
   %repeat
%finish
%if i=4 %thenreturn
%repeat
%end
%endoffile
>>>>COPY3S<<<<
%constant %integer true=0,false=1
%constant %integer testing=false
%if testing = true %start
   %routine %spec monitor(%string (255) s)
%finish
%system %string %function %spec failuremessage(%integer flag)
%system %string (31) %function %spec itos(%integer i)
%own %string (11) save owner,save file
%own %integer already connected=0
%constant %string (6) %name me=9<<18
%system %routine %spec outfile(%string (31) file, %integer size,hole,prot,
    %integer %name conad,flag)
%system %routine %spec move(%integer len,from,to)
%system %routine %spec destroy(%string (31) file, %integer %name flag)
%system %string (31) %function %spec nexttemp
%system %routine %spec setpar(%string (255) par)
%system %integer %function %spec parmap
%system %string (31) %function %spec spar(%integer which)
%system %integer %function %spec allowconnect(%string (6) who,
    %string (11) what)
%system %routine %spec zcopy2(%string (255) par, %integer silent,
    %integer %name flag)
%record %format hf(%integer dataend,datastart,size,filetype)
%record %format rf(%integer conad,filetype,datastart,dataend)
%system %routine %spec connect(%string (31) file, %integer mode,hole,prot,
    %record (rf) %name r, %integer %name flag)
%external %integer %function %spec dconnect(%string (6) owner,
    %string (11) file, %integer fsys,mode,apf, %integer %name seg,gap)
%external %integer %function %spec ddisconnect(%string (6) owner,
    %string (11) file, %integer fsys,destroy)
%routine bconnect(%string (31) full file, %integer mode,hole,prot,
    %record (rf) %name r, %integer %name flag)
   %record (hf) %name h
   %string (6) owner
   %string (31) file,partition
   %integer seg,gap,fsys,apf,conad
   %if full file -  > owner.(".").file %start
   %finish %else %start
      owner = me
      file = full file
   %finish
   %if file -  > file.("_").partition %then %start
   %finish %else %start
      partition = ""
   %finish
   mode = 1
   fsys = -1
   apf = 0
   seg = 0
   gap = 0
   save owner = owner
   save file = file
   flag = dconnect(owner,file,fsys,mode,apf,seg,gap)
   %if flag = 34 %then flag = 0 %and already connected = true %else %c
      already connected = false
   %if flag # 0 %then flag = flag + 500 %and %return
   conad = seg << 18
   h == record(conad)
   r_conad = conad
!h==record(seg<<18)
!r_conad=addr(h)
!r_conad=seg<<18
   r_filetype = h_filetype
   r_datastart = h_datastart
   r_dataend = h_dataend
%end
%routine bdisconnect
   %integer flag
   %unless already connected = true %then %c
      flag = ddisconnect(save owner,save file,-1,0)
%end
%routine copy inner(%string (31) file, %string (31) %name new,
    %integer %name flag)
   %integer oldconad,newconad,oldlen,dummy
   %record (rf) r1
   %if testing = true %start
      monitor("about to call bconnect:".file.",0,0,0,r1,flag")
   %finish
   bconnect(file,0,0,0,r1,flag)
   %if flag # 0 %then %return
   oldconad = r1_conad
   oldlen = r1_dataend
   new = "T#".nexttemp
   %if testing = true %start
      monitor("about to call outfile:".new.",".itos(oldlen).",".itos(oldlen). %c
         ",newconad,flag")
   %finish
   outfile(new,oldlen,oldlen,0,newconad,flag)
   %if flag # 0 %then %return
   %if testing = true %start
      monitor("about to call move:".itos(oldlen).",".itos(oldconad).",".itos %c
         (newconad))
   %finish
   move(oldlen,oldconad,newconad)
   bdisconnect
%end

%external %routine copy3(%string (255) par)
   %string (31) old file,new file,owner,file,temp,member,save old file
   %integer flag,temp created,dummy
   setpar(par)
   %if parmap # 3 %then flag = 263 %and ->fail
   oldfile <- spar(1)
   newfile <- spar(2)
   save old file = oldfile
   %if testing = true %start
      monitor("copy3:".oldfile.",".newfile)
   %finish
   %unless oldfile -  > owner.(".").file %then owner = me %and file = old file
   %unless file -  > file.("_").member %then member = ""
   length(owner) = 6 %if length(owner) > 6
   length(file) = 11 %if length(file) > 11
   %if testing = true %start
      monitor("about to call allowconnect:".owner.",".file)
   %finish
   %if owner # me %and allowconnect(owner,file) # 0 %then %start
!   %if allowconnect(owner,file) # 0 %or owner=me %start
      %if testing = true %start
         monitor("Allowconnect failed")
         monitor("about to call Copy Inner:".owner.".".file.",temp")
      %finish
      copy inner(owner.".".file,temp,flag)
      ->fail %if flag # 0
      file = temp
      temp created = true
      %if testing = true %start
         monitor("TEMP=".temp)
      %finish
      oldfile = me.".".temp
   %finish %else %start
      tempcreated = false
      oldfile = owner.".".file
   %finish
   %if member # "" %then oldfile = oldfile."_".member
   %if testing = true %start
      monitor("About to call zcopy2:".oldfile.",".newfile."/W,1,flag")
   %finish
   zcopy2(oldfile.",".newfile."/W",1,flag)
fail:
   %if flag = 0 %start
      %if testing = true %start
         newline
      %finish
      printstring(spar(2)." is a copy of ".save old file)
      newline
      %if temp created = true %then destroy(temp,dummy)
   %finish %else %start
      %if testing = true %start
         monitor("Flag=".itos(flag)."  sorry!")
      %finish
      printstring("Copy3 fails  - ".failuremessage(flag))
      newline
   %finish
%end
%if testing = true %start
   %routine monitor(%string (255) s)
      newline
      printstring("*** ".s)
!   newline
   %end
%finish
%end %of %file
>>>>COUNTERS<<<<
%begin
!%externalroutine t(%string(255)dummy)
%externalintegerfnspec ddelay(%integer i)
%longintegerarray store(1:10)
%longinteger now ,then
%integer counter,flag
%longintegerfn tim(%integer val)
*RRTC_1
*USH_(%LNB+5)
*STUH_%TOS
*USH_1
*USH_-1
*EXIT_-64
%end
%for counter=1,1,10 %cycle
     store(counter)=tim(-19)
     flag=ddelay(30)
%repeat
then=store(1)
%for counter=1,1,10 %cycle
   now=store(counter)
   print(now,20,0)
   printstring("    <>    ")
   write(now-then,0)
   then=now
   newline
%repeat
%endofprogram
!%end
!%endoffile
>>>>FINDPRIVS<<<<
%externalroutine findpriv(%string(255)u)
%string(6)user
%integer flag,fsys,priv,i
%externalintegerfnspec dfsys(%string(6)user,%integername fsys)
%externalintegerfnspec dsfi (%string(6)user,%integer fsys,type,set,adr)
user<-u
%if length(user)#6 %then flag=8 %and ->out
fsys=-1
flag=dfsys(user,fsys)
->out %unless flag=0
flag=dsfi(user,fsys,38,0,addr(priv))
->out %unless flag=0
write(priv,1)
newline
%for i=0,1,32 %cycle
   %if (priv>>i)&1=1 %then write(i,3)
%repeat
out:
%if flag#0 %start
   printstring("Flag=")
   write(flag,1)
   newline
%finish
%end
%endoffile
>>>>FINDS<<<<

%record %format rf(%integer conad, filetype, datastart, dataend)
%system %routine %spec connect(%string (31) file, %integer mode, hole, prot,
       %record (rf) %name r, %integer %name flag)
%external %integer %function %spec exist(%string (31) file)
%system %integer %function %spec currentll
%system %long %integer %function %spec load ep(%string (31) entry,
       %integer %name type, flag, %integer loadlevel)
%system %routine %spec unload2(%integer loadlevel, flag)
%external %integer %function %spec uinfi(%integer ep)
%external %routine %spec define(%string (255) s)
%external %routine %spec clear(%string (255) s)
%external %routine %spec closestream(%integer str)
%system %routine %spec ssmessa(%integer fail, %string (63) fname)
%system %routine %spec find entry(%string (31) entry, %integer type, dad,
       %string %name file, %integer %name dr0, dr1, flag)
%system %routine %spec load(%string (31) entry, %integer type,
       %integer %name flag)
%system %routine %spec setpar(%string (255) s)
%system %string %function %spec spar(%integer i)
%system %integer %function %spec parmap
%system %string %function %spec confile(%integer adr)
%system %integer %map %spec comreg(%integer i)
%external %string %function %spec uinfs(%integer entry)
%constant %byte %integer %array hex(0:15)= %c
          '0', '1', '2', '3', '4', '5', '6', '7',
          '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'
%constant %integer %array accept digits(0:7)= %c
                      X'FFFFFFFF',
                      X'FFFF003F',
                      X'FFFFFFFF'(6)

%string (8) %function htos(%integer value, places)
!*  TURNS AN INTEGER INTO A HEXADECIMAL STRING OF GIVEN LENGTH
!*  USES MACHINE CODE
   %string (8) s
   %integer i
      i = 64 - 4 * places
      *LD_s; *LSS_places; *ST_(%dr )
      *INCA_1; *STD_ %tos; *STD_ %tos
      *LSS_value; *LUH_0; *USH_i
      *MPSR_X'24'; ! SET CC=1
      *SUPK_ %l =8
      *LD_ %tos; *ANDS_ %l =8, 0, 15; ! THROW AWAY ZONE CODES
      *LSS_hex+4; *LUH_X'18000010'
      *LD_ %tos; *TTR_ %l =8
      %result = s
%end; !OF HTOS

%routine phex(%integer i)
      printstring(htos(i, 8))
%end; !OF PHEX

%routine getnum(%string (255) s, %integer %name i, flag)
   %integer j, k, l, sign
      ->err %if s = ""; !NO PARAM
      l = length(s)
      i = 0
      j = charno(s, 1)
      %if j = 'X' %then %start
         %if l > 9 %then ->err
         %for k = 2, 1, l %cycle
            j = charno(s, k) - '0'
            %if j > 9 %then j = j + '0' - 'A' + 10
            %unless 0 <= j <= 15 %then ->err
            i = (i << 4) ! j
         %repeat
      %finish %else %start
         %if j = '-' %then %start
            sign = 13
            k = 2
         %finish %else %start
            sign = 15
            k = 1
         %finish
         l = l - k + 1
         %if l > 0 %then %start
            %if l > 10 %then ->err
            k = addr(s) + k
            *LDTB_X'18000000'
            *LDB_l
            *LDA_k
            *STD_ %tos
            *LSS_accept digits+4
            *LUH_256
            *TCH_ %l = %dr
            *JCC_7, <err>
            *LD_ %tos
            *LB_sign
            *LSQ_ %b
            *PK_ %l = %dr
            *CBIN_0
            *ST_ %tos
            *USH_32
            *ISH_-32
            *UCP_ %tos
            *JCC_7, <err>
            *STUH_ %b
            *ST_(i)
         %finish
      %finish
      flag = 0
      %return
err:
      flag = 1
%end; ! GETNUM

%routine define output(%string (255) s)
      %if s = "$CLEAR$" %start
         selectoutput(0)
         closestream(23)
         clear("23")
         %return
      %finish
      s = ".OUT" %if s = ""
      define("23,".s)
      selectoutput(23)
%end

%external %routine history(%string (255) file)

   %routine check for source(%string (255) files)
      %string (255) others, file, owner1, owner2
         others = files
         others -> owner1.(".").files
         %while others # "" %cycle
            %unless others -  > file.("+").others %start
               file = others
               others = ""
            %finish
            %if file -  > owner2.(".").file %then %c
                  file = owner2.".".file %else file = owner1.".".file
            length(file) = 31 %if length(file) > 31
            %if exist(file) # 0 %then %c
                  printstring("***  ".file." exists ") %else %c
                  printstring("     ".file." does not exist ")
            newline
         %repeat
   %end; !of check for source

   %record (rf) rr
   %integer flag, lda, p
   %constant %integer ssobjfiletype=1
   %string (255) source, source1, source2
%if file# "#DIRCODE" %start
      connect(file, 0, 0, 0, rr, flag)
      %if flag # 0 %start
         printstring("     History fails  -  ")
         ssmessa(flag, file)
         newline
         %return
      %finish
      %if rr_filetype # ssobjfiletype %start
         printstring("     History fails  -  ")
         ssmessa(267, file)
         newline
         %return
      %finish
%finishelsestart
printstring("     Director code file")
%return
%finish
      printstring("     Object File    :".file)
      newline
      lda = rr_conad + integer(rr_conad + 24); !start of load data
      p = rr_conad + integer(lda + 48); !start of object data
      %while byteinteger(p) # 0 %cycle
         %if byteinteger(p) = 1 {source file type} %start
            source = string(p + 1)
            %if source -  > source1.("+").source2 %start
               source = source1."+".source2
               printstring("     (Source file(s):".source.")")
               newline
            %finish
            check for source(source)
         %finish
         p = p + byteinteger(p + 1) + 2; !point to next item
      %repeat
      newline
%end

%routine decodedr0(%integer dr0, dr1)
   %integer type, subtype, size, s, usc, bci, bound, newdr0, newdr1
   %string (255) line
      *lss_(%lnb +5)
      *st_ %b
      *lss_ %b; *ush_-30; *st_type
      *lss_ %b; *ush_2; *ush_-26; *st_subtype
      *lss_ %b; *ush_2; *ush_-29; *st_size
      *lss_ %b; *ush_5; *ush_-31; *st_s
      *lss_ %b; *ush_6; *ush_-31; *st_usc
      *lss_ %b; *ush_7; *ush_-31; *st_bci
      *lss_ %b; *ush_8; *ush_-8; *st_bound
      printstring("     DR0=    "); write(dr0, 1);
      printstring("   (=X'"); phex(dr0); printstring("')"); newline
      printstring("     Type   "); write(type, 1)
      %if type = 3 %start
         printstring("     Subtype ");
         write(subtype, 1)
      %finish
      printstring("     Size   "); write(size, 1); newline
      printstring("     S      "); write(s, 1)
      printstring("     USC    "); write(usc, 1)
      printstring("     BCI    "); write(bci, 1)
      printstring("     Bound  "); write(bound, 1); newline
   %constant %integer %array sizecode(0:7)= 1, 0, 0, 8, 16, 32, 64, 128  {BITS}
      {                                        0, 1, 2, 3,  4,  5,  6,   7   CODE}
   %constant %string (255) %array descname(0:3)= %c
      "Vector","String","Descriptor"," "
   %constant %string (255) %array subname(32:64)= %c
      "Bounded code","Unbounded code","INVALID","System call",
      "INVALID","Escape","INVALID"(2),"Bounded semaphore",
      "Unbounded semaphore","INVALID"(21),"Null","INVALID"
      line = " descriptor "
      line = descname(type).line
      subtype = 64 %unless 32 <= subtype <= 63
      line = subname(subtype).line %if type = 3
   %switch desctype(0:3)
      ->desctype(type)
desctype(0): {vector}
      %if sizecode(size) = 8 %then %c
            line = "Byte ".line."to a string of length " %else %if %c
            bci = 0 %then line = line."  - greatest modifer is 1+ "
      printstring("     ".line); write(bound, 1); newline
      %return
desctype(1): {string}
      line = "Poorly formed ".line."(wrong size specified)" %if %c
            sizecode(size) # 8
      line = line."to string of length"
      printstring("     ".line)
      write(bound, 1)
      newline
      %return
desctype(2): {descriptor}
      %unless sizecode(size) = 64 %and s = 0 %then %c
            line = "Poorly formed ".line."(wrong size)"
      printstring("     ".line)
      newline
      %unless dr1 <= 0 %start
         printstring("     Descriptor is loaded in file ".confile(dr1))
         newline
         *lda_dr1; *ldtb_dr0; *lsd_(%dr ); *stuh_newdr0; *st_newdr1
         printstring("Accesing descriptor in file   ".confile(newdr1))
         newline
         printstring("     New DR0:"); write(newdr0, 1);
         printstring("   (=X'"); phex(newdr0); printstring("')")
         printstring("     New DR1:"); write(newdr1, 1)
         printstring("   (=X'"); phex(newdr1); printstring("')")
         newline
         dr0 = newdr0
         dr1 = newdr1
         decodedr0(dr0, dr1)
         %if confile(newdr1) # "" %start
            printstring("Attempt to find source(s) of object file")
            newline
            history(confile(newdr1))
         %finish
      %finish
      %return
desctype(3): {other}
      printstring("     ".line)
      newline
      %return
%end



%external %routine getdr0(%string (255) str)
   %integer dr0, dr1, flag1, flag2
   %string (255) s1, s2
      setpar(str)
      s1 = spar(1)
      s2 = spar(2)
      getnum(s1, dr0, flag1)
      getnum(s2, dr1, flag2)
      %if flag1 = 0 %then decode dr0(dr0, dr1) %else printstring("BAD PARAM")
!temp
%end

%external %routine checkentry(%string (255) s)
   %constinteger true = 1, false = 0
   %string (31) file
   %integer dr0, dr1, flag, savecom44, savemon, type, loadlevel, full
   %long %integer %name desc
      full = false
      file = ""
      dr0 = 0
      dr1 = 0
      flag = 100000
      savecom44 = comreg(44)
      setpar(s)
      ->out %if parmap & 1 # 1
      s = spar(1)
      full = true %if spar(2) = "*"
      length(s) = 31 %if length(s) > 31
      %if uinfi(26) = 0 %start
         findentry(s, 0, 0, file, dr0, dr1, flag)
         %if flag # 0 %then %start
            load(s, 0, flag)
            %if flag # 0 %then %start
               printstring("     Checkentry fails   -   ")
               ->out
            %finish
            findentry(s, 0, 0, file, dr0, dr1, flag)
            %if flag # 0 %then %start
               printstring("     ERROR  FAILED TO FIND ENTRY ".s. %c
                     " AFTER CALLING LOADER")
               newline
               ->out
            %finish
         %finish
      %finish %else %start
         type = 2
         loadlevel = currentll
         desc == longinteger(addr(dr0))
         desc = loadep(s, type, flag, loadlevel)
         %if desc = 0 %then flag = 289
         ->out %if flag # 0
      %finish
%if full=1 %start
      write(dr0, 10)
 write(dr1, 10)
 newline
%finish
      file = confile(dr1)
      file = uinfs(1).".#DGLA" %if file = ""
      printstring("     ".s." successfully loaded in file ".file)
      newline
%if full=true %start
      printstring("     DR0=")
      write(dr0, 10)
      printstring("(X'")
      phex(dr0)
      printstring("')")
      printstring("     DR1=")
      write(dr1, 10)
      printstring("(X'")
      phex(dr1)
      printstring("')")
      newline
      printstring("Analysis of Descriptor gives :")
      newline
      decode dr0(dr0, dr1)
%finishelsestart
%if dr1<(2<<18)%then file="#DIRCODE" %else file=confile(integer(dr1+4))
history(file)
%finish
out:
      %if flag # 0 %then %start
         ssmessa(flag, s)
         newline
      %finish
      %if uinfi(26) = 0 %start
         comreg(44) = savecom44
      %finish %else %start
         loadlevel = currentll
         unload2(loadlevel, flag)
      %finish
%end

%external %routine source(%string (255) s)
   %integer dr0, dr1, full, command, flag
   %string (255) s1, s2, s3, s4
      setpar(s)
      %if parmap & 1 # 1 %start
         printstring("invalid param"); !TEMP
         %return
      %finish
      s1 = spar(1)
      s2 = spar(2)
      s3 = spar(3)
      s4 = spar(4)
      getnum(s1, dr0, flag)
      %if flag # 0 %then command = 1 %else command = 0
      %if command = 1 %start
         %if s2 # "" %then full = 1 %else full = 0
         defineoutput(s3)
         checkentry(s1.",".s2); !change for full!!!
         defineoutput("$CLEAR$")
         %return
      %finish
!dr1=getnum(s2)
      getnum(s2, dr1, flag)
      %if s3 # "" %then full = 1 %else full = 0
      defineoutput(s4)
      dr1 = 0 %if dr1 < 0
      decodedr0(dr0, dr1); !change for full
      defineoutput("$CLEAR$")
%end
%end %of %file
>>>>FNOK<<<<
program testfile(input,output);

type
   string31   = packed array [1..31] of char;

var
   filename   : string31;
   flag       : boolean;

procedure readstring(var inp:text;var s:string31; var flag:boolean);

var
   i          : integer;

procedure skipspaces(var inp:text);
begin
   while (inp^=' ') and not (eoln(inp)or eof(inp)) do
      get(inp);
end;

begin
   skipspaces(inp);
   { jump past space characters}
   for i:=1 to 31 do
      { fill array with spaces}
s                  [i]:=' ';
   i := 1;
   while (inp^<>' ') and not (eoln(inp)) and (i<31) do begin
      s[i] := inp^;
      {read in the next string of characters stopping when}
      get(inp);
      {A) a space is found, B) the end of the line is reached}
      i := i+1;
      {or C) the 31 character array is full.}
   end;
   for i:= 1 to 31 do
      {change the string to upper case}
      if ('a'<=s[i]) and ( s[i]<='z') then
         s[i] := chr(ord(s[i])-ord('a')+ord('A'));
   if inp^<>' ' then
      {set afa failure flag if the next character is not a space}
      flag := false;
   {or end of line}
end;


function fnok(s:string31;writeto:boolean): boolean;

var
   i,dot,sub        : integer;
   fail,ftype      : packed array[0..4] of boolean;
   done       : boolean;

function ownfile:boolean;
type shortword=packed array[1..6]of char;
var owner,user:shortword;
    i:integer;

procedure getuser(var u:shortword);
const userad=2359296;
type  string6=packed array[0..6]of char;
       p=^string6;
     p2=record
           dummy:integer;
            case boolean of
               true:(userptr:p);
               false:(addr:integer)
            end;
var  find:p2;
     usr:string6;
     i:integer;
begin
find.addr:=userad;
usr:=find.userptr^;
for i:=1 to 6 do u[i]:=usr[i];
end;

begin
for i:=1 to 6 do owner[i]:=s[i];
getuser(user);
ownfile:= not (owner=user);
end;

function alphabetical(ch:char): boolean;
begin
   alphabetical := ((ord('A')<=ord(ch))and(ord(ch)<=ord('Z')))
                or((ord('a')<=ord(ch))and(ord(ch)<=ord('z')));
end;

function alphanumeric(ch:char): boolean;
begin
   alphanumeric := ((ord('0')<=ord(ch))and(ord(ch)<=ord('9')))
                or alphabetical(ch);
end;

begin
   for i:=0 to 4 do
      ftype[i]:=false;
   for i:=0 to 4 do
      fail[i]:=false;
   dot := 0;
   sub := 0;
   for i:=1 to 31 do
      if s[i]='.' then
         dot := i;
   for i:=31 downto 1 do
      if s[i]='_' then
         sub := i;
   fail[1] := ((dot<>0)and(dot<>7))or((sub<>0)and(dot+1>=sub)) or fail[1];
   if dot<>0 then
      if not fail[1] then
         for i:=1 to 6 do
            fail[1]:=fail[1] or not alphanumeric(s[i]);
   ftype[1] := not fail[1] and (dot<>0);
   ftype[1]:= ftype[1] and ownfile;
   fail[0] := fail[1];
   if not fail[0] then begin
      i := dot+1;
      fail[2] := not alphabetical(s[i]);
      repeat
         i := i+1;
         done := (s[i]=' ')or(s[i]='_');
         fail[2] := not ( alphanumeric(s[i]) or(s[i]='#')or done) or fail[2];
      until done or fail[2] or (i=dot+12);
      fail[2] := fail[2] or not done;
   end;
   fail[0] := fail[1] or fail[2];
   if not fail[0] then begin
      ftype[3] := sub<>0;
      if ftype[3] then begin
         i := sub+1;
         fail[3] := not alphabetical(s[i]);
         repeat
            i := i+1;
            done := s[i]=' ';
            fail[3] := fail[3] or not (alphanumeric(s[i]) or done);
         until done or fail[3] or (i=sub+12);
         fail[3] := fail[3] or not done;
      end;
   end;
   fail[0] := fail[1] or fail[2] or fail[3] or fail[4];
   if fail[0] then begin
      write('invalid ');
      if fail[1] then
         write('username ')
      else if fail[2] then
         write('filename ')
      else if fail[3] then
         write('membername ');
      writeln(s);
   end
   else begin
      if writeto then
         if ftype[1]{other user's file}
         or ftype[3]{pd file member} then begin
            write('Sorry but you can''write to ');
            if ftype[1] then
               writeln('another user''s file')
            else
               writeln('a partitioned file member');
            fail[4] := true;
         end
   end;
   fnok := not (fail[1] or fail[2] or fail[3] or fail[4]);
end;
begin
   repeat
      readstring(input,filename,flag);
      writeln('Can it be written to?:     ',fnok(filename,true));
      readln(input);
   until filename[1]='&';
end.

>>>>FNOKS<<<<
program test_f_name(input,output);
type string31=packed array[1..31]of char;
var  filename:string31;

function fnok(s:string31;write_to:boolean):boolean;
var i,dot,sub:integer;fail,ftype:packed array[0..4]of boolean;done:boolean;

function my_file(s:string31):boolean;
const
  userad=2359296;{str6}
type
  str6=packed array[0..6]of char;
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^str6)
         end;
  var peeker:cheat;me,owner:str6;i:integer;
  begin
     peeker.addr:=userad;
     me:=peeker.ptr^;
     owner[0]:=chr(6);
     for i:=1 to 6 do owner[i]:=s[i];
{     writeln('OWNER=',owner,'    ME=',me,'     result=',me=owner);            }
     my_file:=owner=me;
  end;


function alphabetical(ch:char):boolean;
begin
alphabetical:=((ord('A')<=ord(ch))and(ord(ch)<=ord('Z')));
end;

function alphanumeric(ch:char):boolean;
begin
alphanumeric:=((ord('0')<=ord(ch))and(ord(ch)<=ord('9')))or alphabetical(ch);
end;

begin
for i:=0 to 4 do begin ftype[i]:=false;fail[i]:=false; end;
dot:=0;sub:=0;
for i:=1 to 31 do if s[i]='.' then dot:=i;
for i:=31 downto 1 do if s[i]='_' then sub:=i;
fail[1]:=((dot<>0)and(dot<>7))or((sub<>0)and(dot+1>=sub));
if dot<>0 then if not fail[1] then for i:=1 to 6 do fail[1]:=fail[1] or not
                                        alphanumeric(s[i]);
ftype[1]:=not fail[1] and (dot<>0);
fail[0]:=fail[1];
if not fail[0] then begin
   i:=dot+1;fail[2]:=not alphabetical(s[i]);
   repeat
      i:=i+1;done:=(s[i]=' ')or(s[i]='_');
      fail[2]:=not (alphanumeric(s[i])or(s[i]='#')or done)or fail[2];
   until done or fail[2] or (i=dot+12);
   fail[2]:=fail[2] or not done;
end;
fail[0]:=fail[1] or fail[2];
if not fail[0] then begin
   ftype[3]:=sub<>0;
   if ftype[3] then begin
       i:=sub+1;
       fail[3]:=not alphabetical(s[i]);
{       repeat                                                                 }
{          done:=s[i]=' ';                                                     }
{          fail[3]:=NOT DONE AND(fail[3] or not (alphanumeric(s[i])));         }
{          i:=i+1;                                                             }
{       until done or fail[3] or (i=sub+12);                                   }
       while not (fail[3] or done or (i=sub+12))do begin
           i:=i+1;done:=s[i]=' ';
           fail[3]:=not done and not alphanumeric(s[i]);
       end;
       fail[3]:=fail[3] or not done;
    end;

end;
fail[0]:=fail[1] or fail[2] or fail[3];
if fail[0] then begin
    write('Invalid ');
    if fail[1] then write('username ') else
        if fail[2] then write('filename ') else
            if fail[3] then write('member name ');
    writeln(s);
end else begin
  if write_to then begin
      if ftype[1] and not my_file(s) then  begin
            writeln('Invalid access - you can''t write to another user''s file');
            fail[4]:=true;
       end else begin
           if ftype[3] then begin
    writeln('Invalid access - you can''t write to a partitioned file member ');
         fail[4]:=true;
            end;
       end;
    end;
end;
fnok:=not(fail[1] or fail[2] or fail[3] or fail[4]);
end;

procedure readstr(var s:string31);
var i:integer;
begin
for i:=1 to 31 do s[i]:=' ';
i:=1;
while input^=' ' do get(input);
while (i<=31) and not eoln do begin read(s[i]);i:=succ(i);end;
if i=1 then readstr(s);
end;

begin
repeat
readstr(filename);
if fnok(filename,false) then writeln(filename,'an be read');
if fnok(filename,true) then writeln(filename,'can be written to');
until false;
end.
>>>>GETADDR<<<<
%begin
%recordformat comf %c
(%integerarray i1(1:25),%byteintegerarray b1(1:8),%integerarray i2(1:9),
%longinteger l1,%integerarray i3(1:9),%integer MAXPROCS,
%integerarray i4(1:4),%integer PROCAAD)
%constrecord(comf)%name com=X'80000000'+48<<18
printstring("Addresses of communications record")
newline
printstring("Record starts at ");write(addr(com_i1(1)),10);newline
printstring("Maxprocs is at   ");write(addr(com_maxprocs),10);newline
printstring("Procaad is at    ");write(addr(com_procaad),10);newline
%endofprogram
>>>>GSQS<<<<
%externalroutine gsq(%string(255)s)
%externalroutinespec tcpusers(%string(255)s)
tcpusers("GESQ");tcpusers("GSQ2");
%end
%endoffile
>>>>HASPS<<<<
%external %routine %spec set return code(%integer flag)
%external %integer %function %spec return code
%external %routine %spec detach(%string (255) s)
%external %routine %spec detachjob(%string (255) s)
%external %routine %spec prompt(%string (255) s)
%external %routine %spec destroy(%string (255) s)
%external %integer %function %spec exist(%string (255) s)
%systemroutinespec move(%integer len,from,to)
%system %routine %spec ssmessa(%integer flag, %string (63) fname)
%system %routine %spec outfile(%string (31) file, %integer size, hole, prot, %c
       %integer %name conad, flag)

%routine makefile(%string (255) ownfile)
   %integer flag, conad, i, j
      %on %event 9 %start
         ->out
      %finish
      destroy(ownfile) %if exist(ownfile) # 0
      outfile(ownfile, 4096, 0, X'40000000' {temp file}, conad, flag)
      %if flag # 0 %then ssmessa(flag, ownfile) %and ->err
      printstring("Enter contents of job file. Finish by typing Ctrl-Y")
      prompt("Batch:")
      newline
      i = conad + 32
      %cycle j = i, 1, i + 4000
         readsymbol(byteinteger(j))
      %repeat
out:
      integer(conad) = j - conad
      integer(conad + 4) = 32
      integer(conad + 8) = j - conad - 32
      integer(conad + 12) = 3
      %if j - conad - 32 = 0 %start
         flag = 233
         ssmessa(flag, ownfile." is empty!")
      %finish
err:
      set return code(flag)
%end

%routine makeparams(%string (255) ownfile)
%constinteger l = 27
%constbyteintegerarray p(0:27)=
'O','U','T','=','F','I','L','E',X'0A',
'O','U','T','N','A','M','E','=','S','#','J','J','N',X'0A',
'.','E','N','D',X'0A'
   %integer conad, flag, i, j
      destroy(ownfile) %if exist(ownfile) # 0
      outfile(ownfile, 50, 0, X'40000000', conad, flag)
      %if flag # 0 %then ssmessa(flag, ownfile) %and ->err
      i = conad + 32
      move(l,addr(p(0)),conad+32)
      integer(conad) =32+l
      integer(conad + 4) =32
      integer(conad + 8) =l
      integer(conad + 12) =3
err:
      set return code(flag)
%end

%external %routine hasp(%string (255) time)
   %constant %string (8) detfile="T#DETACH"
   %constant %string (8) parfile="T#PARAMS"
   %constant %string (1) comma=","
   %string (255) line
      %on %event 9 %start
         detach(line)
         ->out
      %finish
      makeparams(parfile)
      ->err %if return code # 0
      makefile(detfile)
      ->err %if return code # 0
      line = detfile.comma.time.comma.parfile
      prompt("Command or Job Interpreter:")
      %while nextsymbol # 'j' %and nextsymbol # 'J' %and %c
            nextsymbol # 'c' %and nextsymbol # 'C' %cycle
         skipsymbol
      %repeat
      %if nextsymbol = 'j' %or nextsymbol = 'J' %then detachjob(line) %else %c
            detach(line)
      %while nextsymbol # nl %cycle
         skipsymbol
      %repeat
out:
      %if return code # 0 {from detach or detachjob} %start
         printstring("Well, you could always try DETACHing ".detfile. %c
               " yourself")
         newline
         %return
      %finish
err:
      destroy("S#JJN") %if exist("S#JJN") # 0
      destroy(detfile) %if exist(detfile) # 0
      destroy(parfile) %if exist(parfile) # 0
%end

%end %of %file
>>>>HEAPS<<<<
%constant %integer true=1,false=0,wordshift=2
%own %integer base=0,heap size=65535<<wordshift,
 moning=true,first hole=0,flag=0,
 first call=true
%record %format holef(%half %integer size,next)
%record %format crf(%integer conad,type,start,end)
%own %record (crf) connect report
%own %record (holef) %name prev,curr,succ
%constant %string (11) heap file="T#IHEAP"
%own %string (11) temp file=""
%system %routine %spec outfile(%string (31) file, %integer length,hole,prot,
    %integer %name conad,flag)
%external %integer %function %spec exist(%string (31) file)
%system %routine %spec destroy(%string (31) file, %integer %name flag)
%system %routine %spec connect(%string (31) file, %integer mode,hole,prot,
    %record (crf) %name report, %integer %name flag)
%system %routine %spec disconnect(%string (31) file, %integer %name flag)
%system %routine %spec newgen(%string (31) old,new, %integer %name flag)
%system %routine %spec rename(%string (31) old,new, %integer %name flag)
%system %routine %spec fill(%integer length,start,filler)
%external %integer %function %spec outpos
%external %integer %function %spec outstream
%system %string (31) %function %spec nexttemp
%system %string (31) %function %spec htos(%integer val,len)

%routine failed(%string (31) what, %string (255) msg)
   selectoutput(0)
   newline
   printstring("HEAP use: ".what." failed ".msg)
   newline
   printstring("        : first hole = ")
   write(first hole,1)
   newline
   %monitor
   %stop
%end

%routine OK(%string (31) what, %integer size,ad)
   %integer curstr
   %if moning # false %start
      curstr = outstream
      selectoutput(0)
      newline %if outpos # 0
      printstring("HEAP use: ".what)
      %unless size = 0 = ad %start
         %if outpos < 40 %then spaces(40 - outpos)
         printstring("   ".htos(size,8)." bytes    at ".htos(ad,8))
      %finish
      newline
      selectoutput(curstr)
   %finish
%end

%system %routine heapmon(%integer val)
   %if val = true %start
      moning = true
      OK("MONITOR on",0,0)
   %finish %else %start
      OK("MONITOR off",0,0)
      moning = false
   %finish
%end

%routine create heap
   %if exist(heap file) = false %start
      outfile(heap file,heap size,0,0,base,flag)
      %if flag # 0 %then failed("OUTFILE ".heap file,"")
   %finish %else %start
      destroy(heap file,flag)
      %if flag = 0 %then OK("DESTROY ".heap file,0,0) %else %c
         failed("DESTROY ".heap file,"")
      outfile(heap file,heap size,0,0,base,flag)
      %if flag # 0 %then failed("OUTFILE ".heap file,"")
   %finish
   curr == record(base)
   curr_size = heap size >> wordshift
   curr_next = 0
   first call = false
   OK("HEAP initialised",heap size,base)
%end

%external {TEMP!!!} %integer %function find hole(%integer size)
   %integer res
   first hole = first hole & X'0000FFFF'
   OK("Find hole :",0,first hole << wordshift + base)
   curr == record(first hole << wordshift + base)
   prev == record(addr(first hole))
   OK("SEARCH starts (?) at:",curr_size,addr(curr_size))
   %while curr_size < size %and curr_next # 0 %cycle
      OK("SEARCHING :",curr_size,addr(curr_size))
      prev == curr
      curr == record(base + curr_next << wordshift)
   %repeat
   %if curr_next = 0 %start
      OK("PREV==",integer(addr(prev_size)),addr(prev_size))
      OK("CURR==",integer(addr(curr_size)),addr(curr_size))
      %if curr_size < size %then failed("NEW","to find heap space")
      res = addr(curr_size)
      prev_next = (res - base + size) >> wordshift
      succ == record(res + size)
      succ_size = curr_size - size
      succ_next = 0
      OK("CLAIMED at top of heap",size,res)
      OK("        Next hole is :",succ_size,addr(succ_size))
      {!}first hole = (addr(succ_size) - base) >> wordshift %if res = base
      OK("PREV==",integer(addr(prev_size)),addr(prev_size))
      OK("CURR==",integer(addr(curr_size)),addr(curr_size))
      OK("SUCC==",integer(addr(succ_size)),addr(succ_size))
      %result = res
   %finish %else %start
      res = addr(curr_size)
      %if curr_size > size %start
         succ == record(res + size)
         succ_size = curr_size - size
         succ_next = curr_next
      %finish %else %start
         succ == record(curr_next << wordshift + base)
      %finish
      prev_next = (addr(succ_size) - base) >> wordshift
      OK("CLAIMED",size,res)
      {!}first hole = (addr(succ_size) - base) >> wordshift %if res = base
      %result = res
   %finish
%end

%integer %function my size of(%name info)
   %integer size
   size = size of(info)
   %if size // (1 << wordshift) # 0 %then %c
      %result = (size >> wordshift + 1) << wordshift
   %result = size
%end

%routine old try at new(%integer dr0,dr1)
   %if first call = true %then create heap
   dr0 = dr0 & X'FF'
   OK("NEW called",dr0,dr1)
   dr1 = find hole(dr0)
%end

%system %integer %function another try at  new(%name info)
   %integer dr0,dr1
   %if first call = true %then create heap
   dr0 = size of(info)
   dr1 = addr(info)
   OK("NEW called ",dr0,dr1)
   dr1 = find hole(dr0)
   OK("NEW tries to return",dr0,dr1)
   %result = dr1
%end

%routine make hole(%integer size,ad)
   first hole = first hole & X'0000FFFF'
   %unless base <= ad < heap size + base %and %c
      base <= ad + size <= heap size + base %start
      OK("ADDRESS ERROR - attempt to make hole outside heap",0,0)
      OK("Heap is :",heap size,base)
      OK("Hole wanted",size,ad)
      %return
   %finish
   curr == record(ad)
   fill(size,ad,0)
   curr_next = (ad - base) >> wordshift
   curr_size = size
   OK("New HOLE made ",size,ad)
   prev == record(addr(first hole))
   %if prev_next << wordshift + base > ad %start
      OK("New hole is below any other",0,0)
      curr_next = first hole
      first hole = (ad - base) >> wordshift
      %return {*****TEMP}
   %finish %else %start
      OK("Search for hole below starts",0,prev_next << wordshift + base)
      %while prev_next # 0 %and prev_next < curr_next %cycle
         prev == record(prev_next << wordshift + base)
         OK(".....to hole ",prev_size,addr(prev_size))
      %repeat
      curr_next = prev_next
      prev_next = (ad - base) >> wordshift
      OK("PREV==",integer(addr(prev_size)),addr(prev_size))
      OK("CURR==",integer(addr(curr_size)),addr(curr_size))
      %if addr(prev_size) + prev_size = ad %start
         OK("Merge with previous hole",0,0)
         prev_size = prev_size + curr_size
         prev_next = curr_next
         curr_size = 0
         curr_next = 0
         curr == prev
         OK("Resulting in",integer(addr(prev_size)),addr(prev_size))
      %finish
   %finish
   %if curr_next # 0 %start
      succ == record(curr_next << wordshift + base)
      %if addr(curr_size) + curr_next = addr(succ_size) %start
         OK("Merge with next hole at",succ_size,addr(succ_size))
         curr_size = curr_size + succ_size
         curr_next = succ_next
         succ_size = 0
         succ_next = 0
         OK("Resulting in",integer(addr(curr_size)),addr(curr_size))
      %finish
   %finish
%end


%system %routine dispose(%name info)
   %integer dr0,dr1
   dr0 = size of(info)
   dr1 = addr(info)
   OK("DISPOSE called",dr0,dr1)
   make hole(dr0,dr1)
   OK("DISPOSE completed",0,0)
%end

%system %routine heapfrag
   %integer holes,size,max,min,ave,curstr
   %if first call = true %then %c
      OK("HEAP FRAG called before NEW!",0,0) %and %return
   curstr = outstream
   selectoutput(0)
   newline %if outpos # 0
   printstring("HEAP use: FRAGMENTATION ANALYSIS")
   newline
   holes = 0
   size = 0
   min = heap size
   max = 0
   first hole = first hole & X'0000FFFF'
   curr == record(addr(first hole))
   printstring("offset of first hole is ".htos(curr_next << wordshift,
      8)." from base of ".heap file." at ".htos(base,8))
   newline
   %while curr_next # 0 %cycle
      curr == record(curr_next << wordshift + base)
      holes = holes + 1
      size = size + curr_size
      max = curr_size %if curr_size > max
      min = curr_size %if curr_size < min
      write(holes,5)
      write(curr_size,6)
      printstring(" ({X'".htos(curr_size,4)."'}")
      printstring("   X'".htos(addr(curr_size),8)."'")
      newline
   %repeat
   printstring("Total of ")
   write(size,1)
   printstring(" {X'".htos(size,8)."'} free bytes in ")
   write(holes,1)
   printstring(" holes")
   newline
   printstring("Largest hole is ")
   write(max,1)
   printstring(" {X'".htos(max,4)."'} bytes")
   newline
   printstring("Smalles hole is ")
   write(min,1)
   printstring(" {X'".htos(min,4)."'} bytes")
   newline
   ave = size // holes
   printstring("Average hole is ")
   write(ave,1)
   printstring(" {X'".htos(ave,4)."'} bytes")
   newline
   printstring("HEAP use : ANALYSIS COMPLETE")
   newline
   selectoutput(curstr)
%end

%system %integer %function new(%name info)
   %integer dr0,dr1
   %if first call = true %then create heap
   dr0 = size of(info)
   dr1 = addr(info)
   OK("NEW called :",dr0,dr1)
   dr1 = find hole(dr0)
   OK("NEW returns:",dr0,dr1)
   %result = dr1
%end

%end %of %file
>>>>INTERRUPTS<<<<
   
!TITLE Interrupts, %EVENTs and fault trapping.
!<Interrupts
    Subsystem cannot control or handle interrupts on its own, and has to
exploit the facilities offered by Director for the purpose.
!< PRIME CONTINGENCY
    One of the tools provided is the
    %EXTERNAL %INTEGER %FN PRIME CONTINGENCY (%ROUTINE TRAP)
in Director.  This need only be called once, to nominate the routine TRAP
to Director.  The %SPEC of TRAP must be
    %ROUTINE %SPEC TRAP (%INTEGER CLASS, SUBCLASS).
If an interrupt subsequently occurs which is relevant to the process
(and subject to some conditions which will appear later), Director
will suspend the process and force it to enter TRAP, supplying the
two %INTEGER parameters CLASS and SUBCLASS to indicate what sort of
interrupt has occurred.  TRAP will normally be some routine which is
declared as part of the subsystem, and in the standard subsystem it is
the routine DIRTRAP, declared in module BASE.  The corresponding call of
PRIME CONTINGENCY is almost the first instruction executed in the
%SYSTEM %ROUTINE CONTROL declared in module CONT.
!>
!< READID
    Within the TRAP routine, the subsystem can identify the kind
of interrupt from the values of CLASS and SUBCLASS, and can find more
details by calling the
    %EXTERNAL %INTEGER %FN READID (%INTEGER AD)
which is part of Director (see Director documentation for details), and a
suitable call is found quite early in DIRTRAP.  The parameter AD must be
the address of the first element of an array of 18 words.
!>
!< Environment
    The data returned by READID will be the 'environment' at the time
of the interrupt, laid out as follows:
    1:   SSN/LNB
    2:   PSR
    3:   PC
    4:   SSR
    5:   SSN/SF
    6:   IT
    7:   IC
    8:   CTB
    9:   XNB
   10:   B
   11 and 12: DR
   13 to 16: Accumulator
   17:   FPC (for PE only)
   18:   ?
!>
!< DRESUME
    When the subsystem has finished processing the interrupt, if it is
required to resume the process at the point where it was suspended before
Director forced the call of the TRAP routine, then it must call
DRESUME (0, 0, AD), where DRESUME is supplied in Director with the
specification
    %EXTERNAL %ROUTINE %SPEC DRESUME (%INTEGER LNB, PC, AD)
and AD has the same value as the AD parameter passed to READID (or,
at any rate, is the address of 18 words containing the same data as
was returned from READID).  There is such a call of DRESUME near the end
of DIRTRAP, just before the lable REROUTE.
!>
!< Inhibiting interrupts
!< SSINHIBIT and SSINTCOUNT
    From time to time, Subsystem may find it impractical to handle
interrupts for a short period, and it can inhibit calls on DIRTRAP by
setting a non-zero value into the first of two consecutive words which
are declared as SSINHIBIT and SSINTCOUNT in the Subsystem.  So long as
SSINHIBIT is non-zero, Director will not force any calls on DIRTRAP,
even if some interrupt occurs; but if one does occur, details will
be recorded in Director's tables for future reference, and SSINTCOUNT
will be incremented.
!>
!< ALLOW INTERRUPTS
    Later on (but, for safety's sake, after only a short
delay), Subsystem will clear SSINHIBIT to zero, to allow calls on DIRTRAP
again.  Once SSINHIBIT is zero, all the interrupts which arrived
while calls of DIRTRAP were inhibited, and whose details have been
saved up by Director, must be processed: this is achieved by
    %WHILE SSINTCOUNT>0 %THEN I = DASYNCINH (1,0)
which requests Director to initiate the appropriate calls of
DIRTRAP (supported by the relevant information to be acquired
via READID) for each of the 'pending' interrupts, one after another.
It is left to Director to decrement SSINTCOUNT.  The relevant code in
Subsystem is found in the %SYSTEM %ROUTINE ALLOW INTERRUPTS (with
no parameters) in the BASE module.
!>
!< DASYNCINH
    For this mechanism to work, Director must know where to find
the two consecutive words SSINHIBIT and SSINTCOUNT.  This information
is supplied by Subsystem in a call on DASYNCINH (0,ADDR(SSINHIBIT));
the declaration of DASYNCINH is
    %EXTERNAL %INTEGER %FN %SPEC DASYNCINH (%INTEGER MODE, A)
and the relevant call is found near the start of the routine CALL BCI
in CONTROL in module CONT.  Until this call has been made, Director will
not initiate any calls on DIRTRAP, even though DIRTRAP has already been
nominated by PRIME CONTINGENCY.  Instead, all interrupts will be 'saved'
or kept pending from the time of the call of PRIME CONTINGENCY until the
call on DASYNCINH.  Any interrupts which were already pending at the
time of the original call on PRIME CONTINGENCY, on the other hand, will
be discarded and utterly lost.  Consequently the start-up sequence of the
Subsystem includes a very early call on PRIME CONTINGENCY, but defers
the first call of DASYNCINH until much later, when the environment is
completely set up for handling interrupts.  Only after that call will
Director initiate calls on DIRTRAP for the pending interrupts (if any).
!>
!>
!< Calls on Director
    Apart from declarations, Subsystem contains one call of READID,
one use of DIRTRAP, two calls of DASYNCINH and two of DRESUME.  We have
so far accounted for all of these except one call on DRESUME.  The
story so far is a complete account of the interactions between Subsystem
and Director for processing interrupts: what follows is concerned
with Subsystem's internal mechanisms and with the effects on, and
facilities for, user programs.
!>
!< REROUTE CONTINGENCY
    Director is not very selective about interrupts.  If it has
something to report to Subsystem, then the only decision which arises
is whether to report it now or to save it for later.  There are no
facilities to inhibit some kinds of interrupts but not others, nor to
report different kinds of interrupts through different paths.  (It is
possible for Subsystem to change the nominated TRAP routine by a second
call on PRIME CONTINGENCY, but this is not a very versatile facility, and
Subsystem soes not use it.)  However, Subsystem has an internal mechanism
to achieve some of these things.  There is a
    %SYSTEM %ROUTINE REROUTE CONTINGENCY (%INTEGER EP, CLASS,         %C
            %LONG %INTEGER MASK, %ROUTINE STRAP, %INTEGER %NAME FLAG)
(declared in BASE) which allows the caller to nominate an alternative routine
STRAP with specification
    %ROUTINE %SPEC STRAP (%INTEGER CLASS, SUBCLASS)
exactly like the TRAP parameter to PRIME CONTINGENCY.  The parameters EP,
CLASS and MASK in a call of REROUTE CONTINGENCY indicate which kinds of
interrupt are to be handled by STRAP.  Up to eight different STRAP routines
can be simultaneously defined, by different calls on REROUTE CONTINGENCY,
each one for a different kind of interrupt.  Director will still initiate
a call of DIRTRAP for any kind of interrupt, but DIRTRAP contains code
to select the appropriate STRAP routine and initiate a call on that.  If
the interrupt is of a kind for which no STRAP has been nominated, then
DIRTRAP will handle it in the normal way.  Within a STRAP routine,
READID may be used to obtain complete information about the interrupt,
and DRESUME can be used to resume the interrupted process, just as
is done in DIRTRAP.
!PAGE

    REROUTE CONTINGENCY can be used to define up to 8 different STRAP
routines to handle different kinds of interrupt (actually, the limit
is the declared value of the %CONST %INTEGER MAXRRC).  The number of
STRAP routines currently defined is given by the %INTEGER RRCTOP, and
the whole set of STRAP routines can be discarded by calling
REROUTE CONTINGENCY with the parameter EP=0 (which has the effect of
setting RRCTOP to zero).  Other calls on REROUTE CONTINGENCY must have
1<=EP<=5, and these are used to nominate STRAP routines.  EP, CLASS
and MASK are used to specify what kinds of interrupt should be
handled by STRAP.  MASK is a 64-bit mask in which the least significant
(right-hand) bit corresponds to the value 0 or 64, the next bit
corresponds to 1 or 65, and so on up to the most significant
(left-hand) bit which corresponds to 63 or 127.  The meaning
of the values of EP, CLASS and MASK are as follows:

    N.B.: In the following table, 'class' and 'subclass' (written in
          lower case) refer to the properties of an interrupt.  'CLASS'
          and 'MASK' (written in upper case) refer to the parameters
          supplied to REROUTE CONTINGENCY.
!PAGE

    EP=1     Handle interrupts whose class = CLASS (ignore MASK).

    EP=2     Handle interrupts whose class = CLASS, provided that
             the bit corresponding to subclass is set in MASK
             (for subclasses 0 to 63).

    EP=3     Handle interrupts whose class = CLASS, provided that
             the bit corresponding to subclass is set in MASK
             (for subclasses 64 to 127).

    EP=4     Check the MASK bit corresponding to the class
             of the interrupt, and handle the interrupt if the bit
             is non-zero (for classes 0 - 63).  Ignore CLASS.

    EP=5     Check the MASK bit corresponding to the class
             of the interrupt, and handle the interrupt if the bit
             is non-zero (for classes 64-127).  Ignore CLASS.
!PAGE

    Incidentally, any use of EP=1 could be replaced by an equivalent
use of EP=4 or 5 (unless one is dealing with interrupt classes greater
than 127).
!>
!< DIRTRAP
    REROUTE CONTINGENCY is, in fact, used nowhere in the standard Subsystem.
Consequently all interrupts are handled by DIRTRAP, so we must now
consider what DIRTRAP does.  For completeness, this description will
include 'forward references' to some things which have not yet been
defined - in particular, SIGLEVEL and SIGNAL - but the general
outline should be sufficiently clear if you know that SIGNAL is a
routine in the Subsystem which is used to notify the 'user program'
of an event.

 1.   Check whether there is any STRAP routine nominated by a previous
      call of REROUTE CONTINGENCY to handle this interrupt.  If there is,
      bodge up a call to that routine, passing on the parameters CLASS
      and SUBCLASS.  There will be no further action in DIRTRAP.  In
      the usual case, there is no STRAP routine, so DIRTRAP carries on
      at step 2.

 2.   Check 0<SIGLEVEL<=MAXSIGLEVEL.  This is simply a check that
      SIGNAL will be able to function if required.  DSTOP(103)
      if the check fails.

 3.   READID to get the interrupt data.

 4.   Bodge the PSR field of the return link from DIRTRAP (at LNB+1)
      so that it looks as if DIRTRAP was called directly from the
      interrupted process.  (This is said to be for the sake of ONCOND
      in NDIAG).

 5.   Action depends on the class of interrupt.
!< Most interrupts
      CLASS # 64, 65 or 66 - i.e., action for most interrupts:
         if STOPPING then DSTOP (113);

         copy the interrupt data (as returned by READID) 
         into SIGDATA(SIGLEVEL);

         copy the same data, PLUS class, subclass and time, into
         one of the SAVEIDATA areas (for #REGS);

         SIGNAL (2,CLASS,SUBCLASS,FLAG) - i.e., signal the event
         at the most recently defined level;

         resume.
!>
!< Time exceeded
      CLASS = 64 (time limit exceeded):
         use DSETIC to get some more time;

         if STOPPING then resume with no further action;

         copy the interrupt data (as returned by READID) 
         into SIGDATA(SIGLEVEL);

         copy the same data, PLUS class, subclass and time, into
         one of the SAVEIDATA areas (for #REGS);

         SIGNAL (2,64,SUBCLASS,FLAG) - i.e., signal 'time
         exceeded' at the most recently defined level;

         resume.
!>
!< Single character INT
      CLASS = 65 (single character INT:) - SUBCLASS will be the
                                           interrupt character:
         convert lower to upper case;

         convert all characters to 'X' for batch jobs;

         recognise which character;

         if it's not a recognised character (Q,W,X,Y,T,A,C),
         then resume with no further action;
!< W, X, Y
         for W, X, Y:
            if STOPPING then DSTOP (113);

            set INT IN PROGRESS (ignoring its previous value);

            SIGNAL (3,65,SUBCLASS,FLAG) - i.e., signal at outermost level;

            resume.
!>
!< A, C
         for A, C:
            if INT IN PROGRESS or STOPPING then resume (i.e., ignore it);

            set INT IN PROGRESS;

            SIGNAL (3,65,SUBCLASS,FLAG) - i.e., signal at outermost level;

            resume.
!>
!< Q
         for Q:
            if INT IN PROGRESS or STOPPING then resume (i.e., ignore it);

            set INTQ (but INT IN PROGRESS is not set - why not?);

            copy the interrupt data (as returned by READID) 
            into SIGDATA(SIGLEVEL);

            copy the same data, PLUS class, subclass and time, into
            one of the SAVEIDATA areas (for #REGS);

            SIGNAL (2,65,'Q',FLAG) - i.e., signal 'INT:Q'
            at the most recently defined level;

            resume.
!>
!< T
         for T:
            if INT IN PROGRESS or STOPPING then resume (i.e., ignore it);

            CONSOLE (12,FLAG,FLAG) to print the time, etc.;

            resume.
!>
!>
!< Operator message
      CLASS = 66 (operator message):
         if not STOPPING then call CONSOLE (6,...) to print the message;

         resume.
!>
!>
!>
!<SIGNAL
The routine SIGNAL is declared in module BASE in the Subsystem as
    %SYSTEM %ROUTINE SIGNAL (%INTEGER EP, P1, P2, %INTEGER %NAME FLAG).
It uses the integer SSCOMREG(34) which is often referred to by the
    %INTEGER %NAME SIGLEVEL
and the other relevant declarations are
    %CONST %INTEGER MAXSIGLEVEL = 7
    %RECORD %FORMAT SIGDATAF (%INTEGER PC, LNB, CLASS, SUBCLASS,          %C
            %INTEGER %ARRAY A (0:17))
    %OWN %RECORD %ARRAY SIGDATA (1:MAXSIGLEVEL) (SIGDATAF)
!< Specification
SIGLEVEL must satisfy 0<=SIGLEVEL<=MAXSIGLEVEL.

From 0 to 7 (i.e., MAXSIGLEVEL) 'levels' of event handling may be defined.
SIGLEVEL indicates how many are actually defined.  For each defined level,
SIGDATA(I)_PC and SIGDATA(I)_LNB give the values of PC and LNB for
restarting the process when an event occurs.  Levels are defined by calling
SIGNAL with the parameter EP=0 (or -1 or 9) and the values for PC and
LNB as parameters P1 and P2.  The first such call on SIGNAL defines
level 1: SIGLEVEL must be zero beforehand, and will be 1 on return from
SIGNAL(0,...).  Subsequent calls define levels 2, 3, and so on, and of
course each call increments SIGLEVEL, so that SIGDATA(SIGLEVEL) is
always the most recently defined level.

A level may be 'abandoned' by calling SIGNAL with EP=1 and P1=0; this
simply decrements SIGLEVEL.  This is a necessary precaution on exit from
the routine or lexical level where the SIGNAL(0,...) call occurred,
since the stack frame is discarded and the LNB value becomes meaningless.
!PAGE

Calling SIGNAL with EP=1 and P1#0 will set SIGLEVEL = 0, thus discarding
all levels: this is a sensible precaution before the first call of
SIGNAL(0,...), and this sequence is found near the beginning of CALLBCI
in CONTROL in module CONT.

When some event occurs, SIGNAL(2,...) or SIGNAL(3,...) may be used to
'signal' the event: that is, to resume execution of the process using
the PC and LNB extracted from one of the SIGDATA records.  This
resumption is achieved by
    DRESUME (SIGDATA(I)_LNB, SIGDATA(I)_PC, ADDR(SIGDATA(I)_CLASS))
which effectively loads the LNB and passes control to the code at PC,
with a copy of the third parameter in the accumulator (see documentation
of DRESUME for further explanations).  SIGNAL(2,...) uses I=SIGLEVEL and
decrements SIGLEVEL: i.e., it signals the event at the most recently defined
level (excluding, of course, levels which have already been abandoned),
and abandons that level so that it will not be used again for subsequent
events.  SIGNAL(3,...), on the other hand, uses I=1.  This has the
effect of resuming execution at the 'outermost' level (i.e., the
level first defined).

Before calling SIGNAL(2,...), it is useful to fill in the contents
of the array SIGDATA(SIGLEVEL)_A with information about the event.
The routine SIGNAL itself will copy its own parameters P1 and P2
into SIGDATA(SIGLEVEL)_CLASS and _SUBCLASS.  The fields CLASS,
SUBCLASS and A then constitute 80 bytes of information about the
event, and, as we have seen, the address of this block of data is
supplied as a parameter to the call of DRESUME, and it ends up in the
accumulator when the process is resumed, so that the process can
determine what event has occurred.  In DIRTRAP, _A gets a copy of
the 18-word 'environment' as delivered by READID before the call of
SIGNAL.  It would also be possible to fill in SIGDATA(1)_A before a
call of SIGNAL(3,...), because SIGNAL passes the data on in the same
way, but as far as I know this is not actually done in the standard
subsystem.
!PAGE

SIGNAL offers an extra facility: a call of SIGNAL(4,...) will 'repeat'
the last call of SIGNAL(2,...) or SIGNAL(3,...).  That is to say, it
will simulate a call of SIGNAL(2,...) using the same _CLASS, _SUBCLASS
and _A as were supplied to the last call of SIGNAL(2,...) or
SIGNAL(3,...).  Now a call of SIGNAL(2,...) uses the _PC and _LNB from
SIGDATA(SIGLEVEL) to resume the process, and also decrements SIGLEVEL,
thus abandoning the level; and the simulated calls made by SIGNAL(4,...)
work the same way.  Thus, repeated calls of SIGNAL(4,...) will signal
the same event at the various levels, most recently defined first.
The way to exploit this is for each level to have a PC and LNB which
will pass control to some code whose first action is to examine the
class, subclass and interrupt data (which are pointed to by the
address in the accumulator).  The code must then decide whether it can
handle the signalled event.  If it can, then it does; but if it
cannot, it simply calls SIGNAL(4,...) to activate the previous level,
which can do the same sort of test.  In this way, an event is signalled
at successive levels until some level is prepared to cope with it.
!PAGE

SIGNAL(5,...) simply does %MONITOR; %STOP.

SIGNAL(6,AD,..) copies the current value of SIGLEVEL into the integer
pointed to by the address AD.
!>
!< Summary
Summary of parameters:

(0,PC,LNB,FLAG)   define a new 'level':   save PC and LNB, increment SIGLEVEL.

(1,0,-,FLAG)      abandon a level:        decrement SIGLEVEL.

(1,n{#0},-,FLAG)  abandon all levels:     set SIGLEVEL = 0.

(2,CLASS,SUBCLASS,FLAG)
                  signal event at most
                  recently defined level
                  and abandon that level:
                                          event defined by CLASS, SUBCLASS
                                          and SIGDATA(SIGLEVEL)_A;
                                          pass control to code with PC, LNB
                                          extracted from SIGDATA(SIGLEVEL);
                                          decrement SIGLEVEL.
!PAGE

(3,CLASS,SUBCLASS,FLAG)
                  signal event at outermost level:
                                          event defined by CLASS, SUBCLASS
                                          and SIGDATA(1)_A;
                                          pass control to code with PC, LNB
                                          extracted from SIGDATA(1).

(4,-,-,FLAG)      signal last event again
                  at most recent surviving level.

(5,-,-,FLAG)      %MONITOR; %STOP.

(6,ADDR(L),-,FLAG)
                  copy SIGLEVEL into L.
!>
!>
!<ONCOND
This note is about the routine ONCOND (in module NDIAG), which is used to
implement the IMP fault trap mechanism.  Its specification is
    %ROUTINE %SPEC ONCOND (%INTEGER EVENT, SUBEVENT, LNB)
It is only called once, fom the routine NDIAG.  Its purpose is to unravel
the stack of an interrupted process (while running on that stack itself!)
looking for a stack frame corresponding to IMP source code which has
nominated an %ON %EVENT action for the event which has occurred.  If
no such stack frame is found, ONCOND will %RETURN to NDIAG.  If one is
found, then instead of returning to NDIAG, the LNB and SF will be adjusted
and ONCOND will pass control (by EXIT) to the code indicated by the
%ON %EVENT trap.

ONCOND will refuse to handle any EVENT which is outside the range 1 - 14
(i.e., it will simply %RETURN to NDIAG).  Within ONCOND, EVENT numbers
are represented as bits in a word, with bit 0 (the most significant, left-
hand bit) corresponding to event number 14, and bit 13 corresponding to
event number 1.
!< Specification
The action of ONCOND is as follows:

 1.   PREVLNB gets a copy of the stack frame pointer for the level
      which called ONCOND - i.e., for NDIAG.

 2.   If we have unravelled the stack far enough, or LNB is not in
      the stack segment, then %RETURN to NDIAG.

 3.   Extract GLA address from the stack frame indicated by LNB.

 4.   Pick out the language flag from the GLA, and %RETURN if it's not IMP.

 5.   Look in the stack frame again for the GLA descriptor, and this time
      pick out the bound from it: assign this value to TSTART.

 6.   TSTART is not actually a sensible bound: it is an offset within
      the shareable symbol tables (not even within the GLA at all!) which
      will lead you to a diagnostic record - or it's zero, if there are
      no such records.

 7.   If TSTART is zero - i.e., no more diagnostic records - then
      we must try the previous stack frame - which we find by going
      on to step 13.  Otherwise, we carry on with step 8.

 8.   Find the address of the shareable symbol tables (this is in
      the fourth word of the GLA) and add it to TSTART so that
      TSTART now points to a diagnostic record.

 9.   Locate the ONWORD within the diagnostic record: this is not
      trivial, since the word is word aligned within the record, but
      follows a variable length name string!

10.   Using the bit-mask convention described above, check whether
      the bit corresponding to EVENT is set in the ONWORD.  If
      it is, we have found an %ON %EVENT trap which is prepared
      to handle the event which has occurred, and we carry on at step
      15.  If not, then we carry on with step 11.
!PAGE

11.   If the name string in the diagnostic record (see step 9) is
      null, then we are simply dealing with a %BEGIN-%END block, and
      since IMP does not generate new stack frames for block entry,
      we simply pick up another diagnostic record: this is found by
      picking up a link from the short integer in the 7th. and 8th.
      bytes of the diagnostic record, assigning that to TSTART, and
      going back to step 7.

12.   If the name string was non-null, then we have been dealing with
      a routine, so we carry on to step 13 to try the previous stack
      frame.

13.   Locate the previous stack frame:
      set PREVLNB = LNB and LNB = INTEGER (LNB).

14.   Go back to step 2 to check whether it's a valid stack frame.
!PAGE

15.   We have found an %ON %EVENT trap which is prepared to handle
      the event.  Build a double word of information about the event
      containing EVENT in the top 24 bits, SUBEVENT in the next 8
      bits, and the line number (extracted from the stack frame, using 
      the offset held in the half integer in the third and fourth words of
      the diagnostic record) in the bottom word.

16.   Abandon one level of SIGNAL trap (i.e., decrement SIGLEVEL by
      calling SIGNAL(1,0,0,I)).  This is alleged to be because NDIAG
      planted a SIGNAL trap before calling ONCOND.

17.   LNB now points to the stack frame for the level which set the
      trap.  PREVLNB points to the stack frame called immediately from
      that stack frame, or to the stack frame for NDIAG if the trap
      was set at the outermost level of the 'user program' or command.
!PAGE

18.   Set ACTIVE = 0.  This variable is used by NDIAG to detect whether
      diagnostics are in progress when an event is signalled, and this
      is associated with the testing for INTERRUPT DURING DIAGNOSTICS.

19.   Fiddle the stack frame indicated by PREVLNB and EXIT so that
      we resume execution:
         at the code address located via ONWORD (whose bottom 18
         bits are an offset within the GLA of a word which contains
         the address of the ON code);

         with ACS=2 and the double word describing the event in the
         accumulator;

         with LNB correct for the level which set the trap;

         and with SF also correct (but if the trap was set at the level
         at which the interrupt occurred, then SF would include everything
         up to, but not including, the call of ONCOND - in particular,
         it would include the stack frames for DIRTRAP, SIGNAL and NDIAG!).
!>
!< Data
Data used by this mechanism:
!< Stack frame
1. Stack frame, located via LNB.
        Word 0: pointer to previous tack frame.
        Words 1 and 2: return link (code descriptor)
        Word 3: first word of GLA descriptor.  The bound (bits 8-31
                of this word) is actually an offset within the
                shareable symbol table, pointing to a diagnostic
                record.
        Word 4: address of GLA.
          .
          .
        Word n: line number.  n can be found from the diagnostic
                record (defined below), and when there is no line
                number, n will be given as zero.
!>
!< GLA
2. GLA, located via word 4 of stack frame.
        Words 0 to 2: ....
        Word 3: address of shareable symbol tables.
        Word 4: most significant byte is the language code.
          .
          .
        Word j: address in code at which to resume processing when a
                'trapped' event occurs: j is found from ONWORD in the
                diagnostic record.
!>
!< Diagnostic record
3. Diagnostic record, found via word 3 of the stack frame and word 3
   of the GLA.
        Word 0: less significant half-word is the offset in the
                stack frame for the line number word (or zero if there
                is no line number word).
        Word 1: less significant half-word is the offset in the
                unshareable symbol table for another diagnostic record -
                i.e., this is the link to the next record.
        Word 2: not used in this code.
        Words 3 onwards: a name string, with the length byte in the
                most significant byte of word 3, and the remainder
                of the last word (if any) unused.  If there is no
                name, then Word 3 is zero.
        Word i (the word immediately after the last word occupied by
                the name): ONWORD, in which bits 0-13 are a mask indicating
                which events can be accepted, and bits 14-31 are an
                offset within the GLA of a word containing the address of
                the code at which to resume processing when the event
                occurs.
!>
!< Event INFO
4. Double word INFO - describing an event.
        Word 0: bits 0-23, event number.
                bits 24-31, subevent number.
        Word 1: line number of source code (or zero).
!>
!>
!>
!<Processing an event.
!< Environment
The common situation when a program or command is running is this:

Subsystem has nominated DIRTRAP to Director by a call on PRIME CONTINGENCY.
It has also nominated SSINHIBIT and SSINTCOUNT by a call on DASYNCINH.
SSINHIBIT is zero.

Two 'SIGNAL' traps have been laid down.

The first (outer) level is laid down very early in routine CONTROL in
module CONT. It transfers control to label CONTIN in that routine, where
there is code to cope with INT:W,X,Y,A and C.  If any other event arrives
here, it is treated as "SUBSYSTEM FAULT = CLASS, SUBCLASS".

The second (inner) level is laid down either in routine BCI (in module
CONT), or in routine ENTER ON USER STACK (in module LOAD).  In each case,
this trap takes us to the label FAIL in the routine which set the trap,
where the following sequence occurs:
      *ST_DESCR0               [DESCR0 and DESCR1 are consecutive words]
      NDIAG (INTEGER(DESCR1+16), INTEGER(DESCR1+8), 10, INTEGER(DESCR1))
!>
!< Action
When Director is activated to handle some event, it initiates a call on
DIRTRAP, on the same stack where the process was working when the event
occurred.  DIRTRAP uses READID to get 18 words of interrupt data, and, in
most cases, stores it in the appropriate SIGDATA record and calls SIGNAL
(again, on the same stack).  SIGNAL prefixes the 18 words with two more -
the class and subclass - and then uses DRESUME to resume execution at one
or other of the 'SIGNAL traps'.  In the more common (and the more
interesting) case, control arrives at the label FAIL in BCI or in
ENTER ON USER STACK, with:
  - LNB pointing to the appropriate stack frame, so that the
 code can find its variables, and
  - the address of twenty words of information in the accumulator
 (actually in the bottom half of the accumulator, since DRESUME
 takes its third parameter, expands it into a descriptor, and
 loads it into the accumulator before passing control to the
 nominated address).
!PAGE

The twenty words are:
    1:   Class
    2:   Subclass
    3:   SSN/LNB
    4:   PSR
    5:   PC
    6:   SSR
    7:   SSN/SF
    8:   IT
    9:   IC
   10:   CTB
   11:   XNB
   12:   B
   13 and 14: DR
   15 to 18: Accumulator
   19:   FPC (for PE only)
   20:   ?
!PAGE

When control arrives at the label FAIL, the first action is to store
the accumulator, i.e., a descriptor pointing to this twenty-word
area, and then, using the second word of the stored descriptor to
locate the data, NDIAG is called with parameters which are -
   the PC at the time of the interrupt;
   the LNB at the time of the interrupt;
   the value 10;
   the class of the interrupt.

NDIAG starts by laying down a new SIGNAL trap in case of further
problems arising during the printing of diagnostics, and also
increments ACTIVE.  Then it starts to unravel the stack frames of the
interrupted process.  It has checks for stack frames which are totally
implausible - that is, incompatible with the 2900 architecture; for
frames which do not conform to EMAS standards (generated by 'odd'
languages, perhaps); and for frames indicating GLAs in public segments,
corresponding to local controller.  For stack frames which pass all these
tests, it extracts the language flag from the indicated GLA, and then
goes through a fairly complicated bit of code to convert the 'class'
(passed in to NDIAG as a parameter) into an 'event' and 'subevent'.
For IMP code, it then calls ONCOND, passing the parameters EVENT,
SUBEVENT and LNB.

ONCOND then works its own way back down the stack frames, looking for an
%ON %EVENT trap.  If there is none, ONCOND simply returns to NDIAG
which goes on to print the diagnostics.  But if a trap is found, then
ONCOND constructs a double-word of information about the event and
passes control to the nominated place.
!>
!< Summary
To summarise, when an event occurs, control passes through the following
bits of code:
    Director;
    routine DIRTRAP;
    routine SIGNAL;
    one of the SIGNAL traps;
    routine NDIAG;
    routine ONCOND;
    some event trap -
    or, if there is none, control returns to NDIAG to print diagnostics.
!>
!>
!< Example of interrupt trapping
%systemroutinespec ndiag(%integer lnb,pc,fault,inf)
%systemroutinespec reroute contingency(%integer ep,class,
      %longinteger mask,%routine on trap,%integername flag)
%systemroutinespec signal(%integer ep,p1,p2,%integername flag)
%systemroutinespec console(%integer ep,%integername st,len)
%externalintegerfnspec readid(%integer adr18)
%externalroutinespec dstop(%integer reason)
%externalintegerfnspec dresume(%integer lnb,pc,adr18)
%externalintegerfnspec ddelay(%integer secs)
%externalstring(15)%fnspec interrupt

%constlonginteger mask=X'FFFFFFFFFFFFFFFF'{the lot}

%externalroutine test trap(%string(255)dummy)
%integer flag,counter
%string(15) multi int

%routine trap (%integer class,subclass)
%conststring(10)%array regs(1:18)="SSN/LNB","PSR    ","PC     ","SSR   ",
    "SSN/SF ","IT     ","IC     ","CTB    ","XNB    ","B      ","DR0    ",
    "DR1    ","ACC 0  ","ACC 1  ","ACC 2  ","ACC 3  ","FPC    ","?      "
%integer flag,adr18
%integerarray aa(1:18)

%if 'a'<=subclass<='z' %then subclass=subclass-'a'+'A'

%if 'W'<=subclass<='Y' %thenstart
   %if subclass#'Y' %thenstart;!cannot write if comms failure
      printstring("*** Fatal Interrupt ".tostring(subclass)." ***")
      newline
      printstring("*** Process stops")
      newline
   %finish
   flag=ddelay(2);!to give message time to get out
   signal(3,class,subclass,flag);!pass interrupt to subsystem
   dstop(100);!we should NEVER get here
%finishelsestart
   adr18=addr(aa(1))
   flag=readid(adr18)
   %if subclass='T' %then console(12,flag,flag) %and ->resume
   %if subclass='K' %then console( 7,flag,flag) %and ->resume
   %if subclass='C' %then console( 8,flag,flag) %and ->resume
   %if subclass='Q' %thenstart
       newline
       printstring("Registers at event:");newline
       %for flag=1,1,18 %cycle
           printstring(regs(flag)."  ");write(aa(flag),10);newline
       %repeat
       ->resume
   %finish
   printstring("*** Int:".tostring(subclass)." trapped and ignored")
   newline
   printstring("*** Use Int:stop to stop")
   newline
resume:
   flag=dresume(0,0,adr18);!go back to where we were
%finish
%end

reroute contingency(3,65,mask,trap,flag)
 !all interrupts of class 65 whose subclass is set in mask (0<=subclass<=63)
reroute contingency(2,65,mask,trap,flag)
 !all interrupts of class 65 whose subclass is set in mask (64<=subclass<=127)
 !a mask of X'0382000A0382000A' will trap A,C,Q,W,X,Y

%for counter=1,1,120 %cycle
   flag=ddelay(1)
   multi int=interrupt
   %if multi int="stop" %thenexit
   %if multi int#"" %start
       newline
       printstring("*** Multi Character Int:".multi int." inspected ")
       newline
       printstring("*** Use Int:stop to stop")
       newline
       printstring("*** Counter = ")
       write(counter,1)
       newline
   %finish
%repeat

reroute contingency(0,0,0,trap{dummy},flag)
 !to clear all nominated traps
 !without this the next event would be sent to the expected address and
 !find the object had been unloaded - disaster!

%end

%endoffile
!>
>>>>IODEMOS1<<<<
program iodemo(inp,output,infile,outfile);
type
    string15=packed array[1..15]of char;
    ptr31   =^string31;
    string31=packed array[0..31]of char;
var
    infile,outfile,inp:text;
procedure pprompt(s:string15);extern;
procedure define(k:integer;p:ptr31);extern;

procedure define_files;
var filename:string31;length:integer;first_try,ok:boolean;

function get_name(prompt:string15;var l:integer;var name:string31):boolean;
var ok:boolean;temp:integer;
begin
if first_try then begin pprompt(prompt);reset(inp);first_try:=false;end
             else begin pprompt(prompt);while inp^=' ' do get(inp);end;
for l:=0 to 31 do name[l]:=' ';
l:=1;
while (inp^<>' ') and not(eoln(inp)) and (l<29) do begin
      name[l]:=inp^;get(inp);l:=l+1;end;
for l:=l downto 1 do 
      if ('a'<=name[l])and(name[l]<='z')then 
           name[l]:=chr(ord(name[l])-ord('a')+ord('A'));
l:=31;while (name[l]=' ') and (l>0) do l:=l-1;
ok:=(l>0)and(inp^=' ');
if not ok and (l>0) then writeln('Invalid filename ',name);
if not ok then while (inp^<>' ') and not(eof(inp)) do get(inp);
get_name:=ok;
end;{of get_name}

procedure call_define(stream,length:integer;filename:string31);
const magic=402653312;
var p31:ptr31;i:integer;
begin
new(p31);p31^:=filename;
for i:=31 downto 2 do p31^[i]:=p31^[i-2];
p31^[2]:=',';
p31^[1]:=chr(stream+ord('0'));
writeln('Command:define ',p31^);
p31^[0]:=chr(length+2);
define(magic,p31);
dispose(p31);
end;{of call_define}

begin {define_files}
first_try:=true;
writeln('Please give the name of the input file to be used:');
for length:=0 to 31 do filename[length]:=' ';
filename[1]:='.';filename[2]:='I';filename[3]:='N';
call_define(1,3,filename);
repeat; ok:=get_name('Input file:    ',length,filename);until ok;
call_define(3,length,filename);
writeln('Please give the name of the output file to be used:');
repeat; ok:=get_name('Output file:   ',length,filename);until ok;
call_define(4,length,filename);
end;{ of define_files}

begin {main program}
writeln('This demonstration program shows how to avoid that "Data:" prompt');
writeln('that appears when you run a program. I askes for the names of two');
writeln('files and copies the input file to the output file               ');
writeln('File names must be no more than 29 characters long');
writeln;
define_files;
reset(infile);
rewrite(outfile);
while not eof(infile) do begin
   while not eoln(infile)do begin
      outfile^:=infile^;get(infile);put(outfile);
   end;
   writeln(outfile);
   if not eof(infile) then get(infile);
end;
end.
>>>>IODEMOS2<<<<
program iodemo(inp,output,infile,outfile);
type
    string15=packed array[1..15]of char;
    ptr63   =^string63;
    string63=packed array[0..63]of char;
    string31=packed array[1..31]of char;
var
    infile,outfile,inp:text;
procedure pprompt(s:string15);extern;
procedure pdefine(k:integer;p:ptr63);extern;

procedure define_files;
var filename:string31;length:integer;first_try,ok:boolean;

function get_name(prompt:string15;var l:integer;var name:string31):boolean;
var ok:boolean;temp:integer;
begin
if first_try then begin pprompt(prompt);reset(inp);first_try:=false;end
             else begin pprompt(prompt);while inp^=' ' do get(inp);end;
for l:=1 to 31 do name[l]:=' ';
l:=1;
while (inp^<>' ') and not(eoln(inp)) and (l<31) do begin
      name[l]:=inp^;get(inp);l:=l+1;end;
for l:=l downto 1 do 
      if ('a'<=name[l])and(name[l]<='z')then 
           name[l]:=chr(ord(name[l])-ord('a')+ord('A'));
l:=31;while (name[l]=' ') and (l>0) do l:=l-1;
ok:=(l>0)and(inp^=' ');
if not ok and (l>0) then writeln('Invalid filename ',name);
if not ok then while (inp^<>' ') and not(eof(inp)) do get(inp);
get_name:=ok;
end;{of get_name}

procedure call_pdefine(pas_len:integer;pas_file:string15;
                       emas_len:integer;emas_file:string31);
const magic=402653312;
var p63:ptr63;i,j:integer;param:string63;
begin
for i:=0 to 63 do param[i]:=' ';
for i:=1 to pas_len do param[i]:=pas_file[i];
param[i]:=',';j:=i;
for i:=1 to emas_len do param[i+j]:=emas_file[i];
{writeln('Command:pdefine',param);}
{writeln('len=',i+j-1:1);}
param[0]:=chr(i+j-1);
new(p63);
p63^:=param;
pdefine(magic,p63);
dispose(p63);
end;{of call_define}

begin {define_files}
first_try:=true;
writeln('Please give the name of the input file to be used:');
call_pdefine(3,'INP............',3,'.IN............................');
repeat; ok:=get_name('Input file:    ',length,filename);until ok;
call_pdefine(6,'INFILE.........',length,filename);
writeln('Please give the name of the output file to be used:');
repeat; ok:=get_name('Output file:   ',length,filename);until ok;
call_pdefine(7,'OUTFILE........',length,filename);
end;{ of define_files}

begin {main program}
writeln('This demonstration program shows how to avoid that "Data:" prompt');
writeln('that appears when you run a program. I askes for the names of two');
writeln('files and copies the input file to the output file               ');
writeln('File names must be no more than 31 characters long');
writeln;
define_files;
reset(infile);
rewrite(outfile);
while not eof(infile) do begin
   while not eoln(infile)do begin
      outfile^:=infile^;get(infile);put(outfile);
   end;
   writeln(outfile);
   if not eof(infile) then get(infile);
end;
end.
>>>>IODEMOS3<<<<
program iodemo(inp,output,infile,outfile);
type
    string15=packed array[1..15]of char;
    ptr63   =^string63;
    string63=packed array[0..63]of char;
    string31=packed array[1..31]of char;
var
    infile,outfile,inp:text;
procedure pprompt(s:string15);extern;
procedure pdefine(k:integer;p:ptr63);extern;

procedure define_files;
var filename:string31;length:integer;first_try,ok:boolean;

function get_name(prompt:string15;
                  var l:integer;
                  var name:string31;
                  write_to:boolean):boolean;
var ok:boolean;temp:integer;

function fnok(s:string31;write_to:boolean):boolean;
var i,dot,sub:integer;fail,ftype:packed array[0..4]of boolean;done:boolean;

function my_file(s:string31):boolean;
const
  userad=2359296;{str6}
type
  str6=packed array[0..6]of char;
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^str6)
         end;
  var peeker:cheat;me,owner:str6;i:integer;
  begin
     peeker.addr:=userad;
     me:=peeker.ptr^;
     owner[0]:=chr(6);
     for i:=1 to 6 do owner[i]:=s[i];
{     writeln('OWNER=',owner,'    ME=',me,'     result=',me=owner);            }
     my_file:=owner=me;
  end;


function alphabetical(ch:char):boolean;
begin
alphabetical:=((ord('A')<=ord(ch))and(ord(ch)<=ord('Z')));
end;

function alphanumeric(ch:char):boolean;
begin
alphanumeric:=((ord('0')<=ord(ch))and(ord(ch)<=ord('9')))or alphabetical(ch);
end;

begin
for i:=0 to 4 do begin ftype[i]:=false;fail[i]:=false; end;
dot:=0;sub:=0;
for i:=1 to 31 do if s[i]='.' then dot:=i;
for i:=31 downto 1 do if s[i]='_' then sub:=i;
fail[1]:=((dot<>0)and(dot<>7))or((sub<>0)and(dot+1>=sub));
if dot<>0 then if not fail[1] then for i:=1 to 6 do fail[1]:=fail[1] or not
                                        alphanumeric(s[i]);
ftype[1]:=not fail[1] and (dot<>0);
fail[0]:=fail[1];
if not fail[0] then begin
   i:=dot+1;fail[2]:=not alphabetical(s[i]);
   repeat
      i:=i+1;done:=(s[i]=' ')or(s[i]='_');
      fail[2]:=not (alphanumeric(s[i])or(s[i]='#')or done)or fail[2];
   until done or fail[2] or (i=dot+12);
   fail[2]:=fail[2] or not done;
end;
fail[0]:=fail[1] or fail[2];
if not fail[0] then begin
   ftype[3]:=sub<>0;
   if ftype[3] then begin
       i:=sub+1;
       fail[3]:=not alphabetical(s[i]);
{       repeat                                                                 }
{          done:=s[i]=' ';                                                     }
{          fail[3]:=NOT DONE AND(fail[3] or not (alphanumeric(s[i])));         }
{          i:=i+1;                                                             }
{       until done or fail[3] or (i=sub+12);                                   }
       while not (fail[3] or done or (i=sub+12))do begin
           i:=i+1;done:=s[i]=' ';
           fail[3]:=not done and not alphanumeric(s[i]);
       end;
       fail[3]:=fail[3] or not done;
    end;

end;
fail[0]:=fail[1] or fail[2] or fail[3];
if fail[0] then begin
    write('Invalid ');
    if fail[1] then write('username ') else
        if fail[2] then write('filename ') else
            if fail[3] then write('member name ');
    writeln(s);
end else begin
  if write_to then begin
      if ftype[1] and not my_file(s) then  begin
            writeln('Invalid access - you can''t write to another user''s file');
            fail[4]:=true;
       end else begin
           if ftype[3] then begin
    writeln('Invalid access - you can''t write to a partitioned file member ');
         fail[4]:=true;
            end;
       end;
    end;
end;
fnok:=not(fail[1] or fail[2] or fail[3] or fail[4]);
end;

begin
if first_try then begin pprompt(prompt);reset(inp);first_try:=false;end
             else begin pprompt(prompt);
end;
while inp^=' ' do get(inp);
for l:=1 to 31 do name[l]:=' ';
l:=1;
while (inp^<>' ') and not(eoln(inp)) and (l<31) do begin
      name[l]:=inp^;get(inp);l:=l+1;end;
for l:=l downto 1 do 
      if ('a'<=name[l])and(name[l]<='z')then 
           name[l]:=chr(ord(name[l])-ord('a')+ord('A'));
l:=31;while (name[l]=' ') and (l>0) do l:=l-1;
ok:=(l>0)and(inp^=' ');
if not ok and (l>0) then writeln('Invalid filename ',name);
if not ok then while (inp^<>' ') and not(eof(inp)) do get(inp);
get_name:=ok and fnok(name,write_to);
end;{of get_name}

procedure call_pdefine(pas_len:integer;pas_file:string15;
                       emas_len:integer;emas_file:string31);
const magic=402653312;
var p63:ptr63;i,j:integer;param:string63;
begin
for i:=0 to 63 do param[i]:=' ';
for i:=1 to pas_len do param[i]:=pas_file[i];
param[i]:=',';j:=i;
for i:=1 to emas_len do param[i+j]:=emas_file[i];
{writeln('Command:pdefine',param);}
{writeln('len=',i+j-1:1);}
param[0]:=chr(i+j-1);
new(p63);
p63^:=param;
pdefine(magic,p63);
dispose(p63);
end;{of call_define}

begin {define_files}
first_try:=true;
writeln('Please give the name of the input file to be used:');
call_pdefine(3,'INP............',3,'.IN............................');
repeat; ok:=get_name('Input file:    ',length,filename,false);until ok;
call_pdefine(6,'INFILE.........',length,filename);
writeln('Please give the name of the output file to be used:');
repeat; ok:=get_name('Output file:   ',length,filename,true);until ok;
call_pdefine(7,'OUTFILE........',length,filename);
end;{ of define_files}

begin {main program}
writeln('This demonstration program shows how to avoid that "Data:" prompt');
writeln('that appears when you run a program. I askes for the names of two');
writeln('files and copies the input file to the output file               ');
writeln('File names must be no more than 31 characters long');
writeln;
define_files;
reset(infile);
rewrite(outfile);
while not eof(infile) do begin
   while not eoln(infile)do begin
      outfile^:=infile^;get(infile);put(outfile);
   end;
   writeln(outfile);
   if not eof(infile) then get(infile);
end;
end.
>>>>IPROCS<<<<
%begin
%externalintegerfnspec DPROCS(%integername max,%integer adr)
%routine idprocs
%integer j,max,adr,l,k
%byteintegerarray plist(0:32*256)
%stringname user
   l=0
   max=256
   adr=addr(plist(0))
   j=dprocs(max,adr)
   %returnif j#0
   %cycle k=0,1,max-1
       user==string(addr(plist(32*k)))
       %unless user="" %start
           write(k,3)
           space
           printstring(user)
           l=l+1
           l=0 %and newline %if l=6
       %finish
   %repeat
   newline %unless l=0
%end

IDPROCS
%endofprogram
>>>>IPROCS2<<<<
%begin
%recordformat comf(%integerarray i1(1:25),%byteintegerarray b1(1:8),
                   %integerarray i2(1:9),%longinteger l1,
                   %integerarray i3(1:9),%integer MAXPROCS,
                   %integerarray i4(1:4),%integer PROCAAD)
%constrecord(comf)%name com=X'80000000'+48<<18
%integerfn VAL(%integer adr,len,rw,psr)
%integer inseg0,beyondseg0,seg0,seg0ad,dr0
  seg0=adr>>18
  %result=0 %unless 0<len<=32<<18
  %if psr=0 %start
     *LSS_(%LNB+1)
     *ST_PSR
  %finish
  %if seg0#(adr+len-1)>>18 %start
     seg0ad=seg0<<18
     inseg0=X'400000'-(adr-seg0ad)
     beyondseg0=len-inseg0
     %result=VAL(adr,inseg0,rw,psr)&VAL(adr+inseg0,beyondseg0,rw,psr)
  %finish
  dr0=x'18000000'!len
  *LDTB_DR0
  *LDA_ADR
  *VAL_PSR
  *JCC_8,<CCZER>
  *JCC_4,<CCONE>
  *JCC_2,<CCTWO>
  %result=0
CCZER:%result=1;!read&write OK
CCONE:%if rw=1 %thenresult=0 %elseresult=1;!read 0K but not write
CCTWO:%if rw=0 %thenresult=0 %elseresult=1;!write OK but not read
%end

%integerfn DPROCS(%integername max,%integer adr)
%systemroutinespec move(%integer len,from,to)
%integer ok
%constinteger entrylen=32
max=com_maxprocs
OK=val(com_procaad,max*entrylen,0,0)
%if OK#1 %start
   printstring("VALIDATE FAILS!")
   newline
   %stop
%finish
move(max*entrylen,com_procaad,adr)
%result=0
%end
%routine idprocs
%integer j,max,adr,l,k
%byteintegerarray plist(0:32*256)
%stringname user
   l=0
   max=256
   adr=addr(plist(0))
   j=dprocs(max,adr)
   %returnif j#0
   %cycle k=0,1,max-1
       user==string(addr(plist(32*k)))
       %unless user="" %start
           write(k,3)
           space
           printstring(user)
           l=l+1
           l=0 %and newline %if l=6
       %finish
   %repeat
   newline %unless l=0
%end

IDPROCS
%endofprogram
>>>>MEMOS<<<<
%external %routine %spec writeprofile(%string(11) key, %name info,
    %integer %name version, flag)
%external %routine %spec readprofile(%string(11) key, %name info,
    %integer %name version, flag)
%system %routine %spec setpar(%string(255) s)
%system %string(255) %fn %spec spar(%integer i)
%system %integer %fn %spec parmap
%system %integer %fn %spec pstoi(%string(255) s)
%system %string(255) %fn %spec substring(%string %name s, %integer i, j)
%external %routine %spec prompt(%string(255) s)
%external %integer %fn %spec uinfi(%integer i)
%external %string(255) %fn %spec ucstring(%string(255) s)
%system %string %fn %spec itos(%integer i)
%const %integer secsin24hrs = 86400; ! SECS IN DAY
%const %integer days70 = 25567; ! DAYS FROM JAN1 1900 TO JAN1 1970
%const %long %integer secs70 = x'0000000083AA7E80'; ! SECS DITTO
%const %string(1) snl = "
"
%const %integer maxmemos=10
%record %format proff(%integer %array after(1:maxmemos),
    %string(255) %array text(1:maxmemos))
%own %integer prof read=0
%own %record(proff) profile value
%const %string(11) profile key="BISH#MEMOS1"
%const %integer profile vsn=1
%own %integer vsn,flag


%integer %fn start of(%string(255) whole string, first part,
    %string(*) %name rest)
   %result = 0 %unless %c
      0 < length(first part) <= length(whole string) %and %c
      first part = substring(whole string, 1, length(first part))
   whole string -> (first part).rest
   %result = 1
%end; !OF START OF



%routine kdate(%integer %name d, m, y, %integer k)

!!    K IS DAYS SINCE 1ST JAN 1900
!!    RETURNS D, M, Y   2 DIGIT Y ONLY

!      %integer W
!      K=K+693902
   ! DAYS SINCE CEASARS BDAY
!      W=4*K-1
!      Y=W//146097
!      K=W-146097*Y
!      D=K//4
!      K=(4*D+3)//1461
!      D=4*D+3-1461*K
!      D=(D+4)//4
!      M=(5*D-3)//153
!      D=5*D-3-153*M
!      D=(D+5)//5
!      Y=K
   *lss_k; *iad_693902
   *imy_4; *isb_1; *imdv_146097
   *lss_ %tos; *idv_4; *imy_4; *iad_3
   *imdv_1461; *st_(y)
   *lss_ %tos; *iad_4; *idv_4
   *imy_5; *isb_3; *imdv_153
   *st_(m); *lss_ %tos
   *iad_5; *idv_5; *st_(d)
   %if m < 10 %then m = m + 3 %else m = m - 9 %and y = y + 1
!bish%if m<10 %then m=m+3 %elsestart
!bish   m=m-9
!bish   %if y=99 %then y=0 %else y=y+1
!bish%finish
%end; ! OF KDATE



%integer %fn current secs

!!    GIVES CURRENT DT IN NEW PACKED FORM

%const %long %integer mill = 1000000
   *rrtc_0; *ush_-1
   *shs_1; *ush_1
   *imdv_mill
   *isb_secs70; *stuh_ %b
!*OR_X'80000000'
   *exit_-64
%end



%routine decwrite2(%integer value, ad)

!!    WRITES VALUE AS TWO DECIMAL ISO DIGITS INTO AD AND AD+1

   *lss_value; *imdv_10
   *ush_8; *iad_ %tos; *iad_x'3030'
   *lda_ad; *ldtb_x'58000002'
   *st_(%dr )
%end; ! OF DECWRITE2



%string(19) %fn secs to dt(%integer p)

!!  Converts secs to a date/time string.

%integer h, m, at, d, mo, y, ad, secs
%string(9) dat
%string(8) tim
%string(19) all
%const %string(3) %array month(1:12) = %c
"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"
   at = addr(tim)
   tim = "00:00:00"
   *lss_p; *ush_1; *ush_-1
   *imdv_60; *imdv_60; *imdv_24
   *lss_ %tos; *st_h
   *lss_ %tos; *st_m
   *lss_ %tos; *st_secs
   decwrite2(h, at + 1)
   decwrite2(m, at + 4)
   decwrite2(secs, at + 7)
   ad = addr(dat)
   dat = "00 XXX 00"
   p = (p & x'7FFFFFFF') // secs in 24 hrs
   kdate(d, mo, y, p + days70)
   string(ad + 2) = " ".month(mo)
   decwrite2(d, ad + 1)
   decwrite2(y, ad + 8)
!%result = dat."  ".tim
   all = dat."  ".tim
   length(all) = 16; !get rid of seconds
   length(all) = 9 %if substring(all, 12, 16) = "00:00"; !get rid of null hours and mins
   %result = all
%end; !OF SECS TO DT



%integer %fn analyse dt after(%string(255) datestring)

!!  Analyses a string specifying when a message is to be delivered.
!!  This routine based on DEC-10 code

%integer msg day, msg month, msg year, msg minutes
   !RESULTS OF ANALYSIS
%integer pt, value, state, datestate, token, dateerror
%integer secs now, days now, d, m, y, i
%integer todays weekday, days from now
%switch action(0:5)
%switch subact(0:4)
%const %integer %array mnemonic time value(0:5) = %c
8*60,12*60,12*60,16*60,20*60,23*60+59
!!  Breakfast, lunch, noon, tea, dinner, midnight
%const %byte %integer %array monthlength(1:12) = %c
31,28,31,30,31,30,31,31,30,31,30,31


%routine dateparse

!!  Takes tokens from "datetoken" and tries to make sense of them

!!  Transition table for parsing numeric/mnemonic months
!!  States are across the top, syntactic classes are vertical
!!  Class:  0 = number, 1 = time(number), 2 = month

   %const %byte %integer %array datetab(0:5,0:2) = %c
  1, 2, 2, 2, 0, 5,
  4, 4, 4, 4, 5, 5,
  3, 2, 5, 5, 3, 5
! 0  1  2  3  4  5

!!  Action table for number/mnemonic date

   %const %byte %integer %array dateact(0:5,0:2) = %c
  1, 2, 3, 1, 5, 8,
  4, 4, 4, 4, 8, 8,
  6, 7, 8, 8, 7, 8
! 0  1  2  3  4  5

   %switch sw(0:8)
      ->sw(dateact(state, token))
sw(1):
      !A PLAIN NUMBER IS A DATE
      msg day = value
      ->sw(0)
sw(2):
      !SECOND NUMBER IS A MONTH
      msg month = value
      ->sw(0)
sw(3):
      !YEAR
      %if value > 99 %then msg year = value %else msg year = value + 1900
      ->sw(0)
sw(4):
      !HOURS
      msg minutes = value * 60
      ->sw(0)
sw(5):
      !MINUTES
      msg minutes = msg minutes + value
      ->sw(0)
sw(6):
      !MONTH ALONE SETS DAY TO 1
      msg day = 1
sw(7):
      !MONTH AFTER DAY JUSTS SETS MONTH
      msg month = value
      ->sw(0)
sw(8):
      !ERROR
      dateerror = 1
sw(0):
      !DO NOTHING
      state = datetab(state, token)
%end; !OF DATE PARSE



%integer %fn date token

!!  This routine returns the next token from the input string.
!!  Character classes:
!!       0 = space
!!       1 = A-Z
!!       2 = 0-9
!!       3 = (
!!       4 = )
!!       5 = : .
!!       6 = rest
!!       7 = end of string

   %const %byte %integer %array class(' ':'Z') = %c
0,6(7),3,4,6(4),5,6,2(10),5,6(6),1(26)

!!  In the state transition table, these character classes are across the
!!  top, the following states are vertical:
!!       0 = startup
!!       1 = scan till ")" or end
!!       2 = build keyword
!!       3 = build number
!!       4 = delete blanks

   %const %byte %integer %array dateparsenext(0:7,0:4) = %c
   0,  62,  62,   1,  63,  63,  63,  63,
   1,   2,   3,   1,   4,   1,   1,  63,
   1,   2,   1,   1,   1,   1,   1,   1,
   1,   1,   3,   1,   1,   1,   1,   1,
   4,  63,  63,  63,  63,  63,  63,  63
! sp  A-Z  0-9    (    )    :  rest  end

!!  Action table
   %const %byte %integer %array dateparseact(0:7,0:4) = %c
  0,   5,   5,   0,   5,   5,   5,   5,
  0,   1,   2,   0,   0,   0,   0,   5,
  6,   1,   6,   6,   6,   6,   6,   6,
  3,   3,   2,   3,   3,   4,   3,   3,
  0,   5,   5,   5,   5,   5,   5,   5
   %const %string(9) %array datekeyword(1:34) = %c
"JANUARY","FEBRUARY","MARCH","APRIL","MAY","JUNE","JULY",
"AUGUST","SEPTEMBER","OCTOBER","NOVEMBER","DECEMBER",
"SUNDAY","MONDAY","TUESDAY","WEDNESDAY","THURSDAY","FRIDAY","SATURDAY",
"TODAY","TOMORROW","WEEK","MONTH","YEAR",
"BREAKFAST","LUNCH","NOON","TEA","DINNER","MIDNIGHT",
"AFTER","SINCE","AT","NEXT"
   %integer cl, char, act, i
   %string(255) str, rest
   %switch sw(0:6)
      str = ""
      value = 0
      %cycle
         pt = pt + 1
         %if pt > length(datestring) %then cl = 7 %else %start
            char = charno(datestring, pt)
            %if ' ' <= char <= 'Z' %then cl = class(char) %else cl = 7
         %finish
         act = dateparseact(cl, datestate)
         datestate = dateparsenext(cl, datestate)
         ->sw(act)
sw(0):
         !DO NOTHING
         %continue
sw(1):
         !CONCATENATE CHAR
         str = str.tostring(char)
         %continue
sw(2):
         !BUILD DECIMAL NUMBER
         value = value * 10 + char - '0'
         %continue
sw(3):
         !RETURN NUMBER
         pt = pt - 1; !RESCAN CHAR
         %result = 0; !TOKEN = 0
sw(4):
         !RETURN TIME SPEC
         %result = 1
sw(5):
         !RETURN END OF DATE
         pt = pt - 1; !RESCAN CHAR
         %result =  - 1
sw(6):
         !STRING - DECODE IT
         pt = pt - 1; !RESCAN CHAR
         value =  - 1
         %for i = 34,  - 1, 1 %cycle
            %if start of(datekeyword(i), str, rest) = 1 %start
               %if value #  - 1 %then value =  - 2 %and %exit
               value = i
            %finish
         %repeat
         %if value < 0 %start
            %if value =  - 1 %then printstring("Unknown") %else %c
               printstring("Ambiguous")
            printstring(" date/time keyword: ".str.snl)
            dateerror =  - 1
         %finish %else %start
            %if value < 13 %then %result = 2; !MONTH NAME
            %if value < 20 %then value = value - 13 %and %result = 3
            !TODAYS WEEKDAY
            %if value < 25 %then value = value - 20 %and %result = 4
            !MNEMONICDATE
            %if value < 31 %then value = value - 25 %and %result = 5
            !MNEMONIC TIME
         %finish; !OTHERWISE NOISE
         value = 0
         str = ""
      %repeat
%end; !OF DATETOKEN


   datestring = "TODAY" %if datestring = "NOW" %or datestring = ""
   secs now = current secs
   days now = secs now // secs in 24 hrs
   kdate(d, m, y, days now + days70)
   y = y + 1900
   msg day = d
   msg year = y
   msg month = m
   msg minutes = 0
   state = 0
   datestate = 0
   dateerror = 0
   pt = 0
   todays weekday = (days now - 3) - ((days now - 3) // 7) * 7
   days from now = 0
   datestring <- "(".datestring.")"
   %cycle
      token = datetoken
      %if token =  - 1 %then %exit
      ->action(token)
action(0):
      !NUMBER
action(1):
      !TIME
action(2):
      !MONTH
      dateparse
      %continue
action(3):
      !TODAYS WEEKDAY
      days from now = value - todays weekday
      %if days from now <= 0 %then days from now = days from now + 7
      %continue
action(4):
      !MNEMONIC DATES
      ->subact(value)
subact(0):
      !TODAY
      %continue
subact(1):
      !TOMORROW
      days from now = 1
      %continue
subact(2):
      !NEXT WEEK
      days from now = 7 - todays weekday
      %continue
subact(3):
      !NEXT MONTH
      msg month = msg month + 1
      msg day = 1
      %if msg month > 12 %then msg month = 1 %and msg year = msg year + 1
      %continue
subact(4):
      !NEXT YEAR
      msg year = msg year + 1
      msg day = 1
      msg month = 1
      %continue
action(5):
      !MNEMONIC TIMES
      msg minutes = mnemonic time value(value)
   %repeat
   %if dateerror = 0 %and pt # length(datestring) %then dateerror = 1
   %if dateerror # 0 %start
      %if dateerror #  - 1 %then %c
         printstring("Faulty date/time specification".snl)
      %result =  - 1
   %finish
   %if msg minutes >= 24 * 60 %start
      printstring("Invalid time in date/time specification".snl)
      %result =  - 1
   %finish
   %if days from now = 0 %start
      %unless 0 < msg month <= 12 %start
         printstring("Invalid month in date specification".snl)
         %result =  - 1
      %finish
      i = monthlength(msg month)
      %if msg month = 2 %and msg year = (msg year >> 2) << 2 %then i = i + 1
      %unless 0 < msg day <= i %start
         printstring("Month has only ".itos(i)." days".snl)
         %result =  - 1
      %finish
      %if msg month > 2 %then msg month = msg month - 3 %else %c
         msg month = msg month + 9 %and msg year = msg year - 1
      i = 1461 * (msg year - 1900) // 4 + (153 * msg month + 2) %c
          // 5 + msg day + 58 - days70
      %result = i * secs in 24 hrs + msg minutes * 60
   %finish %else %start
      %if msg day # d %or msg month # m %or msg year # y %start
         printstring("Inconsistent date/time specification".snl)
         %result =  - 1
      %finish
      %result = (days now + days from now) * secs in 24 hrs + msg minutes * 60
   %finish
%end; !OF ANALYSE DT AFTER


%routine ps(%string(255) s)
%string(255) a, b
%integer width, i
   width = uinfi(15)
   a = s." "
   %cycle i = 1, 1, length(a)
      charno(a, i) = ' ' %if charno(a, i) = 10
   %repeat
start:
   %if length(a) > width %start
      %cycle i = width,  - 1, 1
         %exit %if charno(a, i) = ' '
      %repeat
      b = substring(a, 1, i - 1)
      a = substring(a, i + 1, length(a))
      printstring(b)
      newline
      ->start
   %finish %else %start
      printstring(a)
      newline
   %finish
%end

%routine memohelp(%integer i)
%const %integer maxhelps=5
%switch helpsw(1:maxhelps)
%integer j
   %if 1 <= i <= maxhelps %then j = i %else j = 1
   ->helpsw(j)
helpsw(1):
   ps("   The MEMO command allows you to store 10 short (up to 255 character)
memos for your future reference. Use ADDMEMO to insert them, DELMEMO to delete
them and MEMO to read them.")
   ps("   Each of these commands when followed by a question mark (?) will give
some information about their use.")
   ps("   Put the command MEMO in your startfile for easy reference to your memos")
   ps("   The command MEMO will only list the memos that require action unless
an asterisk is given as the parameter. MEMO * will list all your memos.")
   %return
helpsw(2):
   ps("   The command ADDMEMO can be used to add a memo of up to 255 characters
to your SS#PROFILE file. It should be called without parameters and will prompt
for the information it requires.")
   ps("   The message should be typed in response to the ""Text:"" prompt and
terminated with a tilde (~). When the message is typed out it will not recognise
any breaks in lines that you may have typed so do not rely on any particular
layout of the message.")
   ps("   If you try to type in more than 255 characters the excess will be
ignored and you will be told that this has happened.")
   ps("   You will be prompted for the time at which you want to be reminded
of the contents of the memo.")
helpsw(3):
   ps("   Possible responses are ""now"",""today"",""friday"",""next week"",
""June"",""next year"",""23/05/84"",""23.50"" etc. If you give no relpy the memo
will be noted for immediate action.")
   %return
helpsw(4):
   ps("   The command DELMEMO may be given either with no parameters or
parameters of one of the following types: a question mark (?), an asterisk (*),
or a list of numbers.")
   ps("   The question mark will signify that you want help and this text will
be printed, the numbers represent the numbers of the memos you want to delete,
and the asterisk that ALL memos are to be deleted.")
   ps("   If you do not know the numbers of the memos you want to delete then
give the command DELMEMO with no parameter and all memos currently stored
will be listed to your terminal. You will then be asked if there are any you
want to delete.")
helpsw(5):
   ps("Please reply ""y""(es) or ""n""(o). If you replied no then you will be
prompted for a list of the memo numbers to be deleted.")
   %return
%end


%integer %fn get time after
%string(255) s
%integer i, time now
   s = ""; i = 0
   time now = current secs
   prompt("When for:")
   %if nextsymbol # nl %start
      skipsymbol %while nextsymbol # nl
   %finish
   skipsymbol
   s = s.tostring(nextsymbol) %and skipsymbol %while nextsymbol # nl
   %if s="?" %then memohelp(3) %andresult=get time after
   s = ucstring(s)
   i = analyse dt after(s)
   i = time now %if i <= 0
   skipsymbol
   %if i > time now %then %c
      printstring("Memo set for action after :".secstodt(i)) %else %c
      printstring("Memo will not be delayed")
   newline
   %result = i
%end

%routine profile fail(%integername flag,%integer rw)
pprofile
!rw=1 if reading and 0 if writing profile
%conststring(12)%array prof function(0:1)="Writeprofile","Readprofile"
%switch failno(0:17)
%if 0#rw#1 %then ps("Profile fail routine passed bad param!!!") %andstop
%unless 0<=flag<=7 %start
      ps(prof function(rw)." fails with unknown flag ".itos(flag))
      ps("Contact advisory")
      %stop
%finish
->failno(flag+10*rw)
failno(0):
failno(10):
      !ie no error at all
      %return
failno(1):
      ps("File SS#PROFILE Created ")
      flag=0
      %return
failno(2):
      ps("Failed to create SS#PROFILE - information not stored")
      %return
failno(3):
failno(4):
      ps("Failed to access SS#PROFILE - information not stored")
      %return
failno(5):
      ps("SS#PROFILE is full - information not stored")
      %return
failno(6):
      ps("Attempt to store too large a record in SS#PROFILE ".  %c
         "- information not stored ")
      ps("Contact the writer of this program!!!!")
      %return
failno(7):
failno(17):
      ps("Attempt to access null key in SS#PROFILE ")
      ps("Contact the author of this program!!!!")
      %return
failno(8):
failno(9):
      !should have been caught already but just in case
      %return
failno(11):
failno(12):
      ps("Information in SS#PROFILE was wrong size!!!!!")
      ps("Contact the writer of this program!!!!")
      flag=0
      !because some information may be vaild!!!
      %return
failno(13):
      ps("SS#PROFILE does not exist - no information stored")
      %return
failno(14):
      !field not found !
      ps("Key not found in SS#PROFILE - no information stored")
      %return
failno(15):
      ps("SS#PROFILE has been corrupted and must be destroyed")
      %return
%end;!of profile fail

%external %routine addmemo(%string(255) s)
   setpar(s)
   %if parmap#0 %then memohelp(2)%andreturn
   read profile(profile key, profile value, vsn, flag)
!write(flag,1) %if flag#0;!@@ MUST GET BETTER REPORTING THAN THAT!!!
%integer i, j
   i = 1
   %while i < maxmemos + 1 %cycle
      %if profile value_after(i) = 0 %then %exit
      i = i + 1
   %repeat
   %if i > maxmemos %then %c
      printstring("MEMO Fails - memo file full") %and %return
   prompt("text:")
   j = 1
   s = ""
   printstring("Input text of memo, terminate with a ~ ")
   newline
   %while nextsymbol # '~' %and i < 255 %cycle
      s = s.tostring(nextsymbol)
      skipsymbol
      j = i + 1
   %repeat
   %if j = 255 %start
      printstring("Warning - memo too long - has been truncated")
      newline
   %finish
   skipsymbol
   profile value_after(i) = get time after
   profile value_text(i) = s
   write profile(profile key, profile value, vsn, flag)
   profile fail(flag,0)
   ps("Memo number ".itos(i)." inserted") %if flag=0
%end; !of addmemo



%external %routine memo(%string(255) s)
%integer i
   vsn = profile vsn
   %if s="?" %then memohelp(1) %andreturn
   read profile(profile key,profile value,vsn,flag)
   profile fail(flag,1)
   %returnunless flag=0
   prof read= 1
   %for i = 1, 1, maxmemos %cycle
      %if profile value_after(i) # 0 %start
         %if s = "*" %start
            printstring("Memo no:"); write(i, 1);
            printstring(" for action after ".secstodt(profile value_after(i)))
            newline
            ps(profile value_text(i))
            newline
         %finish %else %start
            %if profile value_after(i) <= current secs %start
               printch(7)
               printstring("**MEMO for ")
               printstring(secstodt(profilevalue_after(i)))
               newline
               ps(profile value_text(i))
               newline
            %finish
         %finish
      %finish
   %repeat
%end; !checkmemo



%external %routine delmemo(%string(255) s)
%integer delwanted, number to delete
%string(255) ss
   setpar(s)
   %if parmap = 0 %start
      memo("*")
      %returnunless flag=0
      printstring("Do you want to delete any of these ?")
      prompt("Yes/No?")
      newline
get answer:
      skipsymbol %while nextsymbol # 'y' %and nextsymbol # 'n' %c
          %and nextsymbol#'Y' %and nextsymbol#'N' %and nextsymbol#nl
      %if nextsymbol=nl %then memohelp(5) %and -> get answer
      delwanted = 0
      delwanted = 1 %if nextsymbol = 'Y' %or nextsymbol = 'y'
      skipsymbol %while nextsymbol # nl
      %return %if delwanted = 0
      prompt("Numbers of memos to delete:")
      skipsymbol
      s = ""
      %while nextsymbol # nl %cycle
         s = s.tostring(nextsymbol)
         skipsymbol
      %repeat
      setpar(s)
   %finish
again:
   ss = spar(0)
   %if ss="?" %start
      memohelp(4)
      %if prof read = 0 %thenreturnelse ->out
   %finish
   ->out %if ss = ""
   delmemo("1,2,3,4,5,6,7,8,9,10") %andreturn %if ss = "*"
   number to delete = pstoi(ss)
   %if %not 0 < number to delete <= maxmemos %start
      printstring("Invalid memo ".ss)
      newline
      ->again
   %finish
   readprofile(profile key, profile value, vsn, flag) %if prof read = 0
   profile fail(flag,1)
   %stopunless flag=0
   prof read = 1
   profile value_after(number to delete) = 0
   profile value_text(number to delete) = ""
   ->again
out:
   write profile(profile key, profile value, vsn, flag)
   profile fail(flag,0)
   %stopunless flag=0
%end; !getmemo



%end %of %file
>>>>NEWSNOOPS<<<<
%external %routine new snoop(%string (255) s)

   %record %format finff(%string (11) fname, %integer sp12, kbytes,
       %byte %integer arch, codes, cct, ownp, eep, use, codes2, ssbyte,
       flags, pool, dayno, sp31)
   %external %integer %function %spec dfsys(%string (6) user,
       %integer %name fsys)
   %external %integer %function %spec dsfi(%string (6) user, %integer fsys,
       type, set, addr)
   %external %integer %function %spec dfilenames(%string (6) user,
       %record (finff) %array %name inf, %integer %name fileno, maxrec,
       nfiles, %integer fsys, type)
   %external %string (15) %function %spec interrupt
   %system %string (255) %function %spec itos(%integer i)
   %system %routine %spec phex(%integer i)

   %own %integer found=0

   %string (255) %function itos2(%integer i)
      %string (255) s
      s = itos(i)
      s = " ".s %while length(s) < 2
      %result = s
   %end

   %routine ff(%string (6) user)
      %record (finff) %array finf(0:5)
      %integer fileno, maxrec, nfiles, flag, fsys, i, privs
      %string (31) surname
      fileno = 0
      maxrec = 5
      nfiles = 5
      fsys =  - 1
      privs = 0
      surname = ""
      flag = dfsys(user, fsys)
      %return %if flag # 0
      flag = dfilenames(user, finf, fileno, maxrec, nfiles, fsys, 0)
      %return %if maxrec <= 2
      flag = dsfi(user, fsys, 18, 0, addr(surname))
!      %return %if flag # 0
      %if flag = 0 %then flag = dsfi(user, fsys, 38, 0, addr(privs))
      found = found + 1
      %if found = 1 %then printstring("
USER       SURNAME                       FSYS     NFILES       PRIVS
")
      surname = surname." " %while length(surname) < 31
      printstring(user."   ".surname."  ".itos2(fsys)."        ".itos2(nfiles))
      %if privs # 0 %then spaces(5) %and phex(privs)
      newline
   %end

   %string (4) grp
   %string (6) user
   %string (2) no
   user <- interrupt
   %integer i
   grp <- s
   %if length(grp) # 4 %then printstring("invalid params") %and %return
   %for i = 0, 1, 99 %cycle
      no = itos2(i)
      no = "0".no %if length(no) < 2
      user = grp.no
      ff(user)
      %if interrupt # "" %then printstring("Snooping at ".user) %and newline
   %repeat
   %if found = 0 %then printstring("No") %else printstring(itos(found))
   %if found # 1 %then printstring(" users have") %else %c
      printstring(" user has")
   printstring(" permitted files to you from group ".grp)
   newline
%end

%end %of %file
>>>>NOTEL<<<<
Source: .IN         Compiled: 18/04/83   19.55.07
Object: T#O

Parms set: DEFAULTS



              ERCC. Imp80 Compiler Release 1 Version 12 Nov 82


  1023  3069
     1        %systemroutinespec to journal (%integer from,len)
     2        %externalroutine note (%string(255)s)
     3        s="
     4"       **** ".s."
     5"       "
     6        tojournal(addr(s)+1,length(s))
     7        %end
     8        %endoffile

     8 LINES ANALYSED IN    64 MSECS  -  SIZE=   214

CODE    448 BYTES      GLAP  56+ 0 BYTES      DIAG TABLES  72 BYTES
TOTAL   576 BYTES
       6 STATEMENTS COMPILED IN    95 MSECS


>>>>PAL<<<<
%source off
{!TITLE     Palindrome Finding Program                                         }
{                                                                              }
{      This program is designed for interactive terminal use. It takes a number}
{as input, reverses the digits, adds the two numbers together and tests the    }
{result to see if it is a palindrome. This process can be repeated until either}
{a palindrome is found or the capacity of the array holding the number is r    }
{reached.                                                                      }
{      Further documentation is contained withing the program.                 }
{      Due to the interactive nature of the program no input or output streams }
{should be defined.                                                            }
{                                                                              }
{                                                                              }

program pal(inp,output);

const
   progname   = 'PALINDROME PROGRAM     VERSION 18  ';
   sp         = ' ';
   maxlength  = 100;
   namelength = 30;

type
   ptr31=^string31;
   string31=packed array[1..31]of char;
   paramrec = record
      length:integer;
      data:packed array[1..17]of char
   end;
   numberelements = array[0..maxlength] of integer;
   longinteger = record
                    s          : integer;
                    d          : numberelements
                 end;
   namestring = array[0..namelength] of char;
   nametype   = record
                   s          : integer;
                   n          : namestring
                end;
   string15   = packed array[1..15] of char;

var
   inp                : text;
   printer,count      : integer;
   num        : longinteger;
   com        : char;
   just_starting,palfound,clockon,quit       : boolean;
   name       : nametype;

procedure pprompt(s:string15);
   extern;

procedure callmonitor;
begin
end;

procedure writename;

var
   i          : integer;

begin
   for i:=0 to name.s-1 do
      write(name.n[i]);
end;

procedure endfile;
begin
   writeln;
   writeln(chr(7),'INPUT TERMINATED BY END OF FILE CHARACTER !');
   writeln;
   write(chr(7),'I don''t know what you''ve done ');
   writename;
   writeln(' but you shouldn''t have!');
   writeln;
   writeln(chr(7),progname,' TERMINATING IMMEDIATELY');
   halt('arrrggghhh!!!!!! ');
end;

PROCEDURE pdefine(k:integer;addr:ptr31);extern;

PROCEDURE define_inp;
CONST
   magic = 402653440;
   paramstring=' INP,.IN                       ';
   paramlength=7;
VAR
   pdefstring:string31;
   pdefptr:ptr31;
   i:integer;
BEGIN
   new(pdefptr);
   pdefstring:=paramstring;
   pdefstring[1]:=chr(paramlength);
   pdefptr^:=pdefstring;
   pdefine(magic,pdefptr);
   dispose(pdefptr);
END;

procedure getname;

var
   ch         : char;
   toolong    : boolean;

begin
   pprompt('Your name:     ');
   if just_starting then begin
      define_inp;
      reset(inp);
      just_starting:=false;
   end else begin
      while not(eoln(inp)or eof(inp)) do get(inp);
      if not eof(inp) then get(inp);
   end;
   if EOF(INP) then
      endfile;
   with name do begin
      s := 0;
      while ((not (EOLN(INP) or EOF(INP))) and (s<namelength)) do begin
         if EOF(INP) then
            endfile
         else
            read(INP,ch);
         n[s] := ch;
         s := s+1;
      end;
      toolong := (s=namelength) and not EOLN(INP);
      if toolong then begin
         s := 0;
         writeln('That''s more than I can remember,');
      end;
   end;
   if name.s>0 then begin
      write('Pleased to meet you ');
      writename;
      writeln;
   end
   else begin
      writeln('I''ll just have to call you Sir');
      name.s := 3;
      name.n[0] := 'S';
      name.n[1] := 'i';
      name.n[2] := 'r';
   end;
   while not EOLN(INP) or EOF(INP) do
      read(INP,ch);
end;

procedure friendly(com:char);

type
   field      = 1..8;
   alfa2      = packed array[1..2] of char;
   alfa9      = packed array[1..9] of char;

var
   day,d,t          : alfa8;
   pm,st         : alfa2;
   mth        : alfa9;
   yr,mt,dy,hr,mn,sc         : integer;
   quittime   : boolean;
   ch         : char;

procedure conv(a:alfa8;f:field;var r:integer);
begin
   r := (ord(a[f])-ord('0'))*10+ord(a[f+1])-ord('0');
end;

procedure convert(d,t:alfa8;var yr,mt,dy,hr,mn,sc:integer);

var
   r          : integer;

begin
   conv(d,1,yr);
   conv(d,4,mt);
   conv(d,7,dy);
   conv(t,1,hr);
   conv(t,4,mn);
   conv(t,7,sc);
end;

procedure datend(var st:alfa2);

const
   s          = 'st';
   n          = 'nd';
   r          = 'rd';
   t          = 'th';

var
   dt         : integer;

begin
   dt := dy mod 10;
   case dt of
   1:
      st := s;
   2:
      st := n;
   3:
      st := r;
   4,5,6,7,8,9,0:
      st := t
   end;
end;

procedure month(var mth:alfa9);

const
   jan        = 'January  ';
   feb        = 'February ';
   mar        = 'March    ';
   apr        = 'April    ';
   may        = 'May      ';
   jun        = 'June     ';
   jul        = 'July     ';
   aug        = 'August   ';
   sep        = 'September';
   oct        = 'October  ';
   nov        = 'November ';
   dec        = 'December ';

begin
   case mt of
   1:
      mth := jan;
   2:
      mth := feb;
   3:
      mth := mar;
   4:
      mth := apr;
   5:
      mth := may;
   6:
      mth := jun;
   7:
      mth := jul;
   8:
      mth := aug;
   9:
      mth := sep;
   10:
      mth := oct;
   11:
      mth := nov;
   12:
      mth := dec
   end;
end;

procedure findday(var day:alfa8);

const
   sun        = '     Sun';
   mon        = '     Mon';
   tue        = '    Tues';
   wed        = '  Wednes';
   thu        = '   Thurs';
   fri        = '     Fri';
   sat        = '   Satur';

var
   i          : integer;

begin
   for i:=1 to 8 do
      day[i]:=' ';
   case mt of
   1,10:
      i := 1;
   5:
      i := 2;
   8:
      i := 3;
   2,3,11:
      i := 4;
   6:
      i := 5;
   9,12:
      i := 6;
   4,7:
      i := 0
   end;
   i := ((yr+(yr div 4))+i+dy)mod 7;
   case i of
   1:
      day := sun;
   2:
      day := mon;
   3:
      day := tue;
   4:
      day := wed;
   5:
      day := thu;
   6:
      day := fri;
   0:
      day := sat
   end;
end;

procedure antepost(var hr:integer;var pm:alfa2);

const
   a          = 'am';
   p          = 'pm';

begin
   if hr>=12 then
      pm := p
   else
      pm := a;
   hr := hr mod 12;
end;

procedure getvalues;
begin
   dateandtime(d,t);
   convert(d,t,yr,mt,dy,hr,mn,sc);
   datend(st);
   month(mth);
   findday(day);
   antepost(hr,pm);
end;

procedure writetime;
begin;
   getvalues;
   if mn<10 then
      write('It is now ',hr:2,':0',mn:1,' ',pm,' on',day,'day the ')
   else
      write('It is now ',hr:2,':',mn:2,' ',pm,' on',day,'day the ');
   write(dy:2,st,' of ',mth,' 19',yr:2);
   writeln;
end;

procedure welcome;
begin
   writeln;
   writeln(progname,'  IS RUNNING');
   writeln;
   writeln('Hi there human! Welcome to the wonderful world of palindromes!!!');
   writeln('My name''s Pal. What''s your name?');
   getname;
   writeln;
   writeln('This program is brought to you courtesy of Sirius Cybernetics ');
   writeln('Unlimited (Unlimited incompetence that is.)');
   writeln('                                          But enough about me.');
   writetime;
   writeln('I sure hope you enjoy this, I know I do!.  If you have any problems');
   writeln('just type the pleasantly reassuring word help!! and push the return');
   writeln('key.   You will then be able to read some fascinating information');
   writeln('about me, your friendly palindrome program.');
   writeln('You can call me "Pal" because I''m you''re pal! SHARE AND ENJOY!');
   writeln;
end;

procedure goodbye;
begin
   getvalues;
   writeln;
   writetime;
   writeln('and well, if you''ve got to go then I suppose you''ve got to go.');
   writeln('I hope it wasn''t anything I said.    SHARE AND ENJOY!.');
   writeln;
   writeln(progname,  '   IS TERMINATED ');
   writeln;
   write(' OCP Time = ',clock:7,'     ',d,'     ',t);
   write('  Goodbye ');
   writename;
   writeln('!');
end;
begin
   case com of
   'w':
      welcome;
   't':
      writetime;
   'q':
      goodbye
   end;
   writeln;
end;

procedure help;

var
   hc         : integer;
   ch         : char;
   quithelp   : boolean;

procedure helpintro;
begin
   writeln;
   writeln('pal>help>                  Help With Palindromes');
   writeln;
   write('It looks as if you need some help, ');
   writename;
   writeln;
   writeln('information is available on the following topics:');
   writeln;
   writeln('  0)General         1)Getstarter        2)Revadds ');
   writeln('  3)Quit            4)Help              5)Time   ');
   writeln('  6)Name            7)Printer           8)Clock');
   writeln;
   writeln;
   writeln('Type the number of the section you want to see and then <return>.');
   writeln;
   write('Type q then return to get back to the palindrome');
   write(' program where you left it.');
   writeln;
   writeln;
end;

procedure helpgeneral;
begin
   writeln;
   writeln('Pal>help>                    General                                    0');
   writeln;
   writeln('The purpose of the palindrome program is to:');
   writeln('            1)read a number');
   writeln('            2)reverse it');
   writeln('            3)add it to its reverse');
   writeln('            4)check if the result is a palindrome');
   writeln('            5)repeat steps 2-4 for a set number of times,');
   writeln('              stopping if a palindrome is reached.');
   writeln;
   writeln('A palindrome is a number that reads the same starting at either end.');
   writeln;
   writeln('eg)        123                          96');
   writeln('          +321                         +69');
   writeln('         ------                      ------');
   writeln('           444                         165');
   writeln('         ======                       +561');
   writeln('                                     ------');
   writeln('                                       726');
   writeln('                                      +627');
   writeln('                                     ------');
   writeln('                                      1353');
   writeln('                                     +3531');
   writeln('                                     ------');
   writeln('                                      4884');
   writeln('                                     ======');
   writeln;
   write('This program was developed as an exercise for');
   write(' Computer Science 1 in December 81.');
   writeln;
   writeln;
   write('It was designed for use by schoolchildren and');
   write(' should not "crash" when given');
   writeln;
   write('incorrect instructions. ("control-y" indicating');
   write(' end of input is one exception)');
   writeln;
   writeln;
   writeln('Any comments (or complaints) about its operation should be sent to ');
   write('Graham Rule (ECZU94) by the mail system or by');
   write(' post c/o 16 Chambers St,Edinburgh.');
   writeln;
   writeln;
end;

procedure helpgetstarter;
begin
   writeln;
   writeln('Pal>help>                   Getstarter                             1');
   writeln;
   write('The command "Getstarter" (or "g") followed by a space and a');
   write(' positive integer');
   writeln;
   write('of not more than',maxlength+1:4,' digits is needed to get');
   write(' the program working');
   writeln;
   writeln('on the starting number indicated.');
   writeln;
   write('This command must be followed by the command "Revadds"');
   write(' before the calculation');
   writeln;
   writeln('will be done.');
end;

procedure helprevadd;
begin
   writeln;
   writeln('Pal>help>                     Revadds                                2');
   writeln;
   writeln('This command or its abbreviation ("r") should be followed  by the number');
   writeln('of times which the computer is to reverse and add the number previously');
   writeln('put in with the command "getstarter".');
   writeln;
   writeln('The number must be a positive integer of not more than 9 digits.');
   write('Anything else after this command will result in an error message being');
   write(' displayed');
   writeln;
   writeln('(but will not affect the number put in with the command getstarter).');
   writeln;
   writeln('If, after a number of "revadds", a palindrome has not been found, putting');
   writeln('in a larger number will cause the system to continue.');
   writeln;
end;

procedure helpquit;
begin
   writeln;
   writeln('Pal>help>                     Quit                               3');
   writeln;
   writeln('The command "quit" (or "q") typed in response to the prompt "Pal>" will');
   writeln('cause the program to stop and the user will be returned to the');
   writeln(' "Command"level. ALL INFORMATION NOT ALREADY PRINTED OUT WILL BE LOST.');
   writeln;
   writeln('The same command typed in response to the prompt "Pal>help>" will');
   writeln('take the user back to where they were when they entered the "help"');
   writeln('system. (This will not effect information in the computer).');
   writeln;
end;

procedure helphelp;
begin
   writeln;
   writeln('Pal>help>                       Help                                4');
   write('The command "help" (or "h") or any invalid command will remove');
   write(' the user from the ');
   writeln;
   write('main palindrome program and give the first page of the');
   write(' "help" information.');
   writeln;
   writeln;
   writeln('To return to where you were in the program type "quit" now.');
   writeln('To get back to the top page (and index) type "top".');
   writeln;
end;

procedure helptime;
begin
   writeln;
   writeln('Pal>help>                    Time                                 5 ');
   writeln('This command (or "t") in response to the prompt "Pal>" will return ');
   writeln('the current date and time.');
   writeln;
   friendly('t');
   writeln;
end;

procedure helpname;
begin
   writeln;
   writeln('Pal>help>                    Name                              6');
   writeln;
   write('The command ''name'' (or ''n'') can be used in response to the prompt');
   writeln(' Pal> to');
   writeln(' change the name by which the user is known to the program.');
   writeln;
   write('The name must be no more than ',namelength:3,' characters long ');
   writeln('including spaces. If anything ');
   write('else is given the system will (chauvanist that it is) ');
   writeln('call the user "Sir"');
   writeln;
   write('You are identified as "');
   writename;
   writeln('" at the moment');
   writeln;
end;

procedure helpprinter;
begin
   writeln('Help info for printer not yet available');
end;

procedure helpclock;
begin
   writeln('Help info for clock not yet available');
end;

begin
   pprompt('Pal>help>      ');
   quithelp := false;
   helpintro;
   hc := -1;
   repeat
      readln(INP);
      while ((inp^=sp)and not EOF(INP)) do
         read(INP,ch);
      if not EOF(INP) then
         read(INP,ch)
      else
         endfile;
{***********}
      if (ch>='0')and(ch<='8')then
         hc := ord(ch)-ord('0')
      else if (ch='q')or(ch='Q') then
         hc := 999
      else
         hc := -1;
      if (ch='t')or(ch='T') then
         hc := -1;
      case hc of
      -1:
         helpintro;
      0:
         helpgeneral;
      1:
         helpgetstarter;
      2:
         helprevadd;
      3:
         helpquit;
      4:
         helphelp;
      5:
         helptime;
      6:
         helpname;
      7:
        helpprinter;
      8:
        helpclock;
      999:
         quithelp := true;
      end;
      while not EOLN(INP) or EOF(INP) do
         read(INP,ch);
      if EOF(INP) then
         endfile;
   until quithelp;
end;

procedure writenumber(var num:longinteger);

var
   i          : integer;

begin
   with num do begin
      for i:=0 to s-1 do begin
         write(d[i]:1);
         if ((i+1)mod 70)=0 then
            writeln;
      end;
      writeln;
   end;
end;

function pal(num:longinteger): boolean;

var
   r,l          : integer;
   p          : boolean;

begin
   with num do begin
      p := true;
      r := s-1;
      l := 0;
      while (r>l) and p do begin
         p := d[l]=d[r];
         r := r-1;
         l := l+1;
      end;
   end;
   pal := p;
end;

procedure add(var num:longinteger);

var
   i          : integer;
   tot        : longinteger;

begin
   for i:=0 to maxlength do
      tot.d[i]:=0;
   for i:=0 to num.s-1 do begin
      tot.d[maxlength-i] := num.d[i]+num.d[num.s-1-i];
      tot.s := num.s;
   end;
   with tot do begin
      for i:=maxlength downto 1 do begin
         d[i-1] := d[i-1]+d[i] div 10;
         d[i] := d[i] mod 10;
      end;
      s := maxlength+1;
      if d[0]=0 then
         repeat
            s := s-1;
            for i:=1 to maxlength do begin
               d[i-1] := d[i];
            end;
            d[maxlength] := -1;
         until d[0]<>0;
   end;
   num := tot;
end;

function digit: boolean;
begin;
   digit := (ord('0')<=ord(inp^))and((ord('9'))>=ord(inp^));
end;

procedure findtarget(var target:integer);

var
   ch         : char;
   int,length     : integer;
   fail       : boolean;

begin
   int := 0;
   length := 0;
   fail := false;
   while (not (digit or EOLN(INP))) and not EOF(INP) do
      read(INP,ch);
   if EOF(INP) then
      endfile;
   if ch='-' then
      fail := true;
   while digit and (length<=8) do begin
      int := int * 10;
      length := length+1;
      if not EOF(INP) then
         read(INP,ch)
      else
         endfile;
      int := int+ord(ch)-ord('0');
   end;
   if not (((inp^=sp) or EOLN(INP)) and (int>=0)) then
      fail := true;
   if fail then begin
      writeln('Look you vegetable!! No more than NINE DIGITS. O.K.??!',chr(7));
      writeln;
      while not(EOLN(INP) or EOF(INP)) do
         read(INP,ch);
      if EOF(INP) then
         endfile;
      target := -1;
   end
   else
      target := int;
end;

procedure revcount(var num:longinteger);

var
   t1,cl1,cl2,cl,target     : integer;

begin
   writeln;
   findtarget(target);;
   palfound := pal(num);
   if target>0 then
      if num.d[0]<1 then
         writeln(chr(7),'no starter yet')
   else begin
      if palfound then
         writeln(chr(7),'It already is a palindrome, you twit!')
      else if (num.d[0]>9) then
         writeln(chr(7),'I''ve already told you, my memory is full!')
      else if (count>=target) then
         writeln(chr(7),'I''ve already done it',count:5,' times!');
   end;
   cl1 := clock;
   t1 := count;
   while (not pal(num)) and (count<target) and (not (num.d[0]>=10)) do begin
      add(num);
      count := count+1;
      palfound := pal(num);
      if palfound or (num.d[0]>9)or(count mod printer=0)or(count=target) then begin
         write('after ',count:1,' revadds, the number is: ');
         writeln;
         writenumber(num);
         if palfound then begin
            writeln;
            writeln('Which is a palindrome!');
         end;
         if (num.d[0]>9) then
            writeln(chr(7),'The system has reached it''s capacity');
      end;
      cl2 := clock;
      cl := cl2-cl1;
      if (clockon and ((target=count) or palfound or (num.d[0]>9)))or palfound then
         writeln(count-t1:8,' revadds took ',cl:6,' milliseconds OCP time');
   end;
end;

procedure readnumber(var num:longinteger);

var
   ch         : char;
   i          : integer;
   fail       : boolean;

begin
   count := 0;
   fail := false;
   with num do begin
      while not(digit or EOLN(INP)) do
         read(INP,ch);
      s := 0;
      while digit and (s<maxlength+1) do begin
         if not EOF(INP) then
            read(INP,ch)
         else
            endfile;
         d[s] := ord(ch)-ord('0');
         s := s+1;
      end;
      for i:=s to maxlength do
         d[s]:=0;
   end;
   if not((inp^=sp) or EOLN(INP)) then
      fail := true;
   if fail then
      writeln(chr(7),' only integers of up to ',maxlength+1:3,' digits please ')
   else if num.s=0 then
      writeln(chr(7),'How about letting me know the starting number?')
   else begin
      writeln('starting number is:');
      writenumber(num);
      writeln;
   end;
   writeln;
   readln(INP);
end;

procedure changeclock;
begin
   clockon := not clockon;
   write('Whatever you say, ');
   writename;
   if clockon then
      write('.   The clock is now ON')
   else
      write('.   The clock is now OFF');
   writeln;
end;

procedure findprinter;
begin
   findtarget(printer);
   if printer<0 then
      printer := 1;
   if printer=0 then begin
      printer := maxint;
      write('The number will not be printed at all ');
   end
   else
      write('The number will be printed after every ',printer:4,' revadd(s) ');
   writename;
   writeln;
   writeln;
end;

procedure docommand(com:char);
begin
   case com of
   'g':
      readnumber(num);
   'r':
      revcount(num);
   't':
      friendly(com);
   'q':
      quit := true;
   'n':
      getname;
   'h':
      help;
   'p':
      findprinter;
   'c':
      changeclock;
   'm':
      callmonitor;
   end;
end;

procedure getcommand(var com:char);

var
   ch         : char;

begin
   pprompt('Pal>           ');
   while (inp^=sp) and (not EOF(INP)) do
      read(INP,ch);
   if not EOF(INP) then
      read(INP,ch)
   else
      endfile;
   if (ch='g')or(ch='G') then
      com := 'g'
   else if (ch='r')or(ch='R') then
      com := 'r'
   else if (ch='q')or(ch='Q') then
      com := 'q'
   else if (ch='t')or(ch='T') then
      com := 't'
   else if (ch='n')or(ch='N') then
      com := 'n'
   else if (ch='c')or(ch='C') then
      com := 'c'
   else if (ch='p')or(ch='P') then
      com := 'p'
   else if (ch='m')or(ch='M') then
      com := 'm'
   else
      com := 'h';
end;
begin
   quit := false;
   clockon := false;
   printer := 1;
   just_starting:=true;
   friendly('w');
   repeat
      getcommand(com);
      docommand(com);
   until quit;
   friendly('q');
end.
>>>>PASMONS<<<<
%external %routine pasmon
   %system %routine %spec ndiag(%integer pc, lnb, fault, inf)
   %integer pc, lnb
      printstring("PASCAL MONITOR ENTERED: THE PROGRAM HAS NOT CRASHED")
      newline
      *lss_(%lnb +2)
      *st_pc
      *stln_lnb
      ndiag(pc, lnb, 0, 0)
      newline
      printstring("PASCAL MONITOR COMPLETED: RETURN TO PROGRAM")
      newline
%end
%end %of %file
>>>>PASS<<<<

%constlonginteger password=987325576
%systemroutinespec phex(%integer i)
%externalstring(255)%fnspec interrupt
%externalroutinespec prompt(%string(255)p)
%externalroutinespec setmode(%string(255)s)
%integerfn encrypt(%longinteger n)
%longlongreal lr
%integer i
%constlonglongreal const=131719.0478125
%for i=1,1,6 %cycle
 lr=n
 lr=lr*const
 n=longinteger(addr(lr)+4);!middle 64 bits
%repeat
%result=integer(addr(n))
%end
%externalroutine privilege(%string(255)s)
%longinteger n
n=0
setmode("echo=off")
prompt("Pass:")
%while nextsymbol#nl %cycle
 n=n<<8+nextsymbol
 skipsymbol
%repeat
setmode("Echo=on")
n=encrypt(n)
%if n=password %then printstring("yes") %else printstring("no")
newline
printstring("encrypted=");write(n,30);newline
%end
%routine show string(%integer i)
%string(4)s
%integer b
s=""
%for b=0,1,3 %cycle
  %unless 32<=byteinteger(addr(i)+b*8)<=126 %start
       printstring(" contains unprintable characters")
       %return
   %finishelse s=s.tostring(byteinteger(addr(i)+b*8))
%repeat
printstring(s)
%stop
%end
%externalroutine findpass(%string(255)s)
%integer i
%for i=X'010101017',1,2147483647 %cycle
%if interrupt#"" %start
   write(i,1)
   printstring("  X'")
   phex(i)
   printstring("'")
   newline
%finish
   %if encrypt(i)=password %start
      printstring("Success!:")
      write(i,30)
      show string(i)
      newline
   %finish
%repeat
%end
%endoffile
>>>>PENVS<<<<
program uinf(output);
const
  userad=2359296;{str6}
  fsysad=2359343;{int}
  basefilead=2359420;{str31}
  scarcityad=2359484;{int}
  preemptad=2359488;{int}
  fundsad=2359504;{int}
  termad=2359564;{str63}
  secstocdad=-2134900564;{int}
  secsfrmnad=-2134900568;{int}
  datead=-2134900673;{int}
  timead=-2134900661;{int}
  usersad=-2134900648;{int}
  ocptypead=-2134900736;{int}
  tojdayad=-2134900680;{int}
  suplvnad=-2134900684;{int}
  rationad=-2134900604;{int}
type
  str6=packed array[0..6]of char;
  str31=packed array[0..31]of char;
  str63=packed array[0..63]of char;
var
  user:str6;
  basefile,supervisor:str31;
  term:str63;
  fsys,scarcity,preempt,funds:integer;
  users,secstocd,secsfrmn,ocptype,suplvn,ration:integer;

procedure peek_str6(var s:str6;address:integer);
  type 
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^str6)
         end;
  var peeker:cheat;
  begin
     peeker.addr:=address;
     s:=peeker.ptr^;
  end;

procedure write_str6(s:str6);
  var i,j:integer;
  begin
    i:=ord(s[0]);
    for j:=1 to i do write(s[j]);
  end;

procedure peek_str31(var s:str31;address:integer);
  type 
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^str31)
         end;
  var peeker:cheat;
  begin
     peeker.addr:=address;
     s:=peeker.ptr^;
  end;
procedure write_str31(s:str31);
  var i,j:integer;
  begin
    i:=ord(s[0]);
    for j:=1 to i do write(s[j]);
  end;

procedure peek_str63(var s:str63;address:integer);
  type 
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^str63)
         end;
  var peeker:cheat;
  begin
     peeker.addr:=address;
     s:=peeker.ptr^;
  end;
procedure write_str63(s:str63);
  var i,j:integer;
  begin
    i:=ord(s[0]);
    for j:=1 to i do write(s[j]);
  end;

procedure peek_integer(var s:integer;address:integer);
  type 
     cheat=record
         dummyi:integer;
         case boolean of
            true:(addr:integer);
            false:(ptr:^integer)
         end;
  var peeker:cheat;
  begin
     peeker.addr:=address;
     s:=peeker.ptr^;
  end;

  
begin
peek_str6(user,userad);
write('You are:');
write_str6(user);
writeln;

peek_str63(term,termad);
write('You are at:');
write_str63(term);
writeln;

peek_str31(basefile,basefilead);
write('Your basefile is ');
write_str31(basefile);
writeln;

peek_integer(fsys,fsysad);
write('You are on file system ',fsys:1);
writeln;

peek_integer(funds,fundsad);
funds:=funds div 100;
writeln('You have ',funds:4,' pence funds left');

peek_integer(users,usersad);
writeln('There are ',users:1,' users at the moment');

peek_integer(secsfrmn,secsfrmnad);
writeln('It is ',secsfrmn:1,' secs from midnight');

peek_integer(secstocd,secstocdad);
if secstocd=0 then writeln('No closedown is planned at the moment')
              else writeln('Closedown in ',secstocd div 60,' minutes');

{peek_integer(suplvn,suplvnad);}
{peek_str31(supervisor,suplvn);}
{peek_str31(supervisor,suplvnad-1);}
{supervisor[0]:=chr(4);}
{write('EMAS Supervisor :');write_str31(supervisor);writeln}


end.
>>>>PREFACE<<<<
!TITLE UTILITIES FOR USE ON EMAS
>>>>PROC1<<<<
program processes(input,output);
const procaad=-2134900528;maxprocs=-2134900736;
type
      procf=packed record
            user:packed array[0..6] of char;
            incar,category,wsn,rung,active:char;
            actwo,lstat,lamtx,stack,status:integer
            end;
      plist_t=packed array [0..256] of procf;
      proc_p_t=record
               dummyp:integer;
               case boolean of
                  true:(paddr:integer);
                  false:(pval:^procf)
               end;
      integer_p_t=record
                  dummyi:integer;
                  case boolean of
                    true:(iaddr:integer);
                    false:(ival:^integer)
                  end;
var
      int_ptr:integer_p_t;
      proc_ptr:proc_p_t;
      process_list:plist_t;
      i,process_base,max,procno,nusers:integer;

begin
      for procno:= 0 to 256 do process_list[procno].user[0]:=chr(0);
      nusers:=0;
      int_ptr.iaddr:=procaad;
      process_base:=int_ptr.ival^;
writeln('Process base is at ',process_base:10);
      int_ptr.iaddr:=maxprocs;
      max:=int_ptr.ival^;
writeln('Maxprocs is        ',max:10);
{      for procno:= 0 to max-1 do begin}
procno:=0;
         proc_ptr.paddr:=process_base + 32 * procno;
         process_list[procno]:=proc_ptr.pval^;
{      end;}
writeln('array filled up');
      for procno:=0 to max-1 do begin
         if process_list[procno].user[0]=chr(6) then begin
            write('Process number:',procno:4,' is ');
            for i:= 1 to 6 do write(process_list[procno].user[i]);
            writeln;
         end;
      end;
end.
>>>>PRONAMES<<<<
%externalroutine proname(%string(255)user)
%record(%integer no,%string(6)%array user(1:25),%string(31)%array alias(1:25)) data
%integer vsn,flag,i
%externalroutinespec readprofile(%string(11)key,%name data,%integername vsn,flag)
vsn=0
readprofile("GWW",data,vsn,flag)
printstring("Flag=");write(flag,1);printstring("   Vsn=");write(vsn,1);newline
printstring("No=");write(data_no,1);newline
%for i=1,1,data_no  %cycle
  printstring(data_user(i));spaces(5);printstring(data_alias(i));newline
%repeat
%end
%endoffile
>>>>RETRIEVES<<<<
%externalroutine retrieve(%string(255)s)
%externalintegerfnspec dretrieve(%string(6)t,%integer c)
%systemroutinespec cast out (%string(255)%name s)
%systemintegerfnspec pstoi(%string(255)s)
%string(255)p1,p2
%string(6)t
%integer c,flag
cast out (s)
%unless s->p1.(",").p2 %start
   printstring("Bad param")
   newline
   %return
%finish
t<-p1
c=pstoi(p2)
flag=dretrieve(t,c)
printstring("RETRIEVE ".p1.",".p2." GIVES:")
write(flag,1)
%end
%endoffile
>>>>SNOOPS<<<<
%systemstring(255)%fnspec itos(%integer i)
%externalroutinespec files(%string(255)s)
%externalroutine snoop(%string(255)s)
%integer i
%string(4)u
u<-s
%for i=0,1,9 %cycle
printstring(u."0".itos(i).".".tostring(nl))
   files(u."0".itos(i).".")
%repeat
%for i=10,1,99 %cycle
printstring(u.itos(i).".".tostring(nl))
   files(u.itos(i).".")
%repeat
%end
%endoffile
>>>>SNOOPS<<<<
%conststring(1) snl="
"
%externalroutinespec files(%string(255)s)
%systemstring(31)%fnspec itos(%integer i)
%externalroutine snoop(%string(255)group)
%integer no
%string(2)nos
%if length(group)=6 %then files(group.".") %andreturn
%if length(group)<4 %then printstring("Invalid group".snl) %andreturn
%if length(group)=5 %start
    %for no=0,1,9 %cycle
       nos=itos(no)
       printstring("Command:files ".group.nos.".");newline
       files(group.nos.".")
    %repeat
%finishelsestart
    %for no=0,1,99 %cycle
       nos=itos(no);nos="0".nos %if no<10
       printstring("Command:files ".group.nos.".");newline
       files(group.nos.".")
    %repeat
%finish
%end
%endoffile
>>>>TESTSM<<<<
program testsm(output);
const out='Pascal test maps OK';
      magic = 402653440;
      fname=' 23,t#             ';
type  str19=packed array [1..19]of char;
      ptr19=^str19;
      ftype=packed array [1..711]of char;
      fptr=^ftype;
var   len:integer;
      mapper:fptr;
      smfile:ptr19;
procedure define(i:integer;stref:ptr19);extern;
procedure opensm(chan,mode:integer;var mapper:fptr;var len:integer);extern;
procedure closesm(chan:integer);extern;
begin
      new(smfile);
      smfile^:=fname;
      smfile^[1]:=chr(5);
      define(magic,smfile);
      opensm(23,1,mapper,len);
      writeln(len:5,' bytes of data accessed');
      writeln(mapper^);
{      mapper^:=out;}
      closesm(23);
end.
>>>>UINFFS<<<<
program uinffs(output);
const uinfstart=2359296;
type
      uinff=packed record
            user:packed array[0..6]of char;
            jobdocfile:packed array[0..31]of char;
            mark,fsys,procno,isuff,reason,batchid,
            sessiclim,scidensad,scidens,startcnsl,aiostat,sctdate,sync1dest,sync2dest,
            asyncdest,aacctrec,aicrevs:integer;
            jobname:packed array[0..15]of char;
            basefile:packed array[0..31]of char;
            previc,
            itaddr0,itaddr1,itaddr2,itaddr3,itaddr4,streamid,dident,scarcity,
            preemptat:integer;
            spoolrfile:packed array[0..11]of char;
            funds,sesslen,priority,decks,drives,partclose:integer;
            tmodes:packed array[1..20]of char{DUMMY FILLER!!!};
            pslot:integer;
            itaddr:packed array[0..63]of char;
            fclosing:packed array[0..3]of char;
            clofes,
            outputlimit,dapsecs:integer;
            dapinstrs:packed array[1..2]of integer{LONG INTEGER!!};
            out:integer;
            outname:packed array[0..15]of char;
            uend:integer
            end;
      uinf_p_t=record
               dummyp:integer;
               case boolean of
                  true:(paddr:integer);
                  false:(pval:^uinff)
               end;
var
      uinf_ptr:uinf_p_t;
      uinf:uinff;
      user:packed array[0..6]of char;
      i:integer;

begin
      uinf_ptr.paddr:=uinfstart;
      uinf:=uinf_ptr.pval^;
      user:=uinf.user;
      user[0]:=' ';
      with uinf do
      writeln('User:',user,'  Fsys: ',fsys:1,' Procno: ',procno:1);
end.
>>>>USER<<<<
program processes(output);
const uinfstart=2359296;ausers=-2134900645;
type
      uinff=packed array[0..6] of char;
      uinf_p_t=record
               dummyp:integer;
               case boolean of
                  true:(paddr:integer);
                  false:(pval:^uinff)
               end;
      int_p_t=record
              dummyi:integer;
              case boolean of
                  true:(iaddr:integer);
                  false:(ival:^integer)
              end;
var
      i:integer;
      int_ptr:int_p_t;
      uinf_ptr:uinf_p_t;
      user:uinff;

begin
      uinf_ptr.paddr:=uinfstart;
      user:=uinf_ptr.pval^;
      user[0]:=' ';
      writeln(user);
      int_ptr.iaddr:=ausers;
      i:=int_ptr.ival^;
      writeln('There are ',i:2,' users');
end.



































                                   1



>>>>USERSS<<<<
%EXTERNALROUTINE MYUSERS(%STRING(255)S)
%externalroutinespec printchs(%string(255)s)
%externalstring(31)%fnspec vdus(%integer i)
!%externalintegerfnspec fecount(%integername a, b)
%EXTERNALINTEGERFNSPEC DPROCEDURE(%INTEGER ACT, ADR)
%RECORDFORMAT RF1(%INTEGER N, A)
%RECORD(RF1) R1
%RECORDFORMAT PF(%STRING(6)USER, %STRING(15)TCP, %BYTEINTEGER A, INVOC, B, N, F,
      %INTEGER LOGS, %BYTEINTEGER site, reason, cons1, cons2, %c
       %INTEGER ID, PROC, G, H, Z)
%RECORD(PF)%ARRAY P(1:256)
%record (pf) %name pp
%INTEGER J, feusers,tcpusers, i, k, f, l, max
%integerarray fe(0:4)
%ownintegerarray index(0:255)

%string (24) t,u
%string(12)%array nam(1:50)
%ownintegerarray nuf(1:50)
%ownintegerarray nus(1:50)

      feusers=0;tcpusers=0
      %routine sort(%integer n)
         %integer flag, i, j, k
         %record (pf) %name s, t
         %cycle i = n-1, -1, 1
            flag = 0
            %cycle j = 1, 1, i
               s==p(index(j)); t == p(index(j+1))
!%if s_user> t_user %start
               %if s_tcp > t_tcp %start
                  k = index(j); index(j)=index(j+1); index(j+1)=k; flag=1
               %finish
            %repeat
            %exit %if flag = 0
         %repeat
      %end

printchs(vdus(1))
      index(i)=i %for i=0, 1, 255
!      j = fecount(feusers, tcpusers)
!      %if j # 0 %start
!         printstring("feuser count failed !
!")
!         %stop
!      %finish

feusers=0;tcpusers=0
      R1_A = ADDR(P(1))
      J = DPROCEDURE(1, ADDR(R1))
      %IF J = 0 %START
         max = r1_n
         printstring("Users ="); write(max-3, 1)
         newline
         k = 0

%if s = "TCP" %start
   nam(i) = "" %for i = 1, 1, 50
   k = 1
   %cycle i = 1, 1, max
      pp == p(i)
      t = pp_tcp
      %cycle j = 1, 1, k
         %if t = nam(j) %then %exit
      %repeat
      nus(j) = nus(j)+1
      %if j = k %start
         nam(j) = t; nuf(j) = pp_id>>16 &255
         k = k+1
      %finish
   %repeat

   j = 0
   %cycle l = 0, 1, 4
   %cycle i = 1, 1, k-1
      %if nuf(i) = l %start
         printstring(nam(i));  spaces(14-length(nam(i)))
         printstring("Fe"); printsymbol(nuf(i)+'0')
         write(nus(I), 3)
         j = j+1
         %if j = 3 %then newline %and j = 0 %else spaces(5)
      %finish
   %repeat
   %repeat
   %return
%finish

         sort(max)
         %cycle i = 1, 1, max
            pp == p(index(i))
            %if pp_reason = 2 %and i > 3 %start
               %cycle l = 1, 1, 4
                  charno(pp_user, l) = charno(pp_user, l) +'a'-'A'
        %if 'A'<=charno(pp_user,l)<='Z' %then charno(pp_user,l)=charno(pp_user,l)%c
-'A'+'a'
               %repeat
            %finish
            printstring(pp_user); space; printstring(pp_tcp)
            %if length(pp_tcp)>6 %start
               k = k+1
               %if k < 3 %then spaces(15)
            %finish %else %start
               spaces(6-length(pp_tcp))
               %if '0'<= pp_cons1 <= '9' %start
               printsymbol('+'); printsymbol(pp_cons1); printsymbol(pp_cons2)
               %finish %else spaces(3)
            %finish
            k = k+1; %if k >= 4 %then newline %and k = 0 %else spaces(2)
         %repeat
         newlines(2)
         %cycle i = 0, 1, 4; fe(i) = 0; %repeat
         %cycle i = 1, 1, r1_n
            f =  (p(i)_id>>16)&255
            fe(f) = fe(f)+1 %unless p(i)_tcp = "null"
         %repeat
         %cycle i = 0, 1, 4
            %if fe(i) # 0 %start
               printstring("Fep"); write(i, 1); write(fe(i), 3); newline
            %finish
         %repeat
         printstring(", No of fep users =")
         write(feusers, 1)
         printstring(", No of TCP users =")
         write(tcpusers, 1); newline
      %FINISH %ELSE %START
         PRINTSTRING("FLAG")
         WRITE(J, 1)
      %FINISH
%END
%end %of %file
>>>>USNAMES<<<<
%systemstring(31)%fnspec username(%string(6)u,%integer i)
%externalroutine name(%string(255) s)
%string(6)u
%if s = "" %thenreturn
u<-s
s=username(u,1)
%if s#"?" %then printstring(u." <==> ".s) %else printstring("Not known")
newline
%end
%endoffile
>>>>WHERE<<<<
%externalstring(63)%fnspec uinfs(%integer ep)
%systemstring(255)%fnspec itos(%integer i)
%systemstring(8)%fnspec htos(%integer i,places)
%externalroutine where(%string(255)dummy)
%string(63)terms
terms=uinfs(14)
%string(6) tcp
%string(8) hexC
%byteinteger C,N,T
N=charno(terms,1);T=charno(terms,2);C=charno(terms,3);
TCP=substring(terms,4,9)
hexC=htos(C,2)
printstring("You are on Console ".itos(c)." (X'".hexC."') on TCP ".TCP)
printstring(" network address N".itos(N)."T".itos(T))
newlines(2)
%end
%endoffile

>>>>XREFS<<<<
%EXTERNALROUTINE CROSSREF(%STRING(63)INPUT)
%CONSTINTEGER JOBNAMLEN=6,MAXDISP=15,MAXGLOB=255,MAXHASH=4095, %C
   MAXLINE=511,NAMLEN=8,OUTLINE=132,PAGESIZE=4096
%CONSTSTRING(23)VERSION="2.02 07/08/78  (MDB)"
%OWNSTRING(35)HEADER="* VARIABLE CROSS REFERENCE OF FILE "
%OWNSTRING(35)BLANK=""
%OWNSTRING(87)ASTK="*******************************************"
%INTEGER DATASTART,DEND,LENIN,M,MAXNAMES,MAXSTRINGS,MAXUSES
%STRING(31)DATETIME,MEMNAME,NAML,OUTPUT,VNAME
%EXTERNALROUTINESPEC DEFINE(%STRING(63)S)
%EXTERNALINTEGERFNSPEC SMADDR(%INTEGER N,%INTEGERNAME L)
%EXTERNALROUTINESPEC PROMPT(%STRING(15)S)
%EXTERNALSTRINGFNSPEC DATE
%EXTERNALSTRINGFNSPEC TIME
!*
%STRINGFN ITOSTR(%INTEGER I,M)
%STRING(1)SIGN
%STRING(63)S
M=0%IF M<0
%IF I<0%THEN SIGN="-"%AND I=IMOD(I)%ELSE SIGN=" "
S=""
S=TOSTRING(I-I//10*10+'0').S%AND I=I//10%UNTIL I=0
S=SIGN.S
S=" ".S%WHILE LENGTH(S)<=M
%RESULT=S
%END                                            ; ! of function 'ITOSTR'
!*
!*
!* MAIN PROGRAM NOW
!*
ASTK=ASTK.ASTK%AND BLANK="                                   " %C
   %IF BLANK=""
DATETIME=" ".DATE." ".TIME." *"
M=0
PRINTSTRING("CROSSREF VERSION ".VERSION."
")
PRINTSTRING("PARAMS ? : NO OUTPUT FILE
")%ANDRETURNUNLESS INPUT->INPUT.("/").OUTPUT%AND0<LENGTH(OUTPUT)<=NAMLEN
M=1%IF INPUT->INPUT.(",").NAML     ; ! IGNORE ACTUAL TEXT
NAML=INPUT
VNAME=""%UNLESS NAML->VNAME.(".").NAML
MEMNAME=""%UNLESS NAML->NAML.("_").MEMNAME
PRINTSTRING("INVALID PARAMETERS : ".INPUT."
") %ANDRETURNUNLESS0<LENGTH(NAML)<=NAMLEN%AND %C
   0<=LENGTH(MEMNAME)<=NAMLEN%AND(LENGTH(VNAME)=JOBNAMLEN%OR VNAME="")
NAML=VNAME.".".NAML%UNLESS VNAME=""
DEFINE("2,".INPUT)
DATASTART=SMADDR(2,DEND)
MAXNAMES=(INT(DEND/PAGESIZE)+5)*20
%IF M=1%THENSTART
PRINTSTRING("You have requested more than".ITOSTR(MAXNAMES,1). %C
   " name table entries
     (calculated from the size of ".INPUT.")
")
PROMPT("EXTRA=")
READ(M)
MAXNAMES=MAXNAMES+20     ; ! AN EXTRA PAGE WORTH ANY WAY
MAXNAMES=MAXNAMES+M-20%IF M>20
%FINISH
MAXUSES=6*MAXNAMES
MAXSTRINGS=8*MAXNAMES
PRINTSTRING("Maxima:- Names =".ITOSTR(MAXNAMES,1)."   Use of names =".%C
   ITOSTR(MAXUSES,1)."   Name string space =".ITOSTR(MAXSTRINGS,1)."
")
DEFINE("1,".OUTPUT)
SELECTOUTPUT(1)
LENIN=LENGTH(INPUT)
LENGTH(BLANK)=LENGTH(HEADER)-LENIN//2
LENGTH(ASTK)=LENGTH(HEADER)+LENGTH(DATETIME)+LENIN
NEWLINES(10)
PRINTSTRING(BLANK.ASTK."
"  .BLANK.HEADER.INPUT.DATETIME."
")
PRINTSTRING(BLANK.ASTK."





"  .BLANK. %C
   "Meanings of characters appended to names and line numbers:-

")
PRINTSTRING(BLANK."*   indicates a routine, function or map
"  .BLANK."!   indicates a record or recordarray format name
")
PRINTSTRING(BLANK. %C
   "A   means the variable is assigned a new value on this line
"  .BLANK."M   indicates multiple use of the variable on this line
")
PRINTSTRING(BLANK. %C
 "G   indicates the variable is global to the textual level at this line
")
!*
!* END OF INITIALISATION
!*
%BEGIN
%CONSTINTEGER MAXNLN=64,MAXVNAME=19,NCONDS=4,NDECLARS=17,NEXTS, %C
   NIGNORES=2,NPROCS,NSYMS=3,NUMLEN=4
%CONSTBYTEINTEGERARRAY SYMBOL(0:218)=0(48),8(10),0(7),7(26),0(4),7,0,
   7(26),0(70),3,2,6,3,1,0(2),3(2),0(2),3,0,3(2),0(2),3(2),5,0(6)
%CONSTBYTEINTEGERARRAY TYPE(0:127)=0(10),1,0(21),4,3,2,0,0,5,0,2,0(19),
   6,0(5),8(26),0(37)
%CONSTSTRING(1)%ARRAY NSYM(0:2)="A","M","G"
%OWNSTRING(27)GLOBMESS="    Global variables used ="
%OWNSTRING(255)ST
%OWNSTRING(6)%ARRAY CONDITION(1:4)="IF","UNLESS","UNTIL","WHILE"
%OWNSTRING(6)%ARRAY IGNORE(1:2)="FORMAT","SPEC"
%OWNSTRING(7)%ARRAY PROC(1:3)="ROUTINE","FN","MAP"
%OWNSTRING(7)%ARRAY DECLAR(1:17)="INTEGER","REAL","STRING","RECORD",
   "NAME","ROUTINE","ARRAY","BYTE","SHORT","HALF","LONG","OWN","CONST",
   "DYNAMIC","SYSTEM","SPEC","SWITCH"
%OWNSTRING(9)%ARRAY EXT(1:2)="EXTERNAL","EXTRINSIC"
%INTEGER AD,ASL,COLON,COMMA,COND,DDECL,DECL,DISP,DPTR,FORMATON,GASL, %C
   GLOBALUSE,GLOBS,GLMESSLEN,GLPERLINE,HASH,I,J,K,KEY,LASL,LAST,LEN, %C
   LENG,LK,LOCAL,LPOS,NAMAD,NASL,NEW,NUMBER,NUMPERLINE,NUMSTART,POS, %C
   PTRI,ROUT,ROUTON,S,SASL,START,STRNG,SYM,T,V
%STRING(19)GNAME
%STRING(63)KEYWORD,SS
%BYTEINTEGERARRAY ASTRING(0:MAXSTRINGS),LINE(-1:MAXLINE)
%INTEGERARRAY GLOBAL(0:MAXGLOB),HASHTAB(0:MAXHASH),PTR(1:MAXNAMES)
%BYTEINTEGERNAME LIST
%STRINGNAME NAMEST
%BYTEINTEGERARRAYNAME DATA
%BYTEINTEGERARRAYFORMAT F(1:DEND)
%RECORDFORMAT DSP(%INTEGER ADDR,LINE,SASL,GASL,LDEC)
%RECORDFORMAT NM(%STRINGNAME NAMEST,%BYTEINTEGER ROUT,DISP, %C
   %INTEGER HASH,LAST,LPTR)
%RECORDFORMAT LNO(%INTEGER LNUM,PTR,%BYTEINTEGER NUM)
%RECORDARRAY DISPLAY(0:MAXDISP)(DSP)
%RECORDARRAY NAME(1:MAXNAMES)(NM)
%RECORDARRAY LINENUM(1:MAXUSES)(LNO)
%RECORDNAME DISPL(DSP)
%RECORDNAME NAM(NM)
%RECORDNAME LN(LNO)
%SWITCH SYMB(0:7),SW(0:6)
!*
%ROUTINE CLOSE(%STRING(255)S)
%EXTERNALROUTINESPEC CLOSESM(%INTEGER N)
%EXTERNALROUTINESPEC CLEAR(%STRING(63)S)
PRINTSTRING(ST)
NEWPAGE
SELECTOUTPUT(0)
CLOSESTREAM(1)
PRINTSTRING(S."
")
CLOSESM(2)
CLEAR("1,2")
%END                                           ; ! of routine 'CLOSE'
!*
%ROUTINE OVERFLOW(%STRING(63)ST,%INTEGER MAX)
CLOSE(ST." on line".ITOSTR(NUMBER,1)." (max =".ITOSTR(MAX,1).")")
%MONITOR
%STOP
%END                                           ; ! of routine 'OVERFLOW'
!*
%ROUTINE GETKEYWORD
KEYWORD=""
I=POS
KEYWORD=KEYWORD.TOSTRING(LINE(I)!!128)%AND I=I+1%WHILE LINE(I)>128
LK=LENGTH(KEYWORD)
%END                                         ; ! of routine 'GETKEYWORD'
!*
%STRINGFN KEYEND(%STRINGARRAYNAME KEY,%INTEGER N)
%CYCLE I=1,1,N
%RESULT="YES"%IF KEYWORD->KEYWORD.(KEY(I)).SS%AND SS=""
%REPEAT
%RESULT="NO"
%END                                            ; ! of function 'KEYEND'
!*
%ROUTINE NPL(%INTEGER T,I)
%OWNINTEGER NLN                        ; ! NEWPAGE FIRST
PRINTSTRING(ST)
ST=""
%IF T>=NLN%THEN NEWPAGE%AND NLN=MAXNLN%ELSE NEWLINES(I)%AND NLN=NLN-I
%END                                           ; ! of routine 'NPL'
!*
%ROUTINE SORTPTRS(%INTEGER A,B)
%INTEGER I,J,K,L,N,PTRJ,PTRK
N=1
L=B-A+1
N=2*N%WHILE N<L
L=A-1
%WHILE N>1%CYCLE
N=N//2
I=L
%CYCLE
I=I+1
J=I+N
%EXITIF J>B
K=I
%UNTIL K<A%CYCLE
PTRJ=PTR(J)
PTRK=PTR(K)
%EXITIF NAME(PTRJ)_NAMEST>=NAME(PTRK)_NAMEST
PTR(J)=PTRK
PTR(K)=PTRJ
J=K
K=K-N
%REPEAT
%REPEAT
%REPEAT
%END                                           ; ! of routine 'SORTPTRS'
!*
%ROUTINE NEWAD
V=(V+97)&MAXHASH              ; ! 97 IS A LARGE PRIME NUMBER TO GET BIG 
                                ! GAP AND TOTAL COVERAGE OF HASH TABLE
AD=HASHTAB(V)
%END                                           ; ! of routine 'NEWAD'
!*
%STRINGFN SPACES(%INTEGER N)
%OWNSTRING(63)S= %C
   "                                                               "
LENGTH(S)=N
%RESULT=S
%END                                           ; ! of function 'SPACES'
!*
%STRINGFN KEYSTART(%STRINGARRAYNAME KEY,%INTEGER N)
%CYCLE I=1,1,N
%RESULT="YES"%IF KEYWORD->(KEY(I)).SS
%REPEAT
%RESULT="NO"
%END                                          ; ! of function 'KEYSTART'
!*
%ROUTINE INCRDISP                      ; ! INCREMENTING DISPLAY LEVEL
DISP=DISP+1
OVERFLOW("Display level overflow",MAXDISP)%IF DISP>MAXDISP
DISPL==DISPLAY(DISP)
DISPL_LDEC=ASL
DISPL_LINE=NUMBER
DISPL_ADDR=0
DISPL_SASL=SASL
DISPL_GASL=GASL
%END                                   ; ! of routine 'INCRDISP'
!*
DATA==ARRAY(DATASTART,F)
NUMSTART=1+MAXVNAME+NUMLEN
NUMPERLINE=(OUTLINE-MAXVNAME-1)//(1+NUMLEN+NSYMS)
GLMESSLEN=LENGTH(GLOBMESS)+1
GLPERLINE=(OUTLINE-GLMESSLEN)//(MAXVNAME+1)
%CYCLE I=1,1,MAXNAMES
NAM==NAME(I)
NAM=0
NAM_LAST=I+1
%REPEAT
%CYCLE I=1,1,MAXUSES
LN==LINENUM(I)
LN=0
LN_PTR=I+1
%REPEAT
%CYCLE I=0,1,MAXHASH
HASHTAB(I)=-1
%REPEAT
ASL=1
COLON=1
DPTR=1
LASL=1
NASL=1
SASL=1
DISP=0
GASL=0
NUMBER=0
STRNG=0
ASTRING(0)=0
DISPL==DISPLAY(0)
DISPL=0
DISPL_LINE=1
DISPL_LDEC=ASL
!*
!* START OF READING IN
!*
NEXTLINE:NUMBER=NUMBER+COLON
COLON=1
COMMA=3
LINE(-1)=0
LEN=0
LAST=0
SW(4):KEY=0                                  ; ! SPACE
NEXT:OVERFLOW("Input file complete",DEND)%IF DPTR>DEND
S=DATA(DPTR)&127                             ; ! NEXT CHARACTER
DPTR=DPTR+1
T=TYPE(S)
->SW(T&COMMA)%IF T=1%OR T=2
STR:KEY=0%IF T=0
->SW(T&7)%IF STRNG=0
->NEXT
SW(2):STRNG=S-STRNG%IF STRNG=0%OR STRNG=S       ; ! QUOTE, EITHER ' OR "
%IF STRNG=''''%AND LEN>0%THENSTART     ; ! FOR SPECIAL CONSTANTS
LEN=LEN-1%IF LAST='M'%OR LAST='X'%OR LAST='B'
%FINISH
KEY=0
SW(0):LAST=S+KEY                       ; ! ANY OTHER CHARACTER
%IF COMMA=3%THENSTART
LINE(LEN)=LAST
LEN=LEN+1
OVERFLOW("Input line too long",MAXLINE)%IF LEN>MAXLINE
%FINISH
->NEXT
SW(3):COMMA=1%IF LEN=0%OR LAST=':'           ; ! %COMMENT
T=0
->STR
SW(5):KEY=128                                ; ! PERCENT
->NEXT
SW(6):COLON=0                                ; ! SEMI-COLON
SW(1):%IF LAST='C'+128%THENSTART             ; ! NEWLINE
LEN=LEN-1
KEY=0
LAST=0
->NEXT
%FINISHELSE LINE(LEN)=0
!*
!* END OF READING IN
!*
LAST=0
ROUT=0
ROUTON=0
DDECL=0
DECL=0
FORMATON=0
POS=0
COND=0
LK=0
!*
!* START OF ANALYSIS
!*
SYMB(0):NEXTSYM:POS=POS+LK              ; ! ALL NON-SPECIAL CHARACTERS
->NEXTLINE%IF POS>=LEN
LK=1
SYM=LINE(POS)
T=SYMBOL(SYM)
%IF SYM>128%THENSTART
GETKEYWORD
COND=1%AND->NEXTSYM%IF KEYEND(CONDITION,NCONDS)="YES" 
        ! CONDITION STATEMENT
%FINISHELSE LAST=SYM
DECL=1%IF DDECL=1%AND SYM=','
->SYMB(T&7)
SYMB(6):->SYMB(3)%IF KEYWORD->("CONST").SS
LK=LEN-POS%IF KEYWORD="COMMENT"           ; ! %COMMENT
->NEXTSYM
SYMB(1):%IF KEYWORD="END"%OR KEYWORD="ENDOFPROGRAM"%OR %C
   KEYWORD="ENDOFFILE"%THENSTART
!*
!* START OF PRINT OUT
!*
START=DISPL_LDEC
I=DISPL_GASL
%IF GASL>I%THEN GLOBS=(GASL-I)//GLPERLINE+3%ELSE GLOBS=0
I=ASL-START+GLOBS+4
I=I+1%IF ASL=START
I=I+1%IF GLOBS>0
NPL(I,3)           ; ! CHECK HOW MANY LINES LEFT
I=DISPL_ADDR
%IF I=0%THEN ST=ST."BLOCK"%ELSE ST=ST."ROUTINE/FUNCTION/MAP ". %C
   NAME(I)_NAMEST
ST=ST." starting at line".ITOSTR(DISPL_LINE,1)." (textual level". %C
   ITOSTR(DISP,1).")"
NPL(0,1)
%IF ASL=START%THEN NPL(0,1)%AND ST=ST."    No local variables"%ELSESTART
ASL=ASL-1                                   ; ! STEP BACK TO LAST LOCAL
SORTPTRS(START,ASL)%IF START<ASL            ; ! IF ENOUGH
J=ASL
ASL=START
%CYCLE I=START,1,J                          ; ! THROUGH ALL THE LOCALS
PTRI=PTR(I)
NAM==NAME(PTRI)
%IF NAM_DISP=DISP%THENSTART         ; ! ACTUAL LOCAL NOT GLOBAL IMPLICIT
NPL(0,1)
NAMEST==NAM_NAMEST
ST=ST.TOSTRING(NAM_ROUT).NAMEST
SYM=NUMSTART-LENGTH(ST)
LENIN=0
LPOS=LINENUM(NAM_LPTR)_PTR                  ; ! FIRST LINE NUM RECORD
V=LPOS
%UNTIL LPOS=V%CYCLE
LN==LINENUM(LPOS)
NPL(-2,1)%AND LENIN=0%AND SYM=NUMSTART%IF LENIN=NUMPERLINE
         ! TAKE UP SLACK ON PAGE 
LENIN=LENIN+1
ST=ST.ITOSTR(LN_LNUM,SYM)
SYM=NUMLEN
%CYCLE K=0,1,NSYMS-1
%IF LN_NUM&(1<<K)>0%THEN ST=ST.NSYM(K)%ELSE SYM=SYM+1
%REPEAT
M=LN_PTR
LN_PTR=LASL                             ; ! RETURN TO ASL
LASL=LPOS
LPOS=M
%REPEAT
LPOS=NAM_LAST
NAM_LAST=NASL                           ; ! RETURN TO ASL
NASL=PTRI
V=NAM_HASH
AD=HASHTAB(V)
NEWAD%WHILE AD#PTRI                     ; ! REHASH
HASHTAB(V)=LPOS
%IF LPOS=-1%THENSTART                   ; ! FILL IN POSSIBLE HOLE
%CYCLE
NEWAD
%EXITIF AD=-1
HASH=NAME(AD)_HASH
LPOS=HASHTAB(HASH)
%WHILE LPOS#-1%AND HASH#V%CYCLE
HASH=(HASH+97)&MAXHASH
LPOS=HASHTAB(HASH)
%REPEAT
HASHTAB(HASH)=AD
HASHTAB(V)=LPOS
%REPEAT
%FINISH
%FINISHELSE PTR(ASL)=PTRI%AND ASL=ASL+1 ; ! RETURN TO LIST, AND PUT BACK
                                      ! IN AS THIS WAS A GLOBAL IMPLICIT
%REPEAT
SASL=DISPL_SASL%IF ASL=START
%FINISH                                 ; ! NO LOCAL VARIABLES
%IF GLOBS>0%THENSTART                   ; ! SOME GLOBALS
LENIN=0
NPL(0,2)
ST=ST.GLOBMESS
SYM=1
%CYCLE I=DISPL_GASL,1,GASL-1
NPL(-2,1)%AND LENIN=0%AND SYM=GLMESSLEN%IF LENIN=GLPERLINE
LENIN=LENIN+1
GNAME=NAME(GLOBAL(I))_NAMEST
ST=ST.SPACES(SYM).GNAME
SYM=MAXVNAME-LENGTH(GNAME)+1
%REPEAT
GASL=DISPL_GASL
%FINISH
!*
!* END OF PRINT OUT
!*
CLOSE("")%ANDSTOPIF DISP=0
LK=0%UNLESS KEYWORD="END"            ; ! 0 = RESET TO END FOR NEXT ROUND
DISP=DISP-1
DISPL==DISPLAY(DISP)
%FINISHELSESTART
->SYMB(3)%IF KEYSTART(EXT,NEXTS)="YES"
%FINISH
->NEXTSYM
SYMB(2):INCRDISP%AND->NEXTSYM%IF KEYWORD="BEGIN"      ; ! %BEGIN
SYMB(3):%IF T=1%OR T=6%OR KEYSTART(DECLAR,NDECLARS)="YES"%THENSTART
DDECL=1                                     ; ! DECLARATION OF VARIABLES
DECL=1
%IF ROUTON=0%THENSTART
%IF KEYEND(IGNORE,NIGNORES)="YES"%THENSTART
%IF IGNORE(I)="FORMAT"%THENSTART
%IF KEYWORD->("RECORD").SS%THENSTART
%IF SS=""%THEN FORMATON=1%ELSE FORMATON=-1
%FINISH
%FINISHELSE ROUT=2
%FINISH%ELSESTART
INCRDISP%AND ROUT=1%IF KEYEND(PROC,NPROCS)="YES"%AND KEYWORD#"SHORT"
%FINISH
ROUTON=ROUT
%FINISH
%FINISH
->NEXTSYM
SYMB(5):COND=0%IF KEYWORD->("THEN").SS         ; ! CONDITION COMPLETE
->NEXTSYM
!*
!* END OF KEYWORD ANALYSIS
!*
SYMB(7):LOCAL=0                           ; ! NAME FOUND
START=POS-1
LIST==LINE(START)
DECL=0%IF LIST='('%OR LIST=':'          ; ! KNOCK DOWN FLAG FOR SPECIALS
%IF FORMATON=2%AND DECL#0%THEN LAST='_'%AND V=LAST-'A'%AND LENG=1 %C
   %ELSE V=0%AND LENG=0
%WHILE T=7%OR T=8%CYCLE
POS=POS+1
I=SYM
SYM=LINE(POS)
T=SYMBOL(SYM)
%IF I='_'%THENSTART           ;  ! SUBNAMES ARE TREATED AS PART OF WHOLE
%EXITIF T#7                            ; ! AND MUST BE ALPHA
LOCAL=1%UNLESS LENG=0
%FINISH
LENG=LENG+1
V=V<<3+I-'A'
%REPEAT
NEW=0
LOCAL=1%IF SYM=':'%OR(LIST='<'%AND SYM='>')%OR %C
   (LIST='>'%AND LINE(START-1)='-'%AND LINE(START-2)#0%AND %C
   7#SYMBOL(LINE(START-2))#8)          ; ! LABEL, JUMP OR USERCODE LABEL
LENG=MAXVNAME%IF LENG>MAXVNAME
LIST=LENG                         ; ! ITOSTR IN LENGTH FOR USE BY STRING
VNAME=STRING(ADDR(LIST))           ; ! PICK UP DIRECTLY
VNAME="_".FROMSTRING(VNAME,1,LENGTH(VNAME)-1)%IF FORMATON=2
V=(V-LENG+LAST-'A')&MAXHASH        ; ! FINALISE HASH VALUE
HASH=V                             ; ! TAKE COPY FOR USE
AD=HASHTAB(V)                      ; ! FIRST ENTRY
%WHILE AD>=0%AND NAME(AD)_NAMEST#VNAME%CYCLE
NEWAD
OVERFLOW("Hash table overflow at ".VNAME,MAXNAMES)%IF HASH=V
%REPEAT
%IF AD=-1%THENSTART               ; ! UNUSED ENTRY - NEW, GET NAME ENTRY
M=SASL
SASL=LENG+1+SASL
OVERFLOW("Name string table overflow at ".VNAME,MAXSTRINGS)%IF %C
   SASL>MAXSTRINGS
NAMEST==STRING(ADDR(ASTRING(M)))       ; ! START ADDRESS OF NEW STRING
NAMEST=VNAME                           ; ! ENTER NEW NAME
NEW=1                                  ; ! SET FLAG
%FINISHELSESTART
NAM==NAME(AD)
M=NAM_DISP
%IF M#DISP%AND((ROUT=1%AND M#DISP-1)%OR(ROUT#1%AND DECL=1) %C
   %OR LOCAL=1)%THEN NAMEST==NAM_NAMEST%AND NEW=1%ELSE NAMAD=AD
    ! POSSIBLE NEW INCARNATION AT DIFFERENT LEVEL
%FINISH
GLOBALUSE=0
%IF NEW=1%THENSTART                       ; ! NEW NAME ENTRY TO ALLOCATE
OVERFLOW("Too many names at ".VNAME,MAXNAMES)%IF NASL>MAXNAMES
NAM==NAME(NASL)                        ; ! NEW ENTRY RECORD
HASHTAB(V)=NASL                        ; ! UPDATE HASH POINTER
NAMAD=NASL
PTR(ASL)=NASL                          ; ! UPDATE POINTER ARRAY
ASL=ASL+1                              ; ! NEXT ENTRY IN POINTER
NASL=NAM_LAST                          ; ! UNSTACK FREE ASL
NAM_LAST=AD                            ; ! COPY IN CHAIN FOR THIS NAME
NAM_NAMEST==NAMEST
NAM_HASH=HASH
NAM_ROUT='*'
%IF LOCAL=0=DECL%THEN I=0%ELSESTART
%IF ROUT=0%THENSTART
I=DISP
%IF IMOD(FORMATON)=1%THEN NAM_ROUT='!'%ELSE NAM_ROUT=' '
%FINISHELSE I=DISP+ROUT-2
! GETS CORRECT DISPLAY LEVEL VALUE
%FINISH
LPOS=LASL
NAM_DISP=I
%FINISHELSESTART
LN==LINENUM(NAM_LPTR)                  ; ! GET LAST USE RECORD
%IF LN_LNUM=NUMBER%THEN LN_NUM=LN_NUM!2%ELSESTART ; ! SET MULTIPLE FLAG
LPOS=LN_PTR                            ; ! SET LAST CHAIN RECORD
LN_PTR=LASL                            ; ! SET NEXT CHAIN RECORD
GLOBALUSE=4%IF0<=NAM_DISP<DISP%AND ROUT=0; ! NO ROUTINES OR PERM/EXTERNAL
NEW=1
%FINISH
%FINISH
DISPL_ADDR=NAMAD%AND DISPL_LDEC=ASL%AND DISPL_SASL=SASL%IF ROUT=1
         ! FILL IN DETAILS FOR START OF LAST LEVEL
%IF NEW=1%THENSTART                       ; ! NEW LINE ENTRY TO ALLOCATE
NAM_LPTR=LASL                    ; ! POINT TO CURRENT LINE NUMBER RECORD
OVERFLOW("Excessive useage of ".VNAME,MAXUSES)%IF LASL>MAXUSES
LN==LINENUM(LASL)
LASL=LN_PTR                            ; ! UNCHAIN ASL
LN=0
LN_LNUM=NUMBER
LN_PTR=LPOS                            ; ! FILL IN LAST CHAIN
%IF GLOBALUSE#0%THENSTART
LN_NUM=4                                  ; ! GLOBAL USE
J=DISPL_GASL
%IF GASL>=J%THENSTART
%CYCLE I=J,1,GASL
%IF I=GASL%THENSTART
OVERFLOW("Excessive global useage of ".VNAME,MAXGLOB)%IF GASL>MAXGLOB
GLOBAL(GASL)=NAMAD
GASL=GASL+1
%EXIT
%FINISH
%EXITIF GLOBAL(I)=NAMAD
%REPEAT
%FINISH
%FINISH
%FINISH
LN_NUM=LN_NUM!(1-COND)%IF(SYM='='%OR(SYM='<'%AND LINE(POS+1)='-'))
         ! SET ASSIGNMENT FLAG
%IF ROUT=2%AND KEYWORD#"RECORD"%THEN LK=LEN-POS%ELSE LK=0
         ! IGNORE SPEC NAMES 
FORMATON=2%IF FORMATON=1                ; ! MARK FORMAT PARAMETERS
ROUT=0
->NEXTSYM
!*
!*
%END                                          ; ! of inner block
%END                                     ; ! of routine 'CROSSREFERENCE'
%ENDOFFILE