$CONTROL USLINIT, MAP, CODE, MAIN = IDAT, SEGMENT = IDAT4               00005000
                                                                        00010000
comment                                                                 00015000
module idat                                                             00020000
                                                                        00025000
product information                                                     00030000
   product name, mnemonic, project number                               00035000
      idat is unsupported, but stars will accept service requests for it00040000
   project abstract                                                     00045000
      idat is an interactive dump analysis tool with a debug-like syntax00050000
   project personnel                                                    00055000
      idat belongs to the kse group and was originally written by       00060000
         bob mead                                                       00065000
      it has since been maintained at csy by                            00070000
         janet garcia                                                   00075000
         kathy leach                                                    00080000
         dan buckler                                                    00085000
         steve follmer                                                  00090000
         lou petrella                                                   00095000
         marie weston                                                   00100000
         larry byler                                           <<84228>>00105000
         bill o'shaughnessy                                    <<84627>>00110000
         harvey skinner                                        << hks >>00115000
         nelson hall                                           <<*nth*>>00120000
                                                                        00125000
general design overview                                                 00130000
the following files are needed to use idat:                             00135000
   idat      actual program                                             00140000
   idats     spl source for idat                                        00145000
   idathcat  raw help file                                              00150000
   idathelp  help file used by idat (run makecat on idathcat)           00155000
   idatug    tdp users guide                                            00160000
   docenvir  environment file for epocing idatug                        00165000
                                                                        00170000
   design approach                                                      00175000
   major modules                                                        00180000
   major data structures                                                00185000
   overall flow of data and control                                     00190000
   performance considerations                                           00195000
                                                                        00200000
module implementation                                                   00205000
   (for each module)                                                    00210000
   module name                                                          00215000
      brief description                                                 00220000
                                                                        00225000
global data structure implementation                                    00230000
   overall data structure relations                                     00235000
      narrative                                                         00240000
      maps of linkages                                                  00245000
                                                                        00250000
   (for each data structure)                                            00255000
   data structure name                                                  00260000
      purpose                                                           00265000
      creation and dispostion                                           00270000
      access methods                                                    00275000
      users                                                             00280000
      data layout and description                                       00285000
      storage management                                                00290000
      subordinate data structures                                       00295000
                                                                        00300000
fix history                                                             00305000
    29oct82   format current stack correctly                            00310000
              enforce use of core to ensure clean corebuf               00315000
    30dec82   change welcome message                                    00320000
              permit 'help' instead of just 'h'                         00325000
              install this template                                     00330000
    31jan83   fix "SAME AS ABOVE" message                               00335000
              check stacks for delta q = 0                              00340000
              handle series 2/3 dumps properly                          00345000
              use procinfo to look for idathelp file                    00350000
              released to field                                         00355000
    18mar83   fix make all commands invariant of spaces                 00360000
    20apr83   negative offset register addressing fixed.                00365000
              precedence of arithmetic operators redefined.             00370000
              leading blank suppression code removed from ci.           00375000
              "INCOMPLETE DUMP" message is now used correctly.          00380000
              idathelp can be found from other groups/accounts.         00385000
    06may83   addressing the top half of a bank works correctly.        00390000
    28feb84   duplicate lines on octal/integer/ascii displays  <<84228>>00395000
              are now handled correctly.                       <<84228>>00400000
              null commands are not errors any more.           <<84228>>00405000
              stkdst assignment in prt'stk now uses mpev/e     <<84228>>00410000
              subfield [(2:14), was (1:10)].                   <<84228>>00415000
    01mar84   saved almost 2048 words of code in fmtsir by     <<84301>>00420000
              changing initialization of impdrs and hldrs'impd.<<84301>>00425000
              streamlined similar code in several other areas. <<84301>>00430000
              fixed statements in chk'for'deadlocks and fmtsir <<84301>>00435000
              which obtained locsir (assumed that sir dst      <<84301>>00440000
              always lives in bank 0).                         <<84301>>00445000
    02mar84   subroutine get'seriesii'context of textfile now  <<84302>>00450000
              checks for texting from tape (required).         <<84302>>00455000
              printerror message length calculation simplified <<84302>>00460000
    11mar84   textfile improved, got rid of specified file is  <<84311>>00465000
              not a memory dump, fixed new'text to indicate    <<84311>>00470000
              correct condition of idat, cleaned up some bugs  <<84311>>00475000
              in error exits, other minor fixups.              <<84311>>00480000
    26mar84   help now tries to open idathelp as follows:      <<84326>>00485000
              1.  in the group.acct idat runs in,              <<84326>>00490000
              2.  in the logon group.acct (modified by any     <<84326>>00495000
                  :file idathelp = ...),                       <<84326>>00500000
              3.  idathelp.idat.kse (last resort).             <<84326>>00505000
              error handling is improved, in particular, fopen <<84326>>00510000
              of idathelp is checked for errors(!).            <<84326>>00515000
              entire command words are now allowed (e.g.,      <<84326>>00520000
              t[ext], f[ormat], etc. except for d  which  can- <<84326>>00525000
              not have more than the d due to syntax confusion <<84326>>00530000
              (need to allow d, dda, da, dsy, dco, etc.)       <<84326>>00535000
    27jun84   added octal value to code dump.                  <<84627>>00540000
                                                                        00545000
quality                                                                 00550000
   the code decoding capability uses debugutil, and must run privileged.00555000
                                                                        00560000
;                                                                       00565000
$page                                                                   00570000
begin                                                                   00575000
                                                                        00580000
equate  <<condition code values>>                                       00585000
   ccg = 0,                                                             00590000
   ccl = 1,                                                             00595000
   cce = 2;                                                             00600000
equate   <<codes for dispaly options>>                                  00605000
    octal'mode   = 0,                                                   00610000
  integer'mode   = 1,                                                   00615000
    ascii'mode   = 2,                                                   00620000
     code'mode   = 3,                                                   00625000
   octal'ascii   = 4;                                            <<nsf>>00630000
                                                                        00635000
equate  << system file numbers >>                                       00640000
      loadmap  = 0,                                                     00645000
      mpecheck = 1,                                                     00650000
      confdata = 2,                                                     00655000
      hppmap   = 3;                                                     00660000
equate                                                                  00665000
      model35      = 1,     << series 3  >>         <<01377>>           00670000
      model25      = 2,     << series 33 >>         <<01377>>           00675000
      model44      = 3,     << series 44 >>         <<01296>>           00680000
      icf55        = 4,     << series 55 >>         <<01377>>           00685000
      mm           = 5,     << series 37 >>                    <<*8993>>00690000
                                                                        00695000
      pcb'maxentno = 1023;                                              00700000
                                                                        00705000
define  << sysfile directory entry >>                                   00710000
  start'addr    = filenumber*4   #,                                     00715000
  end'addr      = filenumber*4+1 #,                                     00720000
  flrecsize     = filenumber*4+2 #,                                     00725000
  fleof         = filenumber*4+3 #,                                     00730000
  sfd'loc       = 16             #,                                     00735000
  maxmem'loc    = 24             #,                                     00740000
  max'file'loc  = 25             #,                                     00745000
  vmrec'min'loc = 26             #,                                     00750000
  time'loc      = 32             #;                                     00755000
                                                                        00760000
define                                                                  00765000
            mpe5 = "G"#,                                         <<nsf>>00770000
            cr   = %15#,                                                00775000
            asb  = assemble#,                                           00780000
        pdisable = assemble (psdb)#,                           <<dougw>>00785000
        penable  = assemble (pseb)#,                           <<dougw>>00790000
        enable   = assemble( sed 1 )#,                         <<*nth*>>00795000
        disable  = assemble( sed 0 )#,                         <<*nth*>>00800000
            seg  = stareg.(8:8)#;                                       00805000
                                                                        00810000
define pcb04 = core(locpcb+double(indx*pcbsize+04))#;                   00815000
define pcb13 = core(locpcb+double(indx*pcbsize+13))#;                   00820000
define pcb14 = core(locpcb+double(indx*pcbsize+14))#;                   00825000
                                                               <<01377>>00830000
define series'33'thru'mm                                       <<*8993>>00835000
             = ( machineid=model25 lor machineid=model44       <<01296>>00840000
                 lor machineid >= icf55 ) #;                   <<*nth*>>00845000
                                                                        00850000
double capd;  << capabilities from who intrinsic >>                     00855000
logical cap=capd;                                                       00860000
                                                                        00865000
define sysmgr = cap.(0:1)#,                                             00870000
       syssup = cap.(5:1)#;                                             00875000
                                                                        00880000
logical    series2or3;<<true: first record of file is firmware>>        00885000
logical       ctrly,  <<true: control-y detected>>                      00890000
         stop'print,  <<flag set or reset every 23rd line >>            00895000
           live'sys, <<true: we are analyzing the live system>><<*nth*>>00900000
           new'text;  <<true: no core file open at time >>              00905000
logical    dst'good,  <<true: low core dst ptr valid>>                  00910000
           cst'good,  <<true: low core cst ptr valid>>                  00915000
          file'good,  <<true: have valid dump file>>                    00920000
             mstart,  <<true: pointer to curr monitor entry >> <<*nth*>>00925000
    print'file'open,  <<true: have an opened hardcopy file >>  << hks >>00930000
      print'enabled,  <<true: duplicate output to hardcopy >>  << hks >>00935000
        autostop'on,  <<true: user prompted every 23 lines>>            00940000
           pcb'good,  <<true; low core pcb ptr valid>>                  00945000
          auto'text,  <<true: automatic text via info=>>         <<nsf>>00950000
       new'firmware,  <<true: new v/e firmware installed>>       <<nsf>>00955000
          ld'in'use,  <<true: a loadmap file was referenced>>    <<nsf>>00960000
                dda,  <<true: doing  dda command >>                     00965000
    reading'sysfile, <<allow access to sysfile area>>                   00970000
         currentvol,  <<tape volume number>>                            00975000
                                                                        00980000
              mpeiv,  <<true: mpe4 dump>>                               00985000
              mpevp,  <<true: mpev/p dump>>                             00990000
              mpeve,  <<true: mpeve dump>>                              00995000
            mpetype;  <<0 = mpeiv, 1= mpevp, 2 = mpeve >>               01000000
                      <<3 = mpeve with new ucode >>                     01005000
                                                               << hks >>01010000
integer       coref,  <<discfile number of memory dump>>                01015000
             vmfile,  <<file number of virtual mem>>                    01020000
            dmptape,  <<for input file>>                                01025000
            devtype,  <<dump input device type>>                        01030000
                                                                        01035000
         print'file,  <<file number for hardcopy listing>>     << hks >>01040000
        screen'line,  <<count of number of lines displayed >>  << hks >>01045000
             infile,  <<file number for $stdinx>>                       01050000
             inchar,  <<number of char read in>>                        01055000
            outchar,  <<number of char after compression>>              01060000
            outfile,  <<file number for $stdlist>>                      01065000
             ldfile,  <<file number for loadmap>>                <<nsf>>01070000
           listfile,  <<file number for hard copy device>>       <<nsf>>01075000
             clock,  <<used during dump time date formatting>>   <<nsf>>01080000
           calendar;  <<used during dump time date formatting>>  <<nsf>>01085000
                                                                        01090000
logical     dst'min,  << beginnig of dst >>                             01095000
            dst'max,  << end of dst      >>                             01100000
     use'pseudo'dst,                                                    01105000
           vm'inuse,  <<true: virt. storage in use>>                    01110000
          get'files,  <<true: ok to get loadmap, etc>>                  01115000
        new'loadmap;  <<true: new loadmap format>>                      01120000
                                                                        01125000
double       maxmem,  <<largest valid memory address>>                  01130000
       max'real'mem,  <<max addr of real mem>>                          01135000
             vm'min,  <<1st addr of virt. storage>>                     01140000
          vmrec'min,  << 1st record of vm >>                            01145000
   old'block'number,  <<memory block currently in buffer>>              01150000
           max'file,  <<max addr of real mem file >>                    01155000
          dseg'base,  <<base addr of virtual dseg>>                     01160000
              sysdb;  <<address of system db>>                          01165000
                                                                        01170000
logical array corebuf(0:4095);  <<memory buffer>>                       01175000
                                                                        01180000
logical array lbuf(0:49);                                               01185000
byte array    buf(*)=lbuf;                                              01190000
                                                                        01195000
double array directory(0:63);                                           01200000
logical array l'directory(*) = directory;                               01205000
byte array sfd(0:20) := "SYSTEM FILE DIRECTORY";                        01210000
                                                                        01215000
logical array pcbentry(0:20);                                           01220000
byte array seriesbuf(0:2);                                              01225000
byte pointer pbuf:=@buf;                                                01230000
byte pointer info'ptr=q-5;                                       <<nsf>>01235000
                                                                        01240000
logical array lsqueez(0:39);                                            01245000
byte array squeez(*)=lsqueez;                                           01250000
                                                                        01255000
byte array lpfname(0:9) := "IDATLIST  ";                       << hks >>01260000
byte array lpdevname(0:3) := "LP ";                            << hks >>01265000
                                                                        01270000
byte array virtfilename(0:37);                                          01275000
                                                                        01280000
intrinsic  fopen,ascii,quit,fread,fwrite,print,freaddir,mycommand;      01285000
intrinsic search,xcontrap,resetcontrol,binary,dbinary,dascii,debug;     01290000
intrinsic fcheck,fgetinfo,fclose,terminate,fspace,fcontrol,fwritedir;   01295000
intrinsic read,readx,fmtcalendar,fmtdate,fmtclock,ferrmsg,who;          01300000
intrinsic printop,dateline,fpoint;                                      01305000
                                                                        01310000
                                                                        01315000
         integer status=q-1,                                   <<01.02>>01320000
                 s0=s-0,                                                01325000
                 s1=s-1,                                       <<*nth*>>01330000
                 info'len=q-6,                                          01335000
                 numrec,                                                01340000
                 machineid,                                             01345000
                 tape'version,                                          01350000
                 mpeversion;                                     <<nsf>>01355000
                                                                        01360000
         array scrbuf(0:100); <<for get'seriesii'context sub.>>         01365000
                                                                        01370000
         array regsave(0:30)=db;  <<registers>>                         01375000
                                                                        01380000
         logical reg0=regsave+0,                                        01385000
                 reg1=regsave+1,                                        01390000
                 reg2=regsave+2,                                        01395000
                 reg3=regsave+3,                                        01400000
                 reg4=regsave+4,                                        01405000
                 reg5=regsave+5,                                        01410000
                 reg7=regsave+6,                                        01415000
                 xreg=regsave+7,                                        01420000
                 dlreg=regsave+8,                                       01425000
                 dbbankreg=regsave+9,                                   01430000
                 dbreg=regsave+10,                                      01435000
                 qreg=regsave+11,                                       01440000
                 sreg=regsave+12,                                       01445000
                 zbankreg=regsave+13,                                   01450000
                 zreg=regsave+14,                                       01455000
                 stareg=regsave+15,                                     01460000
                 pbbankreg=regsave+16,                                  01465000
                 pbreg=regsave+17,                                      01470000
                 preg=regsave+18,                                       01475000
                 plreg=regsave+19,                                      01480000
                 cirreg=regsave+20,                                     01485000
                 cpx1=regsave+21,                                       01490000
                 cpx2=regsave+22,                                       01495000
                 reg6=regsave+23,                                       01500000
                 memsize=regsave+24,                                    01505000
                 nir=regsave+25,                               <<00.01>>01510000
                 sp1=regsave+26,                               <<00.01>>01515000
                 sp2=regsave+27,                               <<00.01>>01520000
                 isr=regsave+28;                               <<00.01>>01525000
                                                                        01530000
double verno := %1116d,                                                 01535000
       upno  := %1114d,                                                 01540000
       fno   := %1115d;                                                 01545000
                                                               <<03752>>01550000
                                                               <<03752>>01555000
<<* * * machine context * * *>>                                <<00.01>>01560000
                                                               <<00.01>>01565000
define                                                         <<00.01>>01570000
   cnmachineid        = corebuf(%1400).(8:8) #,                <<01172>>01575000
   livenumbanks       = corebuf(%1047)        #,               <<*nth*>>01580000
   cntapevers         = corebuf(%1525)       #,                         01585000
                                                               <<00.01>>01590000
<<model 35>>                                                   <<00.01>>01595000
   cnstarfish         = corebuf(%1400).(0:8) #,                <<02519>>01600000
   m35contents24      = corebuf(%1401)       #,                <<00.01>>01605000
   m35smreg           = corebuf(%1402)       #,                <<00.01>>01610000
   m35sp1reg          = corebuf(%1403)       #,                <<00.01>>01615000
   m35sp2reg          = corebuf(%1404)       #,                <<00.01>>01620000
   m35dbreg           = corebuf(%1405)       #,                <<00.01>>01625000
   m35dbankreg        = corebuf(%1406).(0:4) #,                <<00.01>>01630000
   m35pbankreg        = corebuf(%1406).(4:4) #,                <<00.01>>01635000
   m35sbankreg        = corebuf(%1406).(12:4)#,                <<00.01>>01640000
   m35zreg            = corebuf(%1407)       #,                <<00.01>>01645000
   m35dlreg           = corebuf(%1410)       #,                <<00.01>>01650000
   m35xreg            = corebuf(%1411)       #,                <<00.01>>01655000
   m35qreg            = corebuf(%1412)       #,                <<00.01>>01660000
   m35cireg           = corebuf(%1413)       #,                <<00.01>>01665000
   m35pbreg           = corebuf(%1414)       #,                <<00.01>>01670000
   m35plreg           = corebuf(%1415)       #,                <<00.01>>01675000
   m35preg            = corebuf(%1416)       #,                <<00.01>>01680000
   m35cpx1            = corebuf(%1417)       #,                <<00.01>>01685000
   m35statusreg       = corebuf(%1420)       #,                <<00.01>>01690000
   m35cpx2            = corebuf(%1421).(0:8) #,                <<00.01>>01695000
   m35numbanks        = corebuf(%1421).(8:8) #,                <<00.01>>01700000
   cndrt0             = corebuf(%1422)       #,                <<02519>>01705000
   cndrt1             = corebuf(%1423)       #,                <<02519>>01710000
   cndrt2             = corebuf(%1424)       #,                <<02519>>01715000
   cndrt3             = corebuf(%1425)       #,                <<02519>>01720000
                                                               <<00.01>>01725000
                                                               <<00.01>>01730000
<<model 25  and  model icf/55>>                                <<03013>>01735000
   m25dumpdevicedrt   = corebuf(%1401)       #,                <<00.01>>01740000
   m25xreg            = corebuf(%1402)       #,                <<00.01>>01745000
   m25dlreg           = corebuf(%1403)       #,                <<00.01>>01750000
   m25dbankreg        = corebuf(%1404)       #,                <<00.01>>01755000
   m25dbreg           = corebuf(%1405)       #,                <<00.01>>01760000
   m25qreg            = corebuf(%1406)       #,                <<00.01>>01765000
   m25sreg            = corebuf(%1407)       #,                <<00.01>>01770000
   m25sbankreg        = corebuf(%1410)       #,                <<00.01>>01775000
   m25zreg            = corebuf(%1411)       #,                <<00.01>>01780000
   m25statusreg       = corebuf(%1412)       #,                <<00.01>>01785000
   m25pbankreg        = corebuf(%1413)       #,                <<00.01>>01790000
   m25pbreg           = corebuf(%1414)       #,                <<00.01>>01795000
   m25preg            = corebuf(%1415)       #,                <<00.01>>01800000
   m25plreg           = corebuf(%1416)       #,                <<00.01>>01805000
   m25cireg           = corebuf(%1417)       #,                <<00.01>>01810000
   m25numphysicalbanks= corebuf(%1420)       #,                <<00.01>>01815000
   m25nirreg          = corebuf(%1421)       #,                <<00.01>>01820000
   m55nirreg          = corebuf(%1515)       #,                <<03013>>01825000
   m25isr             = corebuf(%1422)       #,                <<00.01>>01830000
   m25numbanks        = corebuf(%1423)       #,                <<03013>>01835000
   m55cpx1            = corebuf(%1421)       #,                <<03013>>01840000
   m55cpx2            = corebuf(%1422)       #;                <<03013>>01845000
 equate maximum'banks = 64;                                    <<01114>>01850000
                                                                        01855000
<< mpe5 >>                                                              01860000
define                                                                  01865000
   mpe5father         = pcbentry(5)/(%25)#,      <<ed>>                 01870000
   mpe5son            = pcbentry(6)/(%25)#,      <<ed>>                 01875000
   mpe5brother        = pcbentry(7)/(%25)#,      <<ed>>                 01880000
   mpe5stkinfo        = pcbentry(3).(2:14)#,     <<ed>>                 01885000
                                                                        01890000
<< mpe4 >>                                                              01895000
   mpe4father         = pcbentry(5).(0:8)#,      <<ed>>                 01900000
   mpe4son            = pcbentry(5).(8:8)#,      <<ed>>                 01905000
   mpe4brother        = pcbentry(6).(0:8)#,      <<ed>>                 01910000
   mpe4stkinfo        = pcbentry(3).(1:10)#;     <<ed>>                 01915000
                                                                        01920000
<< original values of registers saved throughout      >>                01925000
<< the program.  initialized in procedure "INIT'REGS" >>                01930000
  logical                                                               01935000
    svdbbank,     svzreg,                                               01940000
    svdbreg,      svpbbank,                                             01945000
    svsbank,      svpbreg,                                              01950000
    svsreg,       svqreg,                                               01955000
    svdlreg,      svplreg,                                       <<nsf>>01960000
    svpreg;                                                      <<nsf>>01965000
                                                                        01970000
<< leave this core file record sized buff at end of>>                   01975000
<< declarations to prevent byte addressing problems>>                   01980000
logical array tempbuf(0:4095);                                          01985000
                                                                        01990000
                                                                        01995000
logical procedure deassemble(result,string,instr,instr'word2);          02000000
      value instr,instr'word2;                                          02005000
      integer result,instr,instr'word2;                                 02010000
      byte array string;                                                02015000
      option variable, uncallable, privileged, external;                02020000
                                                                        02025000
procedure helproc(catnum,listnum,comimage,combase,err,onecharprmpt);    02030000
      value catnum,listnum,onecharprmpt;                                02035000
      integer catnum,listnum,err;                                       02040000
      byte array comimage,combase;                                      02045000
      logical onecharprmpt;                                             02050000
      option external;                                                  02055000
                                                                        02060000
procedure print'file'info(fn);                                          02065000
      value fn;                                                         02070000
      integer fn;                                                       02075000
      option external;                                                  02080000
                                                                        02085000
procedure genmsgu(a,b);                                                 02090000
   value a,b;integer a,b;                                               02095000
   option privileged;                                                   02100000
   option external;                                                     02105000
integer procedure getdataseg(msize,vmsize);                    <<*nth*>>02110000
  value msize, vmsize;                                         <<*nth*>>02115000
  integer msize, vmsize;                                       <<*nth*>>02120000
  option external;                                             <<*nth*>>02125000
                                                               <<*nth*>>02130000
procedure reldataseg(en);                                      <<*nth*>>02135000
  value en;                                                    <<*nth*>>02140000
  integer en;                                                  <<*nth*>>02145000
  option external;                                             <<*nth*>>02150000
                                                               <<*nth*>>02155000
procedure printerror(errornum); <<error messages>>                      02160000
  value errornum;                                                       02165000
  integer errornum;  <<# of error message to display>>                  02170000
  option forward;                                                       02175000
                                                                        02180000
procedure fmtsir(prntfile);                                             02185000
  value prntfile;                                                       02190000
  integer prntfile;                                                     02195000
  option forward;                                                       02200000
                                                                        02205000
procedure fmtjobs4(prntfile);                                    <<nsf>>02210000
  value prntfile;                                                <<nsf>>02215000
  integer prntfile;                                              <<nsf>>02220000
  option forward;                                                <<nsf>>02225000
                                                                 <<nsf>>02230000
procedure fmtjobs5(prntfile);                                    <<nsf>>02235000
  value prntfile;                                                <<nsf>>02240000
  integer prntfile;                                              <<nsf>>02245000
  option forward;                                                <<nsf>>02250000
procedure help(command,buf,parms);                                      02255000
byte array buf;                                                         02260000
byte pointer command,<<entire command                   >>              02265000
   parms;            <<points to parameters             >>              02270000
   option forward;                                                      02275000
                                                                        02280000
procedure textfile(parmstring);                                         02285000
   byte array parmstring;                                               02290000
   option forward;                                                      02295000
                                                                        02300000
procedure prt'stk4(f'num,adrs,s,qinitl,dstnum);                         02305000
  value f'num,adrs,s,qinitl,dstnum;                                     02310000
  integer f'num,s,qinitl,dstnum;                                        02315000
  double adrs;                                                          02320000
  option forward;                                                       02325000
                                                                        02330000
procedure prt'stk5(f'num,adrs,s,qinitl,dstnum);                         02335000
  value f'num,adrs,s,qinitl,dstnum;                                     02340000
  integer f'num,s,qinitl,dstnum;                                        02345000
  double adrs;                                                   <<nsf>>02350000
  option forward;                                                <<nsf>>02355000
                                                                 <<nsf>>02360000
procedure fmtregs(prntfile);                                            02365000
   value prntfile;                                                      02370000
   integer prntfile;                                                    02375000
   option forward;                                                      02380000
                                                                        02385000
logical procedure isfree(pcb'entry);                                    02390000
   value pcb'entry;                                                     02395000
   integer pcb'entry;                                                   02400000
   option forward;                                                      02405000
                                                                        02410000
procedure putnum(num);                                                  02415000
   value num;                                                           02420000
   integer num;                                                         02425000
   option forward;                                                      02430000
                                                                        02435000
procedure putnump(num);                                                 02440000
   value num;                                                           02445000
   integer num;                                                         02450000
   option forward;                                                      02455000
                                                                        02460000
procedure set'reg(parmstring);                                          02465000
   byte array parmstring;                                               02470000
   option forward;                                                      02475000
                                                                        02480000
procedure fmtmon(prntfile);                                    <<*nth*>>02485000
  value prntfile;                                              <<*nth*>>02490000
  integer prntfile;                                            <<*nth*>>02495000
  option forward;                                              <<*nth*>>02500000
                                                               <<*nth*>>02505000
procedure putdnum(num);                                        <<*nth*>>02510000
  value num;                                                   <<*nth*>>02515000
  double num;                                                  <<*nth*>>02520000
  option forward;                                              <<*nth*>>02525000
                                                               <<*nth*>>02530000
procedure putdnump(num);                                       <<*nth*>>02535000
  value num;                                                   <<*nth*>>02540000
  double num;                                                  <<*nth*>>02545000
  option forward;                                              <<*nth*>>02550000
                                                               <<*nth*>>02555000
procedure find(parmstring);                                    <<*nth*>>02560000
  byte array parmstring;                                       <<*nth*>>02565000
  option forward;                                              <<*nth*>>02570000
                                                               <<*nth*>>02575000
procedure write'rec(file'num,lout'buf,buflen,ccode);           << hks >>02580000
   value file'num,buflen,ccode;                                << hks >>02585000
   integer file'num,buflen,ccode;                              << hks >>02590000
   logical array lout'buf;                                     << hks >>02595000
   option forward;                                             << hks >>02600000
                                                                        02605000
procedure close'print'file;                                    << hks >>02610000
   option forward;                                             << hks >>02615000
                                                               << hks >>02620000
procedure open'print'file;                                     << hks >>02625000
   option forward;                                             << hks >>02630000
                                                                        02635000
logical procedure prompt'stop;                                          02640000
   option forward;                                                      02645000
                                                                        02650000
procedure enable'autostop;                                              02655000
  option forward;                                                       02660000
                                                                        02665000
procedure disable'autostop;                                             02670000
  option forward;                                                       02675000
                                                                        02680000
procedure parse'dioq(parmstring,optn,ldev);                             02685000
  byte array parmstring;                                                02690000
  integer optn,ldev;                                                    02695000
  option forward;                                                       02700000
                                                               << hks >>02705000
procedure fmtdit(ldevnum);                                              02710000
   value ldevnum;                                                       02715000
   integer ldevnum;                                                     02720000
   option forward,variable;                                             02725000
                                                                        02730000
procedure fmtdrq(optn,ldev);                                            02735000
   value optn,ldev;                                                     02740000
   integer optn,ldev;                                                   02745000
   option forward;                                                      02750000
                                                                        02755000
procedure fmtsbuf;                                                      02760000
   option forward;                                                      02765000
                                                                        02770000
procedure fmtioq(optn,ldev);                                            02775000
   value optn,ldev;                                                     02780000
   integer optn,ldev;                                                   02785000
   option forward;                                                      02790000
                                                                        02795000
procedure proc'tree(address,outfile);                                   02800000
   value address;                                                       02805000
   double address;                                                      02810000
   integer outfile;                                                     02815000
   option forward;                                                      02820000
                                                                        02825000
integer procedure get'token(parmstring,delimiters,tknbuf,delim);        02830000
  byte array parmstring,delimiters,tknbuf;                              02835000
  byte delim;                                                           02840000
  option forward;                                                       02845000
                                                                        02850000
logical procedure auto'file(filenumber);                                02855000
  value filenumber;                                                     02860000
  integer filenumber;                                                   02865000
  option forward;                                                       02870000
                                                                        02875000
procedure name'cst(cst'num,target);                                     02880000
  value cst'num;                                                        02885000
  integer cst'num;                                                      02890000
  logical array target;                                                 02895000
  option forward;                                                       02900000
                                                                        02905000
procedure printline(prntfile);                                          02910000
  value prntfile;                                                       02915000
  integer prntfile;                                                     02920000
  option forward;                                                       02925000
                                                                        02930000
$page "                    PROCEDURE CONTROLY"                          02935000
<<***********************************************************>>         02940000
<< controly                                                  >>         02945000
<<----------------------------------------------------------->>         02950000
<< controy-y trap routine  --  set global flag to true       >>         02955000
<<***********************************************************>>         02960000
procedure controly;                                                     02965000
begin                                                                   02970000
                                                                        02975000
integer sdec= q+1;                                                      02980000
                                                                        02985000
resetcontrol;                                                           02990000
ctrly:=true;                                                            02995000
tos:=%31400+sdec;                                                       03000000
assemble(xeq 0);                                                        03005000
                                                                        03010000
end;  <<controly>>                                                      03015000
$page "                    PROCEDURE CORE"                              03020000
<<***********************************************************>>         03025000
<< core                                                      >>         03030000
<<----------------------------------------------------------->>         03035000
<< return contents of memory location                        >>         03040000
<<***********************************************************>>         03045000
logical procedure core(adr);                                            03050000
  value adr;                                                            03055000
  double adr;  <<memory address (bank,address)>>                        03060000
                                                                        03065000
begin                                                                   03070000
                                                                        03075000
  << condition code is returned as follows:               >>            03080000
  <<                                                      >>            03085000
  <<   ccg - invalid address parameter                    >>            03090000
  <<   cce - successfull                                  >>            03095000
  <<   ccl - disc i/o to file "COREF" failed              >>            03100000
                                                                        03105000
  <<this procedure assumes the existence of the following >>            03110000
  <<global variables:                                     >>            03115000
  <<                                                      >>            03120000
  << integer       coref - file number of disc file       >>            03125000
  <<                       containing the memory image    >>            03130000
  <<                                                      >>            03135000
  << double       maxmem - largest valid memory address   >>            03140000
  <<                       in the dump (first word is the >>            03145000
  <<                       bank and second the address)   >>            03150000
  << logical array                                        >>            03155000
  <<     corebuf(0:4095) - buffer for one record from the >>            03160000
  <<                       file "COREF"                   >>            03165000
  <<                       (modified by this procedure)   >>            03170000
  <<                                                      >>            03175000
  << procedure printerror- produces error messages        >>            03180000
                                                                        03185000
  define cc=status.(6:2) #,                                             03190000
         vm'file'flag = %10000000000d #;                                03195000
                                                                        03200000
  logical in'pdst,                                                      03205000
          in'vm,                                                        03210000
          bank = adr,                                                   03215000
          offset = adr + 1,                                             03220000
          dltap=q-2, <<for error>>                                      03225000
          stat=q-1;  <<for error>>                                      03230000
                                                                        03235000
  double block'number, vm'block'number;                                 03240000
                                                                        03245000
  integer block'offset;                                                 03250000
                                                                        03255000
subroutine print'badaddr;                                               03260000
                                                                        03265000
  begin                                                                 03270000
  move buf:="INVALID ADDRESS GENERATED  XXXXXX";                        03275000
  @pbuf:=@buf+27;                                                       03280000
  putdnum(adr);                                                         03285000
  move pbuf:=" IDAT DELTA P=";                                          03290000
  @pbuf:=@pbuf+15;                                                      03295000
  putnum(dltap);                                                        03300000
  move pbuf:=" IDAT SEGMENT=";                                          03305000
  @pbuf:=@pbuf+15;                                                      03310000
  putnum(stat.(10:6)-1);                                                03315000
  if series'33'thru'mm then printline(outfile);                         03320000
  cc:=ccg;                                                              03325000
  end;                                                                  03330000
                                                                        03335000
<< m a i n  >>                                                          03340000
  core := 0;  << return zero in case of an error >>                     03345000
  cc := cce;  << assume no errors >>                                    03350000
                                                                        03355000
  if reading'sysfile  then                                              03360000
    begin                                                               03365000
    if adr <= max'real'mem + 128d  or  adr > max'file  then             03370000
      begin                                                             03375000
      printerror(81);                                                   03380000
      print'badaddr;                                                    03385000
      return;                                                           03390000
      end;                                                              03395000
    end                                                                 03400000
  else if adr < 0d  or  adr > maxmem  then                              03405000
    begin                                                               03410000
    print'badaddr;                                                      03415000
    return;                                                             03420000
    end;                                                                03425000
                                                                        03430000
  << if live system has been selected, get word from >>                 03435000
  << running host's memory                           >>                 03440000
  if live'sys  then                                                     03445000
    begin                                                               03450000
    tos := adr;                                                         03455000
    assemble(lsea);                                                     03460000
    core := tos;                                                        03465000
    ddel;                                                               03470000
    return;                                                             03475000
    end;                                                                03480000
                                                                        03485000
  block'offset := offset.(4:12);                                        03490000
  block'number := adr&dlsr(12);                                         03495000
                                                                        03500000
  in'pdst := use'pseudo'dst    land                                     03505000
     (double(dst'min) <= adr)  land  (adr <= double(dst'max));          03510000
                                                                        03515000
  in'vm := vm'inuse land not reading'sysfile land                       03520000
           adr >= vm'min;                                               03525000
                                                                        03530000
  if in'pdst or in'vm  then                                             03535000
    block'number := block'number + vm'file'flag;                        03540000
                                                                        03545000
  << skip extra first record (firmware)>>                               03550000
  if series2or3 then block'number := block'number + 1d;                 03555000
                                                                        03560000
  if block'number <> old'block'number  then                             03565000
    begin                                                               03570000
    old'block'number := block'number;                                   03575000
    if in'pdst or in'vm  then                                           03580000
      begin                                                             03585000
      if in'pdst  then                                                  03590000
        vm'block'number := (adr-double(dst'min))&dlsr(12) + 1d          03595000
      else                                                              03600000
        vm'block'number := (adr-vm'min)&dlsr(12) + vmrec'min;           03605000
      freaddir(vmfile,corebuf,4096,vm'block'number);                    03610000
      if <> then                                                        03615000
        begin                                                           03620000
        printerror(17);                                                 03625000
        print'file'info(vmfile);                                        03630000
        cc := ccl;                                                      03635000
        return;                                                         03640000
        end                                                             03645000
      end                                                               03650000
    else                                                                03655000
      begin                                                             03660000
      freaddir(coref,corebuf,4096,block'number);                        03665000
      if <> then                                                        03670000
        begin                                                           03675000
        printerror(17);                                                 03680000
        print'file'info(coref);                                         03685000
        cc := ccl;                                                      03690000
        return;                                                         03695000
        end;                                                            03700000
      end;                                                              03705000
    end;                                                                03710000
                                                                        03715000
  if in'pdst  then                                                      03720000
    core := corebuf((offset - dst'min).(4:12))                          03725000
  else                                                                  03730000
    core := corebuf(block'offset);                                      03735000
                                                                        03740000
end;                                                                    03745000
$page "                    PROCEDURE DCORE"                             03750000
<<***********************************************************>>         03755000
<< dcore                                                     >>         03760000
<<----------------------------------------------------------->>         03765000
<< return contents of memory locations (double word)         >>         03770000
<<***********************************************************>>         03775000
double procedure dcore(adr);                                            03780000
  value adr;                                                            03785000
  double adr;  <<memory address (bank,address)>>                        03790000
begin                                                                   03795000
                                                                        03800000
  << condition code is returned as follows:      >>                     03805000
  <<                                             >>                     03810000
  <<   ccg - invalid address parameter           >>                     03815000
  <<   cce - successful                          >>                     03820000
  <<   ccl - disc i/o to file "COREF" failed     >>                     03825000
                                                                        03830000
  << this procedure assumes the existence of the >>                     03835000
  << procedure "CORE"                            >>                     03840000
                                                                        03845000
define  cc = status.(6:2)#;                                             03850000
                                                                        03855000
logical condcode,         <<condition code from "CORE">>                03860000
          status = q-1;   <<status register in marker>>                 03865000
                                                                        03870000
cc:=cce;                                                                03875000
                                                                        03880000
tos:=core(adr);                                                         03885000
push(status);                                                           03890000
condcode:=tos.(6:2);                                                    03895000
if condcode <> cce then begin                                           03900000
  del;                                                                  03905000
  cc:=condcode;                                                         03910000
  return; end;                                                          03915000
                                                                        03920000
tos:=core(adr+1d);                                                      03925000
push(status);                                                           03930000
condcode:=tos.(6:2);                                                    03935000
if condcode <> cce then begin                                           03940000
  del;                                                                  03945000
  cc:=condcode;                                                         03950000
  return; end;                                                          03955000
                                                                        03960000
dcore:=tos;                                                             03965000
                                                                        03970000
end;  <<dcore>>                                                         03975000
$page "                    PROCEDURE GETCORE"                           03980000
<<***********************************************************>>         03985000
<< getcore                                                   >>         03990000
<<----------------------------------------------------------->>         03995000
<< return block of memory locations                          >>         04000000
<<***********************************************************>>         04005000
procedure getcore(adr,wordcount,buffer);                                04010000
  value adr,wordcount;                                                  04015000
  integer    wordcount;   <<number of words to return>>                 04020000
  double           adr;   <<address of first word to return>>           04025000
  logical array buffer;   <<buffer for returning the words>>            04030000
begin                                                                   04035000
                                                                        04040000
  << condition code is returned as follows:      >>                     04045000
  <<                                             >>                     04050000
  <<   ccg - invalid starting or ending address  >>                     04055000
  <<   cce - successful                          >>                     04060000
  <<   ccl - disc i/o to file "COREF" failed     >>                     04065000
                                                                        04070000
  <<this procedure assumes the existence of the following >>            04075000
  <<global variables:                                     >>            04080000
  <<                                                      >>            04085000
  << integer       coref - file number of disc file       >>            04090000
  <<                       containing the memory image    >>            04095000
  << integer  curmemarea - used by this procedure to      >>            04100000
  <<                       remember which record of file  >>            04105000
  <<                       "COREF" is currently in the    >>            04110000
  <<                       file buffer "COREBUF"          >>            04115000
  <<                       (modified by this procedure)   >>            04120000
  << double       maxmem - largest valid memory address   >>            04125000
  <<                       in the dump (first word is the >>            04130000
  <<                       bank and second the address)   >>            04135000
  << logical array                                        >>            04140000
  <<     corebuf(0:4095) - buffer for one record from the >>            04145000
  <<                       file "COREF"                   >>            04150000
  <<                       (modified by this procedure)   >>            04155000
  <<                                                      >>            04160000
  << procedure printerror- produces error messages        >>            04165000
                                                                        04170000
define  cc = status.(6:2) #,                                            04175000
        vm'file'flag = %10000000000d #;                                 04180000
                                                                        04185000
logical in'pdst,            <<true: adr in pdst        >>               04190000
        in'vm,              <<true: adr in vm          >>               04195000
        firstblock,         <<true: copying from first block>>          04200000
        status = q-1,       <<status register in marker>>               04205000
                                                                        04210000
        bank = adr,                                                     04215000
        offset = adr + 1;                                               04220000
                                                                        04225000
double  block'number, vm'block'number;                                  04230000
                                                                        04235000
integer block'offset,       <<current starting addr in buffer>>         04240000
        buff'offset,        <<normalized offset into buffer>>           04245000
        movecount,          <<# words to move in one move>>             04250000
        tcount;             <<# words already transferred>>             04255000
                            <<to target buffer           >>             04260000
                                                                        04265000
cc:=cce;  <<assume no errors>>                                          04270000
                                                                        04275000
<<check for invalid starting or ending address>>                        04280000
if reading'sysfile then                                                 04285000
  begin                                                                 04290000
  if adr <= max'real'mem  or                                            04295000
      adr + double(wordcount) > max'file  then                          04300000
    begin                                                               04305000
    cc := ccg;                                                          04310000
    printerror(78);                                                     04315000
    return;                                                             04320000
    end;                                                                04325000
  end                                                                   04330000
else if adr < 0d  or  adr+double(wordcount-1) > maxmem  then            04335000
  begin                                                                 04340000
  cc := ccg;                                                            04345000
  printerror(16);                                                       04350000
  return;                                                               04355000
  end;                                                                  04360000
                                                                        04365000
if live'sys then                                                        04370000
  begin                                                                 04375000
  for tcount := 0 until wordcount - 1 do                                04380000
    begin                                                               04385000
    tos := adr + double(tcount);                                        04390000
    assemble(lsea);                                                     04395000
    buffer(tcount) := tos;                                              04400000
    ddel;                                                               04405000
    end;                                                                04410000
  return;                                                               04415000
  end;                                                                  04420000
                                                                        04425000
<<calc 4k recored number and offset into 4k record>>                    04430000
block'offset := offset.(4:12);                                          04435000
block'number := adr&dlsr(12);                                           04440000
                                                                        04445000
in'pdst := use'pseudo'dst    land                                       04450000
   (double(dst'min) <= adr)  land  (adr <= double(dst'max));            04455000
                                                                        04460000
in'vm := vm'inuse land not reading'sysfile land                         04465000
         (adr >= vm'min);                                               04470000
                                                                        04475000
if in'pdst or in'vm  then                                               04480000
  block'number := block'number + vm'file'flag;                          04485000
                                                                        04490000
<< skip extra first record (firmware)>>                                 04495000
if series2or3 then block'number := block'number + 1d;                   04500000
                                                                        04505000
tcount := 0;  << # words copied to target buffer >>                     04510000
firstblock := true;                                                     04515000
                                                                        04520000
while tcount < wordcount  do                                            04525000
  begin                                                                 04530000
  if block'number <> old'block'number  then                             04535000
    begin                                                               04540000
    old'block'number := block'number;                                   04545000
    if in'pdst or in'vm  then                                           04550000
      begin                                                             04555000
                                                                        04560000
    if in'pdst then                                                     04565000
      vm'block'number := (adr-double(dst'min))&dlsr(12) + 1d            04570000
    else                                                                04575000
      vm'block'number := (adr-vm'min)&dlsr(12) + vmrec'min;             04580000
    if not firstblock then                                              04585000
      vm'block'number := vm'block'number + 1d;                          04590000
      freaddir(vmfile,corebuf,4096,vm'block'number);                    04595000
      if <> then                                                        04600000
        begin                                                           04605000
        printerror(17);                                                 04610000
        print'file'info(vmfile);                                        04615000
        cc := ccl;                                                      04620000
        return;                                                         04625000
        end;                                                            04630000
      end                                                               04635000
    else                                                                04640000
      begin                                                             04645000
      freaddir(coref,corebuf,4096,block'number);                        04650000
      if <> then                                                        04655000
        begin                                                           04660000
        printerror(17);                                                 04665000
        print'file'info(coref);                                         04670000
        cc := ccl;                                                      04675000
        return;                                                         04680000
        end;                                                            04685000
      end;                                                              04690000
    end;                                                                04695000
                                                                        04700000
  if firstblock then                                                    04705000
    begin                                                               04710000
    if in'pdst then                                                     04715000
      buff'offset := (offset - dst'min).(4:12)                          04720000
    else                                                                04725000
      buff'offset := block'offset;                                      04730000
    end                                                                 04735000
  else                                                                  04740000
    buff'offset := 0;                                                   04745000
                                                                        04750000
  <<copy block of words from memory buffer to target buffer>>           04755000
  if (movecount:=wordcount-tcount)+buff'offset >= 4096 then             04760000
    movecount:= 4096 - buff'offset;                                     04765000
                                                                        04770000
  move buffer(tcount):=corebuf(buff'offset),(movecount);                04775000
  tcount:=tcount+movecount;                                             04780000
  block'number := block'number + 1d;                                    04785000
  firstblock := false;                                                  04790000
  end;                                                                  04795000
                                                                        04800000
end;  <<getcore>>                                                       04805000
$page "                    PROCEDURE PUTCORE"                           04810000
<<***********************************************************>>         04815000
<<  putcore                                                  >>         04820000
<<----------------------------------------------------------->>         04825000
<< put a word of memory back to disk                         >>         04830000
<<***********************************************************>>         04835000
procedure putcore(adr,pvalue);                                          04840000
  value adr,pvalue;                                                     04845000
  double adr;                                                           04850000
  logical pvalue;                                                       04855000
                                                                        04860000
begin                                                                   04865000
                                                                        04870000
  << condition code is returned as follows:      >>                     04875000
  <<                                             >>                     04880000
  <<   cce - successful                          >>                     04885000
  <<   ccl - disc i/o to file "COREF" failed     >>                     04890000
                                                                        04895000
  <<this procedure assumes the existence of the following >>            04900000
  <<global variables:                                     >>            04905000
  <<                                                      >>            04910000
  << integer       coref - file number of disc file       >>            04915000
  <<                       containing the memory image    >>            04920000
  <<          curmemarea - value of the current record    >>            04925000
  <<                       where 'coref' is pointed to    >>            04930000
  << logical array                                        >>            04935000
  <<     corebuf(0:4095) - buffer for one record from the >>            04940000
  <<                       file "COREF"                   >>            04945000
  <<                       (assumed to have been modified >>            04950000
  <<                       before this procedure called)  >>            04955000
  << procedure printerror- produces error messages        >>            04960000
                                                                        04965000
  define cc=status.(6:2) #,                                             04970000
         vm'file'flag = %10000000000d #;                                04975000
                                                                        04980000
  logical in'pdst,                                                      04985000
          in'vm,                                                        04990000
          bank = adr,                                                   04995000
          offset = adr + 1,                                             05000000
          dltap=q-2, <<for error>>                                      05005000
          stat=q-1;  <<for error>>                                      05010000
                                                                        05015000
  double block'number, vm'block'number;                                 05020000
                                                                        05025000
  integer block'offset, buff'offset;                                    05030000
                                                                        05035000
subroutine print'badaddr;                                               05040000
                                                                        05045000
  begin                                                                 05050000
  move buf:="INVALID ADDRESS GENERATED  XXXXXX";                        05055000
  @pbuf:=@buf+27;                                                       05060000
  putdnum(adr);                                                         05065000
  move pbuf:=" IDAT DELTA P=";                                          05070000
  @pbuf:=@pbuf+15;                                                      05075000
  putnum(dltap);                                                        05080000
  move pbuf:=" IDAT SEGMENT=";                                          05085000
  @pbuf:=@pbuf+15;                                                      05090000
  putnum(stat.(10:6)-1);                                                05095000
  if series'33'thru'mm then printline(outfile);                         05100000
  cc:=ccg;                                                              05105000
  end;                                                                  05110000
                                                                        05115000
<< m a i n  >>                                                          05120000
  cc := cce;  << assume no errors >>                                    05125000
                                                                        05130000
  if reading'sysfile  then                                              05135000
    begin                                                               05140000
    if adr <= max'real'mem + 128d  or  adr > max'file  then             05145000
      begin                                                             05150000
      printerror(81);                                                   05155000
      print'badaddr;                                                    05160000
      return;                                                           05165000
      end;                                                              05170000
    end                                                                 05175000
  else if adr < 0d  or  adr > maxmem  then                              05180000
    begin                                                               05185000
    print'badaddr;                                                      05190000
    return;                                                             05195000
    end;                                                                05200000
                                                                        05205000
  block'offset := offset.(4:12);                                        05210000
  block'number := adr&dlsr(12);                                         05215000
                                                                        05220000
  in'pdst := use'pseudo'dst  land                                       05225000
     (double(dst'min) <= adr)  land  (adr <= double(dst'max));          05230000
                                                                        05235000
  in'vm := vm'inuse land not reading'sysfile land                       05240000
           (adr >= vm'min);                                             05245000
                                                                        05250000
  if in'pdst or in'vm  then                                             05255000
    begin                                                               05260000
    block'number := block'number + vm'file'flag;                        05265000
    if in'pdst  then                                                    05270000
      vm'block'number := (adr-double(dst'min))&dlsr(12) + 1d            05275000
    else                                                                05280000
      vm'block'number := (adr-vm'min)&dlsr(12) + vmrec'min;             05285000
    end;                                                                05290000
                                                                        05295000
  << skip extra first record (firmware)>>                               05300000
  if series2or3 then block'number := block'number + 1d;                 05305000
                                                                        05310000
  if block'number <> old'block'number  then                             05315000
    begin                                                               05320000
    old'block'number := block'number;                                   05325000
    if in'pdst or in'vm  then                                           05330000
      begin                                                             05335000
      freaddir(vmfile,corebuf,4096,vm'block'number);                    05340000
      if <> then                                                        05345000
        begin                                                           05350000
        printerror(17);                                                 05355000
        print'file'info(vmfile);                                        05360000
        cc := ccl;                                                      05365000
        return;                                                         05370000
        end;                                                            05375000
      end                                                               05380000
    else                                                                05385000
      begin                                                             05390000
      freaddir(coref,corebuf,4096,block'number);                        05395000
      if <> then                                                        05400000
        begin                                                           05405000
        printerror(17);                                                 05410000
        print'file'info(coref);                                         05415000
        cc := ccl;                                                      05420000
        return;                                                         05425000
        end;                                                            05430000
      end;                                                              05435000
    end;                                                                05440000
                                                                        05445000
  if in'pdst  then                                                      05450000
    buff'offset := (offset - dst'min).(4:12)                            05455000
  else                                                                  05460000
    buff'offset := block'offset;                                        05465000
                                                                        05470000
  if corebuf(buff'offset) <> pvalue then                                05475000
    begin                                                               05480000
    corebuf(buff'offset) := pvalue;                                     05485000
    if in'pdst or in'vm  then                                           05490000
      begin                                                             05495000
      fwritedir(vmfile,corebuf,4096,vm'block'number);                   05500000
      if <> then                                                        05505000
        begin                                                           05510000
        printerror(17);                                                 05515000
        print'file'info(vmfile);                                        05520000
        cc := ccl;                                                      05525000
        return;                                                         05530000
        end;                                                            05535000
      if in'pdst  then                                                  05540000
        begin                                                           05545000
        old'block'number := block'number := adr&dlsr(12);               05550000
        freaddir(coref,corebuf,4096,block'number);                      05555000
        if <> then                                                      05560000
          begin                                                         05565000
          printerror(17);                                               05570000
          print'file'info(coref);                                       05575000
          cc := ccl;                                                    05580000
          return;                                                       05585000
          end;                                                          05590000
        corebuf(block'offset) := pvalue;                                05595000
        fwritedir(coref,corebuf,4096,block'number);                     05600000
        if <> then                                                      05605000
          begin                                                         05610000
          printerror(17);                                               05615000
          print'file'info(coref);                                       05620000
          cc := ccl;                                                    05625000
          return;                                                       05630000
          end;                                                          05635000
        end;                                                            05640000
      end                                                               05645000
    else                                                                05650000
      begin                                                             05655000
      fwritedir(coref,corebuf,4096,block'number);                       05660000
      if <> then                                                        05665000
        begin                                                           05670000
        printerror(17);                                                 05675000
        print'file'info(coref);                                         05680000
        cc := ccl;                                                      05685000
        return;                                                         05690000
        end;                                                            05695000
      end;                                                              05700000
    end;                                                                05705000
                                                                        05710000
  block'offset := %1400;                                                05715000
  block'number := 0d;                                                   05720000
                                                                        05725000
  if block'number <> old'block'number  then                             05730000
    begin                                                               05735000
    old'block'number := block'number;                                   05740000
    freaddir(coref,corebuf,4096,block'number);                          05745000
    if <> then                                                          05750000
      begin                                                             05755000
      cc:=ccl;                                                          05760000
      printerror(17);                                                   05765000
      return;                                                           05770000
      end;                                                              05775000
                                                                        05780000
    corebuf(block'offset).(0:8):=%123;                                  05785000
    fwritedir(coref,corebuf,4096,block'number);                         05790000
    if <> then                                                          05795000
      begin                                                             05800000
      cc:=ccl;                                                          05805000
      printerror(17);                                                   05810000
      return;                                                           05815000
      end;                                                              05820000
                                                                        05825000
    end;                                                                05830000
                                                                        05835000
end;  <<putcore>>                                                       05840000
$page "                    PROCEDURE PUTCHAR"                           05845000
<<***********************************************************>>         05850000
<< putchar                                                   >>         05855000
<<----------------------------------------------------------->>         05860000
<< place ascii character into buffer                         >>         05865000
<<***********************************************************>>         05870000
procedure putchar(char,bufloc);                                         05875000
  value char;                                                           05880000
  integer  char;  <<character to put in buffer>>                        05885000
  byte  bufloc;   <<location in which to place char>>                   05890000
begin                                                                   05895000
                                                                        05900000
bufloc:= if %40 <= char <= %176 then char                               05905000
                                else ".";                               05910000
                                                                        05915000
end;  <<putchar>>                                                       05920000
procedure printline(prntfile);                                 <<*nth*>>05925000
                                                               <<*nth*>>05930000
<<             printline                                    >> <<*nth*>>05935000
<<    this procedure will output a line to the output file  >> <<*nth*>>05940000
<<    from lbuf. after printing the print buffer is filled  >> <<*nth*>>05945000
<<    with blanks.                                          >> <<*nth*>>05950000
                                                               <<*nth*>>05955000
    value prntfile;                                            <<*nth*>>05960000
    integer prntfile;                                          <<*nth*>>05965000
                                                               <<*nth*>>05970000
      begin                                                    <<*nth*>>05975000
      integer len;                                                      05980000
                                                                        05985000
         len := 78;                                                     05990000
         while (buf(len-1)=" ") and (len > 0)  do                       05995000
           len := len - 1;                                              06000000
         write'rec(prntfile,lbuf,-len,%40);                             06005000
noprjmp:   <<no print jump point>>                             <<*nth*>>06010000
         @pbuf:=@buf;                                          <<*nth*>>06015000
         << linecount:=linecount+1; >>                         <<*nth*>>06020000
blankbuf:                                                      <<*nth*>>06025000
         lbuf:="  ";                                           <<*nth*>>06030000
         move lbuf(1):=lbuf,(39);                              <<*nth*>>06035000
         << if linecount > lnsperpg then newpage; >>           <<*nth*>>06040000
      end;                                                     <<*nth*>>06045000
                                                               <<*nth*>>06050000
procedure blankbuf;                                            <<*nth*>>06055000
  begin                                                        <<*nth*>>06060000
    lbuf := "  ";  move lbuf(1) := lbuf, (39);                          06065000
  end;                                                         <<*nth*>>06070000
                                                               <<*nth*>>06075000
logical procedure check'stop;                                  <<*nth*>>06080000
begin                                                          <<*nth*>>06085000
  integer length;                                              <<*nth*>>06090000
                                                               <<*nth*>>06095000
  ctrly := false;                                              <<*nth*>>06100000
  write'rec(outfile,lbuf,0,%40);                                        06105000
  move buf := "<CR to Continue> ";                             <<*nth*>>06110000
  write'rec(outfile,lbuf,-17,%320);                                     06115000
  length := readx(lbuf,-1);                                    <<*nth*>>06120000
  if length = 0 then check'stop := false                       <<*nth*>>06125000
  else check'stop := true;                                     <<*nth*>>06130000
  move buf := (27,"A",27,"G",27,"K");                          <<*nth*>>06135000
  write'rec(outfile,lbuf,-6,%320);                                      06140000
  blankbuf;                                                    <<*nth*>>06145000
end;                                                           <<*nth*>>06150000
$page "                    PROCEDURE OCTALDUMP"                         06155000
<<***********************************************************>>         06160000
<<  octaldump                                                >>         06165000
<<----------------------------------------------------------->>         06170000
<< dump range of memory in octal, integer, ascii             >>         06175000
<< or code format.  optionally supress match comparisons.    >>         06180000
<<***********************************************************>>         06185000
procedure octaldump(fnum,startadr,endadr,mode,match'suppress);   <<nsf>>06190000
  value fnum,startadr,endadr,mode,match'suppress;                <<nsf>>06195000
  integer    fnum,       <<file number on which to dump>>               06200000
             mode;       << 0 <= octal  >>                              06205000
                         << 1 <= integer>>                              06210000
                         << 2 <= ascii  >>                              06215000
                         << 3 <= deassemble >>                          06220000
                         << 4 <= octal and ascii >>              <<nsf>>06225000
  logical match'suppress;<< 0 <= don't print matching mem. locations >> 06230000
                         << 1 <= print matching memory locations >>     06235000
  double   endadr,       <<last address to dump>>                       06240000
         startadr;       <<first address to dump>>                      06245000
  option privileged;                                                    06250000
begin                                                                   06255000
                                                                        06260000
  << this procedure assumes the existence of the >>                     06265000
  << procedures "GETCORE" and "PUTCHAR"          >>                     06270000
                                                                        06275000
logical      bank,  <<bank number of current address>>                  06280000
          address,  <<address portion of current address>>              06285000
    current'match,  <<true: have duplicate line>>                       06290000
   previous'match,  <<true: had previous duplicates>>                   06295000
         lastline,  <<true: current output line is final>>              06300000
         codesize;  <<character length of the deassembly>>              06305000
integer      base,  <<value to pass to "ASCII">>                        06310000
              i,j,  <<loop variables and temporary var>>                06315000
           offset;  <<offset from start of line>>                       06320000
double      count,  <<# words to get from getcore>>                     06325000
           curadr,  <<current address to dump>>                         06330000
          lastadr,  <<address of last line dumped>>                     06335000
           pcount;  <<number of words printed>>                         06340000
                                                                        06345000
logical array   curline(0:7),  <<current line>>                         06350000
               prevline(0:7);  <<previous line>>                        06355000
                                                                        06360000
byte array curbytes(*)=curline;                                         06365000
byte array prevbytes(*)=prevline;                                       06370000
                                                                        06375000
logical array lbuf(0:39);     <<output buffer>>                         06380000
byte array buf(*)=lbuf;                                                 06385000
                                                                        06390000
byte array tempbuf(0:5);      <<temporary buffer>>                      06395000
                                                                        06400000
pcount:=0d;                                                             06405000
current'match:=false;                                                   06410000
previous'match:=false;                                                  06415000
lastline:=false;                                                        06420000
curadr:=startadr;                                                       06425000
                                                                        06430000
<<determine mode to use and offset>>                                    06435000
if not (octal'mode <= mode <= octal'ascii) then                  <<nsf>>06440000
  return                                                                06445000
else                                                                    06450000
  case mode of begin                                                    06455000
      <<octal>> begin                                                   06460000
                offset:=21;                                             06465000
                base:=8; end;                                           06470000
    <<integer>> begin                                                   06475000
                offset:=26;                                             06480000
                base:=-10; end;                                         06485000
      <<ascii>> offset:=21;                                             06490000
       <<code>> begin end;                                              06495000
<<octal'ascii>> begin offset:=21;                                <<nsf>>06500000
                base:=8; end;                                    <<nsf>>06505000
  end;  <<case>>                                                        06510000
                                                                        06515000
<<format and print 4,8 or 16 words at a time until done>>               06520000
<<unless deassembling, then only one word per line>>                    06525000
while curadr <= endadr and not stop'print do begin                      06530000
  buf:=" ";                                                             06535000
  move buf(1):=buf,(79);       <<clear output line>>                    06540000
                                                                        06545000
  if ctrly then begin                                                   06550000
    <<control-y has been entered - stop formatting>>                    06555000
    write'rec(fnum,lbuf,0,0);  <<to start new line>>                    06560000
    move buf:=" <CONTROL-Y>";                                           06565000
    write'rec(fnum,lbuf,-12,%60);                                       06570000
    return; end;                                                        06575000
                                                                        06580000
  <<determine number of words for current line>>                        06585000
  if mode = code'mode then                                              06590000
     begin                                                              06595000
     count:=1d;                                                         06600000
     if curadr+1d=endadr then lastline:=true;                           06605000
     end                                                                06610000
  else if mode = octal'ascii then                                <<nsf>>06615000
     begin                                                       <<nsf>>06620000
     if (count:=endadr-curadr+1d) > 4d then count:=4d;           <<nsf>>06625000
     if curadr+4d > endadr then lastline:=true;                  <<nsf>>06630000
     end                                                         <<nsf>>06635000
  else if mode = ascii'mode then                                 <<nsf>>06640000
     begin                                                       <<nsf>>06645000
     if (count:=endadr-curadr+1d) > 16d then count:=16d;         <<nsf>>06650000
     if curadr+16d > endadr then lastline:=true;                 <<nsf>>06655000
     end                                                         <<nsf>>06660000
  else begin                                                            06665000
     if (count:=endadr-curadr+1d) > 8d then count:=8d;                  06670000
     if curadr+8d > endadr then lastline:=true;                         06675000
     end;                                                               06680000
  use'pseudo'dst := false;                                              06685000
  getcore(curadr,integer(count),curline);                               06690000
  if <> then return;                                                    06695000
  use'pseudo'dst := true;                                               06700000
  if not match'suppress then begin                               <<nsf>>06705000
    <<compare for duplicate line>>                                      06710000
    if pcount > 0d then                                                 06715000
      if curbytes = prevbytes,(integer(count)*2) then            <<nsf>>06720000
         begin                                                          06725000
         previous'match:=current'match;                                 06730000
         current'match:=true;                                           06735000
         end else begin                                                 06740000
             previous'match := current'match;                           06745000
             current'match  := false;                                   06750000
         end;                                                           06755000
    if (previous'match land not current'match) or                       06760000
       (current'match land lastline) then begin                         06765000
      <<had previous match - must print line>>                          06770000
      move buf:="LINES";                                                06775000
      ascii(logical(lastadr+8d),8,buf(6));                              06780000
      buf(13):="-";                                                     06785000
      ascii(logical(curadr-1d),8,buf(15));                              06790000
      move buf(22):="SAME AS ABOVE";                                    06795000
      write'rec(fnum,lbuf,-35,0);                                       06800000
      buf:=" ";                                                         06805000
      move buf(1):=buf,(79);  <<clear output line>>                     06810000
      current'match:=false;                                             06815000
      previous'match:=false;                                            06820000
      end;                                                              06825000
    end else current'match:=false;                                      06830000
                                                                        06835000
  if not current'match then begin                                       06840000
    <<format current line -- max of 8 words>>                           06845000
    tos:=curadr;                                                        06850000
    if startadr > max'real'mem then tos := tos - dseg'base;             06855000
    address:=tos;                                                       06860000
    bank:=tos;                                                          06865000
    ascii(bank,8,tempbuf);                                              06870000
    if startadr <= max'real'mem then                                    06875000
    move buf:=tempbuf(3),(3);                                           06880000
    ascii(address,8,buf(4));                                            06885000
    buf(11):="(";                                                       06890000
    buf(18):=")";                                                       06895000
    buf(19):=":";                                                       06900000
    ascii(logical(pcount),8,buf(12));                                   06905000
                                                                        06910000
    <<format the words from memory>>                                    06915000
    for i:=0 until integer(count)-1 do                                  06920000
      case mode of begin                                                06925000
                                                                        06930000
        << octal mode >>                                                06935000
        ascii(curline(i),base,buf(offset+i*7));                         06940000
                                                                        06945000
        << integer mode >>                                              06950000
        ascii(curline(i),base,buf(offset+i*7));                         06955000
                                                                        06960000
        << ascii mode >>                                                06965000
        begin                                                           06970000
          putchar(curline(i).(0:8),buf(offset+i*2));                    06975000
          putchar(curline(i).(8:8),buf(offset+i*2+1));                  06980000
                                                                        06985000
          <<print byte offset to the right>>                            06990000
          ascii(logical(pcount)*2,8,buf(56));                    <<nsf>>06995000
          buf(55):="(";                                          <<nsf>>07000000
          buf(62):=")";                                          <<nsf>>07005000
        end;                                                     <<nsf>>07010000
                                                                        07015000
        << code mode >>                                                 07020000
        begin                                                    <<nsf>>07025000
          ascii(curline(i),8,buf(21));                           <<nsf>>07030000
          codesize:=deassemble(j,buf(29),curline(i),curline(i+1));      07035000
        end;                                                     <<nsf>>07040000
                                                                        07045000
        << octal'ascii mode >>                                          07050000
        begin                                                           07055000
          ascii(curline(i),base,buf(offset+i*7));                       07060000
          putchar(curline(i).(0:8),buf(offset+29+i*2));          <<nsf>>07065000
          putchar(curline(i).(8:8),buf(offset+29+i*2+1));        <<nsf>>07070000
          ascii(logical(pcount)*2,8,buf(60));                    <<nsf>>07075000
          buf(59):="(";                                          <<nsf>>07080000
          buf(66):=")";                                          <<nsf>>07085000
        end;                                                            07090000
                                                                        07095000
      end;  << case >>                                                  07100000
                                                                        07105000
    lastadr:=curadr;                                                    07110000
    move prevline:=curline,(8);                                         07115000
                                                                        07120000
    write'rec(fnum,lbuf,-79,0); end;                                    07125000
                                                                        07130000
  <<update counters>>                                            <<nsf>>07135000
  if mode = code'mode then curadr:=curadr+1d                     <<nsf>>07140000
  else if mode = octal'ascii then curadr:=curadr+4d              <<nsf>>07145000
       else if mode = ascii'mode then curadr:=curadr+16d         <<nsf>>07150000
            else curadr:=curadr+8d;                              <<nsf>>07155000
                                                                        07160000
  if mode = code'mode then pcount:=pcount+1d                     <<nsf>>07165000
  else if mode = octal'ascii then pcount:=pcount+4d              <<nsf>>07170000
       else if mode = ascii'mode then pcount:=pcount+16d         <<nsf>>07175000
            else pcount:=pcount+8d; end;                         <<nsf>>07180000
                                                                        07185000
end;  <<octaldump>>                                                     07190000
$page"                  PROCEDURE DISPDUMP"                             07195000
$control segment=idat5                                                  07200000
<<*********************************************************>>    <<nsf>>07205000
<<  dispdump                                               >>    <<nsf>>07210000
<<--------------------------------------------------------->>    <<nsf>>07215000
<< routine to display values of memory locations during    >>    <<nsf>>07220000
<< the modify routine.  this is a modification of the      >>    <<nsf>>07225000
<< 'octaldump' routine.                                    >>    <<nsf>>07230000
<<*********************************************************>>    <<nsf>>07235000
                                                                 <<nsf>>07240000
procedure dispdump(dmpaddr,temp'valu,mode);                      <<nsf>>07245000
  value dmpaddr,temp'valu,mode;                                  <<nsf>>07250000
  integer mode;      << 0 <= octal    >>                         <<nsf>>07255000
                     << 1 <= integer  >>                         <<nsf>>07260000
                     << 2 <= ascii    >>                         <<nsf>>07265000
  double dmpaddr;    << dmpaddr of location to display >>        <<nsf>>07270000
  logical temp'valu;                                             <<nsf>>07275000
                                                                 <<nsf>>07280000
  begin                                                          <<nsf>>07285000
    logical bank,                                                <<nsf>>07290000
            address;                                             <<nsf>>07295000
    integer base;                                                <<nsf>>07300000
                                                                 <<nsf>>07305000
    byte array tempbuf(0:5);  <<temporary buffer>>               <<nsf>>07310000
                                                                 <<nsf>>07315000
    if not (octal'mode <= mode <= ascii'mode) then               <<nsf>>07320000
      return                                                     <<nsf>>07325000
    else                                                         <<nsf>>07330000
      case mode of begin                                         <<nsf>>07335000
        <<  octal  >> base:=8;                                   <<nsf>>07340000
        << integer >> base:=-10;                                 <<nsf>>07345000
        <<  ascii  >> base:=8;                                   <<nsf>>07350000
      end;  <<case>>                                             <<nsf>>07355000
                                                                 <<nsf>>07360000
    buf:=" ";                                                    <<nsf>>07365000
    move buf(1):=buf,(79);  << clear output line >>              <<nsf>>07370000
                                                                 <<nsf>>07375000
    tos:=dmpaddr;                                                <<nsf>>07380000
    if dmpaddr > max'real'mem then tos := tos - dseg'base;              07385000
    address:=tos;                                                <<nsf>>07390000
    bank:=tos;                                                   <<nsf>>07395000
    ascii(bank,8,tempbuf);                                       <<nsf>>07400000
    move buf:=tempbuf(3),(3);                                    <<nsf>>07405000
    ascii(address,8,buf(4));                                     <<nsf>>07410000
    move buf(11):="(      ) (  ) := ";                           <<nsf>>07415000
    if mode = integer'mode then                                  <<nsf>>07420000
      ascii(temp'valu,base,buf(17))                              <<nsf>>07425000
    else                                                         <<nsf>>07430000
      ascii(temp'valu,base,buf(12));                             <<nsf>>07435000
    putchar(temp'valu.(0:8),buf(21));                            <<nsf>>07440000
    putchar(temp'valu.(8:8),buf(22));                            <<nsf>>07445000
                                                                 <<nsf>>07450000
    print(lbuf,-27,%320); << no cr/lf at end of line >>                 07455000
                                                                 <<nsf>>07460000
end;  <<dispdump>>                                               <<nsf>>07465000
$control segment=idat4                                                  07470000
$page "                        PROCEDURE INIT "                         07475000
<<*****************                                                     07480000
** init          **                                                     07485000
*****************>>                                                     07490000
procedure init;                                                         07495000
begin                                                                   07500000
                                                                        07505000
integer dummy;  <<required by intrinsic "XCONTRAP">>                    07510000
                                                                        07515000
  << this procedure assumes the existence of the >>                     07520000
  << following global variables:                 >>                     07525000
  <<    cst'good      = |                        >>                     07530000
  <<    dst'good      = |--low core pointers     >>                     07535000
  <<    pcb'good      = |                        >>                     07540000
    <<  curmemarea    = memory block currently in>>                     07545000
  <<                    buffer                   >>                     07550000
  <<    infile        = file # for $stdinx       >>                     07555000
  <<    outfile       = file # for $stdlist      >>                     07560000
  <<    auto'text     = flag for info= use       >>              <<nsf>>07565000
  << new'firmware     = flag for new mapping hdwr>>              <<nsf>>07570000
  <<     live'sys     = flag for live sys use    >>                     07575000
  <<    maxmem        = largest valid memory add.>>                     07580000
  <<    sysdb         = system db                >>                     07585000
                                                                        07590000
                                                                        07595000
who(,capd);  << get capabilities >>                                     07600000
cst'good:=dst'good:=pcb'good:=true;                                     07605000
  new'text:=true;                                                       07610000
live'sys := false;                                             <<*nth*>>07615000
old'block'number := -1d;  << 1st core call calls disck >>               07620000
outfile:=fopen(,%410);                                         <<*nth*>>07625000
infile:=fopen(,%55);  <<$stdinx>>                                       07630000
auto'text:=false;                                                <<nsf>>07635000
ld'in'use:=false;                                                <<nsf>>07640000
new'firmware:=false;                                             <<nsf>>07645000
autostop'on:=false;                                                     07650000
stop'print:=false;                                                      07655000
reading'sysfile := false;                                               07660000
                                                               << hks >>07665000
print'file'open := false;                                      << hks >>07670000
print'enabled := false;                                        << hks >>07675000
                                                                        07680000
xcontrap(@controly,dummy);                                              07685000
                                                                        07690000
sysdb:=%1000d;                                                          07695000
end;  <<init>>                                                          07700000
$page "                    PROCEDURE PRINTERROR"                        07705000
<<***********************************************************>>         07710000
<< printerror                                                >>         07715000
<<----------------------------------------------------------->>         07720000
<< print error message for syntax error detected in command  >>         07725000
<<***********************************************************>>         07730000
procedure printerror(errornum);                                         07735000
  value errornum;                                                       07740000
  integer errornum;  <<# of error message to display>>                  07745000
begin                                                                   07750000
                                                                        07755000
  << this procedure assumes the existence of global >>                  07760000
  << variables "OUTFILE" and "CR"                    >>                 07765000
                                                                        07770000
integer length;                                                <<84302>>07775000
                                                                        07780000
logical array lbuf(0:39);      <<output buffer>>                        07785000
byte array     buf(*)=lbuf;                                             07790000
                                                                        07795000
case errornum of begin                                                  07800000
   <<0>> move buf:=" *** UNABLE TO PARSE COMMAND ***", 2;               07805000
   <<1>> move buf:=" *** SYNTAX ERROR <MODE> ***", 2;                   07810000
   <<2>> move buf:=" *** UNDEFINED MODE ***", 2;                        07815000
   <<3>> move buf:=" *** SYNTAX ERROR <COUNT> ***", 2;                  07820000
   <<4>> move buf:=" *** NEGATIVE COUNT ***", 2;                        07825000
   <<5>> move buf:=" *** SYNTAX ERROR <DISPLACEMENT> ***", 2;           07830000
   <<6>> move buf:=" *** INVALID DISPLACEMENT ***", 2;                  07835000
   <<7>> move buf:=" *** UNRECOGNIZED SYNTAX ***", 2;                   07840000
   <<8>> move buf:=" *** UNRECOGNIZED COMMAND ***", 2;                  07845000
   <<9>> move buf:=" *** SPECIFIED SEGMENT IS ABSENT ***", 2;           07850000
  <<10>> move buf:=" *** INCORRECT NUMBER OF PARAMETERS ***", 2;        07855000
  <<11>> move buf:=" *** INVALID FORMAT MODE ***", 2;                   07860000
  <<12>> move buf:=" *** SYNTAX ERROR ***", 2;                          07865000
  <<13>> move buf:=" *** UNABLE TO ACCESS DST TABLE ***", 2;            07870000
  <<14>> move buf:=" *** UNABLE TO ACCESS PCB TABLE ***", 2;            07875000
  <<15>> move buf:=" *** SPECIFIED PIN DOES NOT EXIST ***", 2;          07880000
  <<16>> move buf:=" *** INVALID ADDRESS GENERATED ***", 2;             07885000
  <<17>> move buf:=" *** I/O ERROR ON MEMORY DUMP DISC FILE ***", 2;    07890000
  <<18>> move buf:=" *** UNABLE TO ACCESS CST TABLE ***", 2;            07895000
  <<19>> move buf:=" *** INVALID EXPRESSION ***", 2;                    07900000
  <<20>> move buf:=" *** INVALID STACK ***", 2;                         07905000
  <<21>> move buf:=" *** UNABLE TO TEXT SPECIFIED FILE ***", 2;         07910000
  <<22>> move buf:=" *** OLD FILE NOT PURGED ***", 2;                   07915000
  <<23>> move buf:=" *** SPECIFIED FILE DOES NOT EXIST ***", 2;         07920000
  <<24>> move buf:=" *** SPECIFIED FILE IS NOT A MEMORY DUMP ***", 2;   07925000
  <<25>> move buf:=" *** UNABLE TO READ FROM TAPE ***", 2;              07930000
  <<26>> move buf:=" *** UNABLE TO WRITE TAPE TO DISC ***", 2;          07935000
  <<27>> move buf:=" *** UNABLE TO PLACE EOF ON TAPE ***", 2;           07940000
  <<28>> move buf:=" *** INVALID REGISTER ***", 2;                      07945000
  <<29>> move buf:=" *** INVALID ADDRESS ***", 2;                       07950000
  <<30>> move buf:=                                                     07955000
             "*** UNABLE TO KEEP PREVIOUS TAPE FILE ON DISC ***", 2;    07960000
  <<31>> move buf:=" *** WORKFILE IS TEMPORARY ***", 2;                 07965000
  <<32>> move buf:=" *** You must text in a file first ***", 2;         07970000
  <<33>> move buf:=" *** PROCINFO error getting group.acct ***", 2;     07975000
  <<34>> move buf:=" *** Insufficient stack space for HELPROC ***", 2;  07980000
  <<35>> move buf:=" *** Invalid stack: Delta Q = 0 ***", 2;            07985000
  <<36>> move buf:=" *** Save this tape! ***@@@@", 2;          07990000
  <<37>> move buf:=                                                     07995000
         "You cannot text in a Series II dump file from disc. ***", 2;  08000000
  <<38>> move buf:=" *** File name is too long ***", 2;                 08005000
  <<39>> move buf:=" *** Couldn't open IDATHELP ***", 2;                08010000
  <<40>> move buf:=" *** PREP OR RUN WITH MAXDATA >= 16384. ***", 2;    08015000
  <<41>> move buf:=" *** SYNTAX ERROR <MATCH'SUPPRESS> ***",2;   <<nsf>>08020000
  <<42>> move buf:=" *** UNDEFINED MATCH'SUPPRESS FLAG ***",2;   <<nsf>>08025000
  <<43>> move buf:=" *** CANNOT OPEN FILE 'IDATLIST' ***",2;     <<nsf>>08030000
  <<44>> move buf:=" *** FCLOSE ERROR ON OUTPUT FILE ***",2;     <<nsf>>08035000
  <<45>> move buf:=" *** DEVICE MUST BE <= 8 CHARS. ***",2;      <<nsf>>08040000
  <<46>> move buf:=" *** FILE 'IDATLIST' ALREADY OPEN ***",2;    <<nsf>>08045000
  <<47>> move buf:=" (FILE REMAINS UNCHANGED) ",2;               <<nsf>>08050000
  <<48>> move buf:=" *** INVALID FORMAT FOR JMAT DST ***",2;     <<nsf>>08055000
  <<49>> move buf:=" *** UNABLE TO ACCESS JMAT TABLE ***",2;     <<nsf>>08060000
  <<50>> move buf:=" *** UNABLE TO ACCESS LOG. DEV. TABLE ***",2;<<nsf>>08065000
  <<51>> move buf:=" *** INVALID FORMAT FOR LDT DST ***",2;      <<nsf>>08070000
  <<52>> move buf:=" *** 'INFO=' FILE NOT FOUND ***",2;          <<nsf>>08075000
  <<53>> move buf:=" (WARNING - ONLY FIRST 2 CHARACTERS USED)",2;<<nsf>>08080000
  <<54>> move buf:=" *** INVALID VALUE OR FORMAT ***",2;         <<nsf>>08085000
  <<55>> move buf:=" (NEW FILE WILL OVERRIDE OLD FILE)",2;       <<nsf>>08090000
  <<56>> move buf:=" *** INVALID FORMAT FOR FILENAME ***",2;     <<nsf>>08095000
  <<57>> move buf:=" *** FOPEN OF LOADMAP FILE FAILED ***",2;    <<nsf>>08100000
  <<58>> move buf:=" *** SPECIFIED FILE IS NOT A LOADMAP ***",2; <<nsf>>08105000
  <<59>> move buf:=" *** V.UU.FF MIS-MATCH ***",2;               <<nsf>>08110000
  <<60>> move buf:=" *** FREADDIR ERROR ON LOADMAP ***",2;              08115000
  <<61>> move buf:=                                              <<nsf>>08120000
          " *** SPECIFIED ADDRESS NOT WITHIN ICS STACK ***",2;   <<nsf>>08125000
  <<62>> move buf:=(" *** THIS FEATURE NOT SUPPORTED FOR USE ",         08130000
          "ON THE LIVE SYSTEM ***"),2;                                  08135000
  <<63>> move buf:=                                                     08140000
       " *** PRINT FILE WAS NOT OPENED, COMMAND IGNORED ***",2;<< hks >>08145000
  <<64>> move buf:=                                                     08150000
       "THIS FEATURE NOT SUPPORTED FOR MPE-IV DUMPS",2;                 08155000
  <<65>> move buf:=" *** UNABLE TO FORMAT DRQ ***",2;                   08160000
  <<66>> move buf:=                                                     08165000
         " *** UNABLE TO FORMAT DRQ - POSSIBLE CORRUPTION ***",2;       08170000
  <<67>> move buf:=                                                     08175000
         " *** WARNING: SYSDB & DST POINTERS DON'T AGREE ***",2;        08180000
  <<68>> move buf:=" *** LDEV NUMBER > MAX LDEV ***",2;                 08185000
  <<69>> move buf:=" *** UNDEFINED MPE COMMAND ***",2;                  08190000
  <<70>> move buf:=" *** COUNT OR OFFSET IS NEGATIVE ***", 2;           08195000
  <<71>> move buf:=" *** DSTNUMBER IS OUT OF RANGE ***", 2;             08200000
  <<72>> move buf:=" *** DST IS NOT IN USE ***", 2;                     08205000
  <<73>> move buf:=" *** OFFSET + COUNT IS OUT OF DST BOUNDS ***", 2;   08210000
  <<74>> move buf:=" *** TARGET LENGTH TOO SMALL ***", 2;               08215000
  <<75>> move buf:=" *** MFDS UNABLE TO TRANSFER DATA ***", 2;          08220000
  <<76>> move buf:=" *** LFDS UNABLE TO TRANSFER DATA ***", 2;          08225000
  <<77>> move buf:=" *** DLFDS UNABLE TO TRANSFER DATA ***", 2;         08230000
  <<78>> move buf:=                                                     08235000
          "*** INVALID SYSTEM FILE ADDR GENERATED ***", 2;              08240000
  <<79>> move buf:=                                                     08245000
          "LOADMAP FILE ALREADY AUTOMATICALLY IN USE", 2;               08250000
  <<80>> move buf:=                                                     08255000
          " *** FIRST LETTER CANNOT BE ""V"" ***", 2;                   08260000
  <<81>> move buf:= "INVALID SYSTEM FILE ADDRESS", 2;                   08265000
  <<82>> move buf:=                                                     08270000
        "*** REAL AND VIRTUAL FILE TIME STAMP MISMATCH ***", 2;         08275000
  <<83>> move buf:=                                                     08280000
         " *** MOD TO VIRTUAL DST ENTRY NOT ALLOWED ***", 2;            08285000
  <<84>> move buf:=" *** REQUIRES SYSMGR CAPABILITY ***", 2;            08290000
  <<85>> move buf:=" *** UNASSIGNED PIN ***", 2;                        08295000
  <<86>> move buf:=" *** INVALID STACK ADDRESS ***", 2;                 08300000
                                                                        08305000
end;  <<case>>                                                          08310000
                                                                        08315000
length := tos - @buf;                                          <<84302>>08320000
                                                                        08325000
print(lbuf, -length, 0);                                                08330000
                                                                        08335000
end;  <<printerror>>                                                    08340000
$page "                    PROCEDURE GETCSTADDR"                        08345000
<<***********************************************************>>         08350000
<< getcstaddr                                                >>         08355000
<<----------------------------------------------------------->>         08360000
<< return address of a cst  (if the cst is not absent)       >>         08365000
<<***********************************************************>>         08370000
double procedure getcstaddr(cstnum);                                    08375000
  value cstnum;                                                         08380000
  integer cstnum;  <<cst of interest>>                                  08385000
begin                                                                   08390000
                                                                        08395000
  << condition code is returned as follows:      >>                     08400000
  <<                                             >>                     08405000
  <<   ccg - cst is absent                       >>                     08410000
  <<   cce - successful                          >>                     08415000
  <<   ccl - unable to use the cst table         >>                     08420000
                                                                        08425000
  << this porcedure assumes the existence of the>>                      08430000
  << global variables:                          >>                      08435000
  <<     cst'good          printerror (proc)    >>                      08440000
  <<     core (proc)       getcore (proc)       >>                      08445000
                                                                        08450000
define          cc = status.(6:2)#,                                     08455000
          cst'addr = cstentry(3)#,                                      08460000
          cst'bank = cstentry(2)#,                                      08465000
       present'cst = not cstentry(0).(0:1)                              08470000
                      or cstentry(1).(1:1)#;                            08475000
                                                                        08480000
logical  status = q-1;  <<status register from marker>>                 08485000
double entryaddr;         <<address of cst entry in question>>          08490000
                                                                        08495000
logical array cstentry(0:3);  <<cst entry for segment>>                 08500000
                                                                        08505000
cc:=cce;   <<assume no errors>>                                         08510000
if not cst'good then begin                                              08515000
  cc:=ccl;                                                              08520000
  printerror(18);                                                       08525000
  return; end;                                                          08530000
                                                                        08535000
entryaddr:=double(core(0d)+logical(cstnum)*4);                          08540000
getcore(entryaddr,4,cstentry);                                          08545000
                                                                        08550000
if present'cst then begin                                               08555000
  tos:=cst'bank;                                                        08560000
  tos:=cst'addr;                                                        08565000
  getcstaddr:=tos; end                                                  08570000
else begin                                                              08575000
  cc:=ccg;   <<segment is absent>>                                      08580000
  printerror(9); end;                                                   08585000
                                                                        08590000
end;  <<getcstaddr>>                                                    08595000
$page "                    PROCEDURE GETDSTADDR"                        08600000
<<***********************************************************>>         08605000
<< getdstaddr                                                >>         08610000
<<----------------------------------------------------------->>         08615000
<< return address of a dst  (if the dst is not absent)       >>         08620000
<<***********************************************************>>         08625000
double procedure getdstaddr(dstnum);                                    08630000
  value dstnum;                                                         08635000
  integer dstnum;  <<dst of interest>>                                  08640000
begin                                                                   08645000
                                                                        08650000
  << condition code is returned as follows:      >>                     08655000
  <<                                             >>                     08660000
  <<   ccg - dst is absent                       >>                     08665000
  <<   cce - successful                          >>                     08670000
  <<   ccl - unable to use the dst table         >>                     08675000
                                                                        08680000
  << this procedure assumes the existence of the>>                      08685000
  << following global variables:                >>                      08690000
  <<     dst'good          printerror (proc)    >>                      08695000
  <<     core (proc)       getcore (proc)       >>                      08700000
                                                                        08705000
define cc=status.(6:2)#;                                                08710000
define    dst'addr = dstentry(3)#,                                      08715000
          dst'bank = dstentry(2)#,                                      08720000
       present'dst = not dstentry(0).(0:1)                              08725000
                      or dstentry(1).(1:1)#;                            08730000
                                                                        08735000
logical  status = q-1;  <<status register from marker>>                 08740000
double entryaddr;         <<address of dst entry in question>>          08745000
                                                                        08750000
logical array dstentry(0:3);  <<dst entry for segment>>                 08755000
                                                                        08760000
cc:=cce;   <<assume no errors>>                                         08765000
if not dst'good then begin                                              08770000
  cc:=ccl;                                                              08775000
  printerror(13);                                                       08780000
  return; end;                                                          08785000
                                                                        08790000
entryaddr:=double(core(2d)+logical(dstnum)*4);                          08795000
getcore(entryaddr,4,dstentry);                                          08800000
                                                                        08805000
if present'dst then begin                                               08810000
  tos:=dst'bank;                                                        08815000
  tos:=dst'addr;                                                        08820000
  getdstaddr:=tos; end                                                  08825000
else begin                                                              08830000
  cc:=ccg;   <<segment is absent>>                                      08835000
  getdstaddr:=0d; end;                                                  08840000
                                                                        08845000
end;  <<getdstaddr>>                                                    08850000
$page "                    PROCEDURE GETNUMBER"                         08855000
$page "                    PROCEDURE MFDS"                     <<dougw>>08860000
<<***********************************************************>><<dougw>>08865000
<<  mfds                                                     >><<dougw>>08870000
<<----------------------------------------------------------->><<dougw>>08875000
<< move words from a dst                                     >><<dougw>>08880000
<<***********************************************************>><<dougw>>08885000
procedure mfds (target, dstnumber, offset, count);             <<dougw>>08890000
   value                dstnumber, offset, count;              <<dougw>>08895000
   integer              dstnumber, offset, count;              <<dougw>>08900000
   array        target;                                        <<dougw>>08905000
begin                                                          <<dougw>>08910000
                                                               <<dougw>>08915000
  << condition code is returned as follows:                  >><<dougw>>08920000
  <<                                                         >><<dougw>>08925000
  <<   ccg - dst is unavailable                              >><<dougw>>08930000
  <<   cce - successful                                      >><<dougw>>08935000
  <<   ccl - unable to do the transfer for one               >><<dougw>>08940000
  <<         the following reasons:                          >><<dougw>>08945000
  <<      1) count or offset is negative                     >><<dougw>>08950000
  <<      2) dstnumber is invalid                            >><<dougw>>08955000
  <<         a)  it is negative                              >><<dougw>>08960000
  <<         b)  it is > last entry in dst table             >><<dougw>>08965000
  <<      3) segment dstnumber is not in use                 >><<dougw>>08970000
  <<      4) offset + count is not in segment                >><<dougw>>08975000
  <<      5) either target(0) or target (count-1)            >><<dougw>>08980000
  <<         would cause a bounds violation                  >><<dougw>>08985000
  <<         (i.e. not between dl & q register-8)            >><<dougw>>08990000
  <<      6) the dst table is unusable                       >><<dougw>>08995000
                                                               <<dougw>>09000000
  << this procedure assumes the existence of the             >><<dougw>>09005000
  << following global variables:                             >><<dougw>>09010000
  <<   live'sys            getcore (proc)                    >><<dougw>>09015000
  <<   dst'good            printerror (proc)                 >><<dougw>>09020000
                                                               <<dougw>>09025000
define cc=status.(6:2)#;                                       <<dougw>>09030000
define    dst'addr = dstentry(3)#,                             <<dougw>>09035000
          dst'bank = dstentry(2)#,                             <<dougw>>09040000
          dst'size = dstentry.(3:13)#,                         <<dougw>>09045000
       present'dst = not dstentry(0).(0:1)                     <<dougw>>09050000
                      or dstentry(1).(1:1)#;                   <<dougw>>09055000
                                                               <<dougw>>09060000
logical  status = q-1;  <<status register from marker>>        <<dougw>>09065000
double entryaddr;         <<address of dst entry in question>> <<dougw>>09070000
double dstaddr;           << memory address of dst >>          <<dougw>>09075000
                                                               <<dougw>>09080000
integer   buf'addr=q-7, <<address of buffer area             >><<dougw>>09085000
                dl,     <<current value of dl register       >><<dougw>>09090000
            dstlen,     <<length of source data segment      >><<dougw>>09095000
         firstaddr,     <<address of 1st word in buffer area >><<dougw>>09100000
          lastaddr,     <<address of last word in buffer area>><<dougw>>09105000
                 q;     <<curr value of q register (adjusted)>><<dougw>>09110000
                                                               <<dougw>>09115000
logical array dstentry(0:3);  <<dst entry for segment>>        <<dougw>>09120000
                                                               <<dougw>>09125000
subroutine print'parms;                                        <<dougw>>09130000
begin                                                          <<dougw>>09135000
   buf := " "; move buf (1) := buf, (79);                      <<dougw>>09140000
   move buf := "DST=%XXXXXX, OFFSET=%XXXXXX, COUNT=%XXXXXX";   <<dougw>>09145000
   ascii (dstnumber, 8, buf (5));                              <<dougw>>09150000
   ascii (offset,    8, buf (21));                             <<dougw>>09155000
   ascii (count,     8, buf (36));                             <<dougw>>09160000
   print (lbuf, -42, 0);                                       <<dougw>>09165000
end;                                                           <<dougw>>09170000
                                                               <<dougw>>09175000
                                                               <<dougw>>09180000
cc:=cce;   <<assume no errors>>                                <<dougw>>09185000
if not dst'good then                                           <<dougw>>09190000
   begin                                                       <<dougw>>09195000
      cc := ccl;                                               <<dougw>>09200000
      printerror (13);  <<unable to access dst table>>         <<dougw>>09205000
      return;                                                  <<dougw>>09210000
   end;                                                        <<dougw>>09215000
                                                               <<dougw>>09220000
if (count <= 0) or (offset < 0) then                           <<dougw>>09225000
   begin                                                       <<dougw>>09230000
      cc := ccl;                                               <<dougw>>09235000
      printerror (75);                                         <<dougw>>09240000
      printerror (70); << count or start is negative >>        <<dougw>>09245000
      print'parms;                                             <<dougw>>09250000
      return;                                                  <<dougw>>09255000
   end;                                                        <<dougw>>09260000
                                                               <<dougw>>09265000
if (dstnumber < 1) or                                          <<dougw>>09270000
   (dstnumber > integer(core(double(core(2d))))) then          <<dougw>>09275000
   begin                                                       <<dougw>>09280000
      cc := ccl;                                               <<dougw>>09285000
      printerror (75);                                         <<dougw>>09290000
      printerror (71); << dst number range error >>            <<dougw>>09295000
      print'parms;                                             <<dougw>>09300000
      return;                                                  <<dougw>>09305000
   end;                                                        <<dougw>>09310000
                                                               <<dougw>>09315000
<< check for bounds violation on move to target >>             <<dougw>>09320000
firstaddr := buf'addr;                                         <<dougw>>09325000
lastaddr  := buf'addr + count - 1;                             <<dougw>>09330000
push (dl,q);                                                   <<dougw>>09335000
dl := tos;                                                     <<dougw>>09340000
q  := tos - 8; << adjust for stack marker, and parms >>        <<dougw>>09345000
if not (dl <= firstaddr <= q) or                               <<dougw>>09350000
   not (dl <= lastaddr  <= q) then                             <<dougw>>09355000
   begin                                                       <<dougw>>09360000
      cc := ccl;                                               <<dougw>>09365000
      printerror (75);                                         <<dougw>>09370000
      printerror (74); << target bounds violation >>           <<dougw>>09375000
      return;                                                  <<dougw>>09380000
   end;                                                        <<dougw>>09385000
                                                               <<dougw>>09390000
if live'sys then                                               <<dougw>>09395000
   pdisable;   << psuedo disable during mfds >>                <<dougw>>09400000
                                                               <<dougw>>09405000
entryaddr:=double(core(2d)+logical(dstnumber)*4);              <<dougw>>09410000
getcore(entryaddr,4,dstentry);                                 <<dougw>>09415000
                                                               <<dougw>>09420000
if dstentry = %100000 then                                     <<dougw>>09425000
   begin                                                       <<dougw>>09430000
      if live'sys then                                         <<dougw>>09435000
         penable;         << re-enable       >>                <<dougw>>09440000
      cc := ccl;                                               <<dougw>>09445000
      printerror (75); << mfds transfer error >>               <<dougw>>09450000
      printerror (72); << dst not in use  >>                   <<dougw>>09455000
      print'parms;                                             <<dougw>>09460000
      return;                                                  <<dougw>>09465000
   end;                                                        <<dougw>>09470000
                                                               <<dougw>>09475000
dstlen := dst'size * 4;                                        <<dougw>>09480000
if (offset + count) > dstlen or overflow then                           09485000
   begin                                                       <<dougw>>09490000
      if live'sys then                                         <<dougw>>09495000
         penable;         << re-enable       >>                <<dougw>>09500000
      cc := ccl;                                               <<dougw>>09505000
      printerror (75);                                         <<dougw>>09510000
      printerror (73); << offset+count not in dst >>           <<dougw>>09515000
      print'parms;                                             <<dougw>>09520000
      return;                                                  <<dougw>>09525000
   end;                                                        <<dougw>>09530000
                                                               <<dougw>>09535000
if live'sys then                                               <<dougw>>09540000
   begin << use mfds instruction >>                            <<dougw>>09545000
      << dst is still allocated do mfds instruction >>         <<dougw>>09550000
      tos := @target;   << @target in d >>                     <<dougw>>09555000
      tos := dstnumber; << dst     in c >>                     <<dougw>>09560000
      tos := offset;    << offset  in b >>                     <<dougw>>09565000
      tos := count;     << count   in a >>                     <<dougw>>09570000
                                                               <<dougw>>09575000
      penable; << re-enable >>                                 <<dougw>>09580000
      assemble (mfds 4);<< sdec 4 words >>                     <<dougw>>09585000
      return;                                                  <<dougw>>09590000
   end << live mode >>                                         <<dougw>>09595000
else                                                           <<dougw>>09600000
   begin << looking at a dump >>                               <<dougw>>09605000
      if present'dst then                                      <<dougw>>09610000
         begin                                                 <<dougw>>09615000
            tos := dst'bank;                                   <<dougw>>09620000
            tos := dst'addr;                                   <<dougw>>09625000
            dstaddr := tos;                                    <<dougw>>09630000
            getcore (dstaddr + double (offset),                <<dougw>>09635000
                     count, target);                           <<dougw>>09640000
         end                                                   <<dougw>>09645000
      else                                                     <<dougw>>09650000
         begin << dst absent see if sdf dumped it >>           <<dougw>>09655000
            cc := ccg;   <<segment is unavailable            >><<dougw>>09660000
         end                                                   <<dougw>>09665000
   end; << looking at a dump >>                                <<dougw>>09670000
                                                               <<dougw>>09675000
end;  <<mfds>>                                                 <<dougw>>09680000
$page "                    PROCEDURE LFDS"                     <<dougw>>09685000
<<***********************************************************>><<dougw>>09690000
<<  lfds                                                     >><<dougw>>09695000
<<----------------------------------------------------------->><<dougw>>09700000
<< load a word from a dst                                    >><<dougw>>09705000
<<***********************************************************>><<dougw>>09710000
logical procedure lfds (dstnumber, offset);                    <<dougw>>09715000
   value                dstnumber, offset;                     <<dougw>>09720000
   integer              dstnumber, offset;                     <<dougw>>09725000
begin                                                          <<dougw>>09730000
                                                               <<dougw>>09735000
  << condition code is returned as follows:                  >><<dougw>>09740000
  <<                                                         >><<dougw>>09745000
  <<   ccg - dst is unavailable                              >><<dougw>>09750000
  <<   cce - successful                                      >><<dougw>>09755000
  <<   ccl - unable to do the transfer for one of            >><<dougw>>09760000
  <<         the following reasons:                          >><<dougw>>09765000
  <<      1) offset is negative                              >><<dougw>>09770000
  <<      2) dstnumber is invalid                            >><<dougw>>09775000
  <<         a)  it is negative                              >><<dougw>>09780000
  <<         b)  it is > last entry in dst table             >><<dougw>>09785000
  <<      3) segment dstnumber is not in use                 >><<dougw>>09790000
  <<      4) the dst table is unusable                       >><<dougw>>09795000
                                                               <<dougw>>09800000
  << this procedure assumes the existence of the             >><<dougw>>09805000
  << following global variables:                             >><<dougw>>09810000
  <<   live'sys            getcore (proc)                    >><<dougw>>09815000
  <<   dst'good            printerror (proc)                 >><<dougw>>09820000
                                                               <<dougw>>09825000
define cc=status.(6:2)#;                                       <<dougw>>09830000
define    dst'addr = dstentry(3)#,                             <<dougw>>09835000
          dst'bank = dstentry(2)#,                             <<dougw>>09840000
          dst'size = dstentry.(3:13)#,                         <<dougw>>09845000
       present'dst = not dstentry(0).(0:1)                     <<dougw>>09850000
                      or dstentry(1).(1:1)#;                   <<dougw>>09855000
                                                               <<dougw>>09860000
logical lfds'val = lfds; << return value of procedure >>       <<dougw>>09865000
                                                               <<dougw>>09870000
logical  status = q-1;  <<status register from marker>>        <<dougw>>09875000
double entryaddr;         <<address of dst entry in question>> <<dougw>>09880000
double dstaddr;           << memory address of dst >>          <<dougw>>09885000
                                                               <<dougw>>09890000
integer     dstlen;     <<length of source data segment      >><<dougw>>09895000
                                                               <<dougw>>09900000
logical array dstentry(0:3);  <<dst entry for segment>>        <<dougw>>09905000
                                                               <<dougw>>09910000
subroutine print'parms;                                        <<dougw>>09915000
begin                                                          <<dougw>>09920000
   buf := " "; move buf (1) := buf, (79);                      <<dougw>>09925000
   move buf := "DST=%XXXXXX, OFFSET=%XXXXXX";                  <<dougw>>09930000
   ascii (dstnumber, 8, buf (5));                              <<dougw>>09935000
   ascii (offset,    8, buf (21));                             <<dougw>>09940000
   print (lbuf, -42, 0);                                       <<dougw>>09945000
end;                                                           <<dougw>>09950000
                                                               <<dougw>>09955000
                                                               <<dougw>>09960000
cc:=cce;   <<assume no errors>>                                <<dougw>>09965000
if not dst'good then                                           <<dougw>>09970000
   begin                                                       <<dougw>>09975000
      cc := ccl;                                               <<dougw>>09980000
      printerror (13);  <<unable to access dst table>>         <<dougw>>09985000
      return;                                                  <<dougw>>09990000
   end;                                                        <<dougw>>09995000
                                                               <<dougw>>10000000
if (offset < 0) then                                           <<dougw>>10005000
   begin                                                       <<dougw>>10010000
      cc := ccl;                                               <<dougw>>10015000
      printerror (76);                                         <<dougw>>10020000
      printerror (70); << count or start is negative >>        <<dougw>>10025000
      print'parms;                                             <<dougw>>10030000
      return;                                                  <<dougw>>10035000
   end;                                                        <<dougw>>10040000
                                                               <<dougw>>10045000
if (dstnumber < 1) or                                          <<dougw>>10050000
   (dstnumber > integer(core(double(core(2d))))) then          <<dougw>>10055000
   begin                                                       <<dougw>>10060000
      cc := ccl;                                               <<dougw>>10065000
      printerror (76);                                         <<dougw>>10070000
      printerror (71); << dst number range error >>            <<dougw>>10075000
      print'parms;                                             <<dougw>>10080000
      return;                                                  <<dougw>>10085000
   end;                                                        <<dougw>>10090000
                                                               <<dougw>>10095000
if live'sys then                                               <<dougw>>10100000
   pdisable;   << psuedo disable during lfds >>                <<dougw>>10105000
                                                               <<dougw>>10110000
entryaddr:=double(core(2d)+logical(dstnumber)*4);              <<dougw>>10115000
getcore(entryaddr,4,dstentry);                                 <<dougw>>10120000
                                                               <<dougw>>10125000
if dstentry = %100000 then                                     <<dougw>>10130000
   begin                                                       <<dougw>>10135000
      if live'sys then                                         <<dougw>>10140000
         penable;         << re-enable       >>                <<dougw>>10145000
      cc := ccl;                                               <<dougw>>10150000
      printerror (76); << lfds transfer error >>               <<dougw>>10155000
      printerror (72); << dst not in use  >>                   <<dougw>>10160000
      print'parms;                                             <<dougw>>10165000
      return;                                                  <<dougw>>10170000
   end;                                                        <<dougw>>10175000
                                                               <<dougw>>10180000
dstlen := dst'size * 4;                                        <<dougw>>10185000
if (offset + 1) > dstlen then                                  <<dougw>>10190000
   begin                                                       <<dougw>>10195000
      if live'sys then                                         <<dougw>>10200000
         penable;         << re-enable       >>                <<dougw>>10205000
      cc := ccl;                                               <<dougw>>10210000
      printerror (76);                                         <<dougw>>10215000
      printerror (73); << offset+count not in dst >>           <<dougw>>10220000
      print'parms;                                             <<dougw>>10225000
      return;                                                  <<dougw>>10230000
   end;                                                        <<dougw>>10235000
                                                               <<dougw>>10240000
if live'sys then                                               <<dougw>>10245000
   begin << use lfds instruction >>                            <<dougw>>10250000
      << dst is still allocated do lfds instruction >>         <<dougw>>10255000
      tos := @lfds'val; << @target in d >>                     <<dougw>>10260000
      tos := dstnumber; << dst     in c >>                     <<dougw>>10265000
      tos := offset;    << offset  in b >>                     <<dougw>>10270000
      tos := 1;         << count   in a >>                     <<dougw>>10275000
                                                               <<dougw>>10280000
      penable; << re-enable >>                                 <<dougw>>10285000
      assemble (mfds 4);<< sdec 4 words >>                     <<dougw>>10290000
      return;                                                  <<dougw>>10295000
   end << live mode >>                                         <<dougw>>10300000
else                                                           <<dougw>>10305000
   begin << looking at a dump >>                               <<dougw>>10310000
      if present'dst then                                      <<dougw>>10315000
         begin                                                 <<dougw>>10320000
            tos := dst'bank;                                   <<dougw>>10325000
            tos := dst'addr;                                   <<dougw>>10330000
            dstaddr := tos;                                    <<dougw>>10335000
            lfds := core (dstaddr + double (offset));          <<dougw>>10340000
         end                                                   <<dougw>>10345000
      else                                                     <<dougw>>10350000
         begin << dst absent see if sdf dumped it >>           <<dougw>>10355000
            cc := ccg;   <<segment is unavailable            >><<dougw>>10360000
         end                                                   <<dougw>>10365000
   end; << looking at a dump >>                                <<dougw>>10370000
                                                               <<dougw>>10375000
end;  <<lfds>>                                                 <<dougw>>10380000
$page "                    PROCEDURE DLFDS"                    <<dougw>>10385000
<<***********************************************************>><<dougw>>10390000
<<  dlfds                                                    >><<dougw>>10395000
<<----------------------------------------------------------->><<dougw>>10400000
<< load two words from a dst                                 >><<dougw>>10405000
<<***********************************************************>><<dougw>>10410000
double procedure dlfds (dstnumber, offset);                    <<dougw>>10415000
   value                dstnumber, offset;                     <<dougw>>10420000
   integer              dstnumber, offset;                     <<dougw>>10425000
begin                                                          <<dougw>>10430000
                                                               <<dougw>>10435000
  << condition code is returned as follows:                  >><<dougw>>10440000
  <<                                                         >><<dougw>>10445000
  <<   ccg - dst is unavailable                              >><<dougw>>10450000
  <<   cce - successful                                      >><<dougw>>10455000
  <<   ccl - unable to do the transfer for one of            >><<dougw>>10460000
  <<         the following reasons:                          >><<dougw>>10465000
  <<      1) offset is negative                              >><<dougw>>10470000
  <<      2) dstnumber is invalid                            >><<dougw>>10475000
  <<         a)  it is negative                              >><<dougw>>10480000
  <<         b)  it is > last entry in dst table             >><<dougw>>10485000
  <<      3) segment dstnumber is not in use                 >><<dougw>>10490000
  <<      4) the dst table is unusable                       >><<dougw>>10495000
                                                               <<dougw>>10500000
  << this procedure assumes the existence of the             >><<dougw>>10505000
  << following global variables:                             >><<dougw>>10510000
  <<   live'sys            getcore (proc)                    >><<dougw>>10515000
  <<   dst'good            printerror (proc)                 >><<dougw>>10520000
                                                               <<dougw>>10525000
define cc=status.(6:2)#;                                       <<dougw>>10530000
define    dst'addr = dstentry(3)#,                             <<dougw>>10535000
          dst'bank = dstentry(2)#,                             <<dougw>>10540000
          dst'size = dstentry.(3:13)#,                         <<dougw>>10545000
       present'dst = not dstentry(0).(0:1)                     <<dougw>>10550000
                      or dstentry(1).(1:1)#;                   <<dougw>>10555000
                                                               <<dougw>>10560000
double dlfds'val = dlfds; << return value of procedure >>      <<dougw>>10565000
                                                               <<dougw>>10570000
logical  status = q-1;  <<status register from marker>>        <<dougw>>10575000
double entryaddr;         <<address of dst entry in question>> <<dougw>>10580000
double dstaddr;           << memory address of dst >>          <<dougw>>10585000
                                                               <<dougw>>10590000
integer     dstlen;     <<length of source data segment      >><<dougw>>10595000
                                                               <<dougw>>10600000
logical array dstentry(0:3);  <<dst entry for segment>>        <<dougw>>10605000
                                                               <<dougw>>10610000
subroutine print'parms;                                        <<dougw>>10615000
begin                                                          <<dougw>>10620000
   buf := " "; move buf (1) := buf, (79);                      <<dougw>>10625000
   move buf := "DST=%XXXXXX, OFFSET=%XXXXXX";                  <<dougw>>10630000
   ascii (dstnumber, 8, buf (5));                              <<dougw>>10635000
   ascii (offset,    8, buf (21));                             <<dougw>>10640000
   print (lbuf, -42, 0);                                       <<dougw>>10645000
end;                                                           <<dougw>>10650000
                                                               <<dougw>>10655000
                                                               <<dougw>>10660000
cc:=cce;   <<assume no errors>>                                <<dougw>>10665000
if not dst'good then                                           <<dougw>>10670000
   begin                                                       <<dougw>>10675000
      cc := ccl;                                               <<dougw>>10680000
      printerror (13);  <<unable to access dst table>>         <<dougw>>10685000
      return;                                                  <<dougw>>10690000
   end;                                                        <<dougw>>10695000
                                                               <<dougw>>10700000
if (offset < 0) then                                           <<dougw>>10705000
   begin                                                       <<dougw>>10710000
      cc := ccl;                                               <<dougw>>10715000
      printerror (77);                                         <<dougw>>10720000
      printerror (70); << count or start is negative >>        <<dougw>>10725000
      print'parms;                                             <<dougw>>10730000
      return;                                                  <<dougw>>10735000
   end;                                                        <<dougw>>10740000
                                                               <<dougw>>10745000
if (dstnumber < 1) or                                          <<dougw>>10750000
   (dstnumber > integer(core(double(core(2d))))) then          <<dougw>>10755000
   begin                                                       <<dougw>>10760000
      cc := ccl;                                               <<dougw>>10765000
      printerror (77);                                         <<dougw>>10770000
      printerror (71); << dst number range error >>            <<dougw>>10775000
      print'parms;                                             <<dougw>>10780000
      return;                                                  <<dougw>>10785000
   end;                                                        <<dougw>>10790000
                                                               <<dougw>>10795000
if live'sys then                                               <<dougw>>10800000
   pdisable;   << psuedo disable during lfds >>                <<dougw>>10805000
                                                               <<dougw>>10810000
entryaddr:=double(core(2d)+logical(dstnumber)*4);              <<dougw>>10815000
getcore(entryaddr,4,dstentry);                                 <<dougw>>10820000
                                                               <<dougw>>10825000
if dstentry = %100000 then                                     <<dougw>>10830000
   begin                                                       <<dougw>>10835000
      if live'sys then                                         <<dougw>>10840000
         penable;         << re-enable       >>                <<dougw>>10845000
      cc := ccl;                                               <<dougw>>10850000
      printerror (77); << dlfds transfer error >>              <<dougw>>10855000
      printerror (72); << dst not in use  >>                   <<dougw>>10860000
      print'parms;                                             <<dougw>>10865000
      return;                                                  <<dougw>>10870000
   end;                                                        <<dougw>>10875000
                                                               <<dougw>>10880000
dstlen := dst'size * 4;                                        <<dougw>>10885000
if (offset + 2) > dstlen then                                  <<dougw>>10890000
   begin                                                       <<dougw>>10895000
      if live'sys then                                         <<dougw>>10900000
         penable;         << re-enable       >>                <<dougw>>10905000
      cc := ccl;                                               <<dougw>>10910000
      printerror (77);                                         <<dougw>>10915000
      printerror (73); << offset+count not in dst >>           <<dougw>>10920000
      print'parms;                                             <<dougw>>10925000
      return;                                                  <<dougw>>10930000
   end;                                                        <<dougw>>10935000
                                                               <<dougw>>10940000
if live'sys then                                               <<dougw>>10945000
   begin << use lfds instruction >>                            <<dougw>>10950000
      << dst is still allocated do lfds instruction >>         <<dougw>>10955000
      tos := @dlfds'val; << @target in d >>                    <<dougw>>10960000
      tos := dstnumber; << dst     in c >>                     <<dougw>>10965000
      tos := offset;    << offset  in b >>                     <<dougw>>10970000
      tos := 2;         << count   in a >>                     <<dougw>>10975000
                                                               <<dougw>>10980000
      penable; << re-enable >>                                 <<dougw>>10985000
      assemble (mfds 4);<< sdec 4 words >>                     <<dougw>>10990000
      return;                                                  <<dougw>>10995000
   end << live mode >>                                         <<dougw>>11000000
else                                                           <<dougw>>11005000
   begin << looking at a dump >>                               <<dougw>>11010000
      if present'dst then                                      <<dougw>>11015000
         begin                                                 <<dougw>>11020000
            tos := dst'bank;                                   <<dougw>>11025000
            tos := dst'addr;                                   <<dougw>>11030000
            dstaddr := tos;                                    <<dougw>>11035000
            dlfds := dcore (dstaddr + double (offset));        <<dougw>>11040000
         end                                                   <<dougw>>11045000
      else                                                     <<dougw>>11050000
         begin << dst absent see if sdf dumped it >>           <<dougw>>11055000
            cc := ccg;   <<segment is unavailable            >><<dougw>>11060000
         end                                                   <<dougw>>11065000
   end; << looking at a dump >>                                <<dougw>>11070000
                                                               <<dougw>>11075000
end;  <<dlfds>>                                                <<dougw>>11080000
$page "                    PROCEDURE GETNUMBER"                <<dougw>>11085000
<<***********************************************************>>         11090000
<< getnumber                                                 >>         11095000
<<----------------------------------------------------------->>         11100000
<< convert ascii string to binary                            >>         11105000
<<***********************************************************>>         11110000
logical procedure getnumber(string,length);                             11115000
  value length;                                                         11120000
  integer          length;  <<# chars in ascii string>>                 11125000
  byte array       string;  <<ascii string to convert>>                 11130000
begin                                                                   11135000
                                                                        11140000
define cc=status.(6:2)#;                                                11145000
                                                                        11150000
logical  status = q-1;  <<status register in marker>>                   11155000
                                                                        11160000
byte array buffer(0:9); <<used to build string to convert>>             11165000
                                                                        11170000
cc:=cce;   <<assume no errors>>                                         11175000
getnumber:=0;                                                           11180000
                                                                        11185000
if length <= 0 then return;   <<nothing to convert>>                    11190000
                                                                        11195000
if string = "#" then begin                                              11200000
  <<user specified decimal number>>                                     11205000
  length:=length-1;                                                     11210000
  move buffer:=string(1),(length); end                                  11215000
else begin                                                              11220000
  <<assume number is in octal>>                                         11225000
  buffer:="%";                                                          11230000
  move buffer(1):=string,(length);                                      11235000
  length:=length+1; end;                                                11240000
                                                                        11245000
<<convert to binary using the binary intrinsic>>                        11250000
getnumber:=binary(buffer,length);                                       11255000
push(status);    <<need condition code returned>>                       11260000
tos:=tos.(6:2);                                                         11265000
cc:=tos;                                                                11270000
                                                                        11275000
end;  <<getnumber>>                                                     11280000
$page "                    PROCEDURE EXPREVAL"                          11285000
<<***********************************************************>>         11290000
<< expreval                                                  >>         11295000
<<----------------------------------------------------------->>         11300000
<< evaluate an expression and return value                   >>         11305000
<<***********************************************************>>         11310000
logical procedure expreval(string);                                     11315000
  byte array string;  <<expression to be evaluated>>                    11320000
                      << <cr> at end of expression>>                    11325000
begin                                                                   11330000
                                                                        11335000
  << condition code is returned as follows:      >>                     11340000
  <<                                             >>                     11345000
  <<   ccg - syntax error unable to parse        >>                     11350000
  <<   cce - successful                         >>                      11355000
  <<   ccl - not returned                        >>                     11360000
                                                                        11365000
  << this procedure assumes the existence of the >>                     11370000
  << procedure "GETNUMBER"                       >>                     11375000
                                                                        11380000
equate  maxparm = 24,                                                   11385000
            add =  0,                                                   11390000
            sub =  1,                                                   11395000
            mpy =  2,                                                   11400000
            div =  3,                                                   11405000
            eos =  4,                                                   11410000
           null =  5;                                                   11415000
                                                                        11420000
define       cc = status.(6:2)#,                                        11425000
          delim = infoword.(11:5)#,                                     11430000
         length = infoword.(0:8)#;                                      11435000
                                                                        11440000
logical  infoword,      <<word returned by mycommand>>                  11445000
              op1,      <<operand 1>>                                   11450000
              op2,      <<operand 2>>                                   11455000
             temp,      <<temporary>>                                   11460000
           status = q-1;<<status  register in marker>>                  11465000
integer numparms,      <<# parms in expression>>                        11470000
           numtos,      <<top of operand stack>>                        11475000
            optos,      <<top of operator stack>>                       11480000
             parm;      <<loop variable>>                               11485000
                                                                        11490000
logical array   number(0:maxparm),  <<operand stack>>                   11495000
               operator(0:maxparm),  <<operator stack>>                 11500000
                 oppri(0:5);        <<operator priorities>>             11505000
double array     parms(0:maxparm);  <<returned by mycommand>>           11510000
byte array   delimiters(0:4);                                           11515000
                                                                        11520000
byte pointer  operand;    <<operand to convert to binary>>              11525000
                                                                        11530000
cc:=cce;  <<assume no errors>>                                          11535000
expreval:=0;  <<in case of an error>>                                   11540000
                                                                        11545000
<<initialize operator priorities>>                                      11550000
oppri(add):=2;                                                          11555000
oppri(sub):=2;                                                          11560000
oppri(mpy):=3;                                                          11565000
oppri(div):=3;                                                          11570000
oppri(eos):=1;                                                          11575000
oppri(null):=0;                                                         11580000
                                                                        11585000
<<set up to parse the expression>>                                      11590000
delimiters(add):="+";                                                   11595000
delimiters(sub):="-";                                                   11600000
delimiters(mpy):="*";                                                   11605000
delimiters(div):="/";                                                   11610000
delimiters(eos):=cr;                                                    11615000
                                                                        11620000
mycommand(string,delimiters,maxparm,numparms,parms);                    11625000
if <> then begin                                                        11630000
  cc:=ccg;                                                              11635000
  return; end;                                                          11640000
                                                                        11645000
<<use first parm to initialize the operator and operand stacks>>        11650000
tos:=parms(0);                                                          11655000
infoword:=tos;                                                          11660000
@operand:=tos;                                                          11665000
                                                                        11670000
if numparms = 0 then                                                    11675000
  return;  <<string is null - return zero>>                             11680000
                                                                        11685000
operator(0):=null;                                                      11690000
optos:=1;                                                               11695000
numtos:=parm:=0;                                                        11700000
operator(optos):=delim;                                                 11705000
temp:=getnumber(operand,length);                                        11710000
if = then                                                               11715000
  number(numtos):=temp                                                  11720000
else begin                                                              11725000
  cc:=ccg;                                                              11730000
  return; end;                                                          11735000
                                                                        11740000
while operator(optos) <> eos do begin                                   11745000
  tos:=parms(parm:=parm+1);                                             11750000
  infoword:=tos;                                                        11755000
  @operand:=tos;                                                        11760000
                                                                        11765000
  temp:=getnumber(operand,length);                                      11770000
  if = then                                                             11775000
    number(numtos:=numtos+1):=temp                                      11780000
  else begin                                                            11785000
    cc:=ccg;                                                            11790000
    return; end;                                                        11795000
                                                                        11800000
  while oppri(delim) <= oppri(operator(optos)) do begin                 11805000
    op1:=number(numtos-1);                                              11810000
    op2:=number(numtos);                                                11815000
    case operator(optos) of begin                                       11820000
      <<+>> temp:=op1+op2;                                              11825000
      <<->> temp:=op1-op2;                                              11830000
      <<*>> temp:=op1*op2;                                              11835000
      <</>> temp:=op1/op2;                                              11840000
    end;  <<case>>                                                      11845000
                                                                        11850000
    number(numtos:=numtos-1):=temp;                                     11855000
    optos:=optos-1; end;                                                11860000
                                                                        11865000
  operator(optos:=optos+1):=delim; end;                                 11870000
                                                                        11875000
expreval:=number(numtos);                                               11880000
                                                                        11885000
end;  <<expreval>>                                                      11890000
$page "                    PROCEDURE VALIDPIN"                          11895000
<<***********************************************************>>         11900000
<<  validpin                                                 >>         11905000
<<----------------------------------------------------------->>         11910000
<< determine if specified pin exists                         >>         11915000
<<***********************************************************>>         11920000
logical procedure validpin(pin);                                        11925000
  value pin;                                                            11930000
  integer pin;     <<pin to validate>>                                  11935000
begin                                                                   11940000
                                                                        11945000
  << this procedure assumes the existence of the >>                     11950000
  << global variable pcb'good and the proc. core >>                     11955000
                                                                        11960000
double pcbaddr;                                                  <<nsf>>11965000
integer maxpin;                                                  <<nsf>>11970000
validpin:=false;                                                        11975000
                                                                        11980000
if not pcb'good then return;                                            11985000
                                                                        11990000
pcbaddr:=getdstaddr(3);                                          <<nsf>>11995000
maxpin:=integer(core(pcbaddr));                                  <<nsf>>12000000
                                                                 <<nsf>>12005000
if 1 <= pin <= maxpin then validpin:=true;                       <<nsf>>12010000
                                                                        12015000
end;  <<validpin>>                                                      12020000
$page "                    PROCEDURE ASSIGNED'PIN"                      12025000
<<***********************************************************>>         12030000
<<  assigned'pin                                             >>         12035000
<<----------------------------------------------------------->>         12040000
<< determine if specified pin is assigned                    >>         12045000
<<***********************************************************>>         12050000
logical procedure assigned'pin(pin);                                    12055000
  value pin;                                                            12060000
  integer pin;     <<pin to test>>                                      12065000
begin                                                                   12070000
                                                                        12075000
  << this procedure assumes the existence of the >>                     12080000
  << global variable pcb'good and the proc. core >>                     12085000
                                                                        12090000
double pcbaddr,entry'addr;                                              12095000
assigned'pin:=false;                                                    12100000
                                                                        12105000
if not pcb'good then return;                                            12110000
                                                                        12115000
pcbaddr:=getdstaddr(3);                                                 12120000
if mpeversion = 4  then                                                 12125000
  begin                                                                 12130000
  entry'addr := pcbaddr + double(pin * %20);                            12135000
  if core(entry'addr+%17d) <> %177777  then                             12140000
    assigned'pin := true;                                               12145000
  end                                                                   12150000
else                                                                    12155000
  begin                                                                 12160000
  entry'addr := pcbaddr + double(pin * %25);                            12165000
  if core(entry'addr+%24d) <> %177777  then                             12170000
    assigned'pin := true;                                               12175000
  end;                                                                  12180000
                                                                        12185000
end;  <<assigned'pin>>                                                  12190000
$page "                    PROCEDURE VALIDDST"                <<851230>>12195000
<<***********************************************************><<851230>>12200000
<<  validdst                                                 ><<851230>>12205000
<<-----------------------------------------------------------><<851230>>12210000
<< determine if specified dst exists                         ><<851230>>12215000
<<***********************************************************><<851230>>12220000
logical procedure validdst(dst);                              <<851230>>12225000
  value dst;                                                  <<851230>>12230000
  integer dst;     <<dst to validate>>                        <<851230>>12235000
begin                                                         <<851230>>12240000
                                                              <<851230>>12245000
  << this procedure assumes the existence of the >>           <<851230>>12250000
  << procedure core                              >>           <<851230>>12255000
                                                              <<851230>>12260000
double dstaddr;                                               <<851230>>12265000
integer maxdst;                                               <<851230>>12270000
validdst:=false;                                              <<851230>>12275000
                                                              <<851230>>12280000
dstaddr:=getdstaddr(2);                                       <<851230>>12285000
maxdst:=integer(core(dstaddr));                               <<851230>>12290000
                                                              <<851230>>12295000
if 1 <= dst <= maxdst then validdst:=true;                    <<851230>>12300000
                                                              <<851230>>12305000
end;  <<validdst>>                                            <<851230>>12310000
$page "                    PROCEDURE GETSTACKDST"                       12315000
<<***********************************************************>>         12320000
<<  getstackdst                                              >>         12325000
<<----------------------------------------------------------->>         12330000
<< return dst index of stack for the specified pin           >>         12335000
<<***********************************************************>>         12340000
integer procedure getstackdst(pin);                                     12345000
  value pin;                                                            12350000
  integer pin;    <<pin of process of interest>>                        12355000
begin                                                                   12360000
                                                                        12365000
  << condition code is returned as follows:    >>                       12370000
  <<                                           >>                       12375000
  <<  ccg - invalid pin #                      >>                       12380000
  <<  cce - successful                         >>                       12385000
  <<  ccl - unable to access the pcb table     >>                       12390000
                                                                        12395000
  << this procedure assumes the existence of the >>                     12400000
  <<following global variables:                  >>                     12405000
  <<       pcb'good         printerror (proc)    >>                     12410000
  <<       core (proc)      validpin (proc)      >>                     12415000
                                                                        12420000
define  cc = status.(6:2)#;                                             12425000
                                                                        12430000
logical  pcbword,        <<word from pcb table>>                        12435000
          status = q-1;  <<status word in marker>>                      12440000
                                                                        12445000
double pcbaddr;                                                  <<nsf>>12450000
logical pcbentsize;                                              <<nsf>>12455000
                                                                        12460000
cc:=cce;   <<assume no errors>>                                         12465000
                                                                        12470000
pcbaddr:=getdstaddr(3);                                          <<nsf>>12475000
pcbentsize:=(%20+(mpeversion-4)*5);                              <<nsf>>12480000
                                                                        12485000
if not pcb'good then begin                                              12490000
  printerror(14);                                                       12495000
  cc:=ccl;                                                              12500000
  return; end;                                                          12505000
                                                                        12510000
if not validpin(pin) then begin                                         12515000
  printerror(15);                                                       12520000
  cc:=ccg; end                                                          12525000
else begin                                                              12530000
  pcbaddr:=pcbaddr+double(logical(pin)*pcbentsize+3);            <<nsf>>12535000
  pcbword:=core(pcbaddr);                                        <<nsf>>12540000
  if mpeversion=4 then                                           <<nsf>>12545000
    getstackdst:=pcbword.(1:10)                                  <<nsf>>12550000
  else                                                           <<nsf>>12555000
    getstackdst:=pcbword.(2:14); end;                            <<nsf>>12560000
                                                                        12565000
end;  <<getstackdst>>                                                   12570000
$page "                            PROCEDURE BUILDDATE"                 12575000
$control segment=idat5                                                  12580000
<<**********************************************************>>          12585000
<<  builddate                                               >>          12590000
<<---------------------------------------------------------->>          12595000
<< do some work for getdate, which is the sole caller       >>          12600000
<<**********************************************************>>          12605000
                                                                        12610000
procedure builddate;                                                    12615000
  begin                                                                 12620000
    integer array dayspermonth(0:11)=pb:=                               12625000
    0,31,60,91,121,152,182,213,244,274,305,335;                         12630000
    integer date=q+1,time=q+2,year=q+3,day=q+4,x=x,hour=day;            12635000
    equate noon=12*256;                                                 12640000
                                                                        12645000
  subroutine convert(n,position);                                       12650000
    value n,position;                                                   12655000
    integer n,position;                                                 12660000
    begin                                                               12665000
      x:=position;                                                      12670000
      tos:=n;                                                           12675000
      assemble(ldi 10;div,xch);                                         12680000
      buf(x):=tos+"0";                                                  12685000
      buf(x:=x+1):=tos+"0";                                             12690000
    end;  <<convert>>                                                   12695000
                                                                        12700000
    tos:=calendar;                                                      12705000
    tos:=clock;                                                         12710000
    tos:=date.(0:7);                                                    12715000
    tos:=date.(7:9);                                                    12720000
    x:=((year-1)&asr(2)+year+day) mod 7*3;  <<day of week>>             12725000
    move buf:="  /  /  ,   :  AM";                                      12730000
    if year.(14:2) <> 0 and day >= 60 then day:=day+1;                  12735000
    if 1<=day<=366 then else return;                                    12740000
      <<prevent out of bounds dayspermonth index>>                      12745000
    x:=12;                                                              12750000
    do x:=x-1 until dayspermonth(x)<day;                                12755000
    day:=day-dayspermonth(x);                                           12760000
    convert(x:=x+1,0);                                                  12765000
    if buf="0" then buf:=" ";                                           12770000
    convert(day,3);                                                     12775000
    convert(year,6);                                                    12780000
    tos:=(time.(0:8)+11) mod 12 + 1;                                    12785000
    convert(*,10);                                                      12790000
    if buf(10)="0" then buf(10):=" ";                                   12795000
    convert(time.(8:8),13);                                             12800000
    if time = noon then buf(15):=" ";                                   12805000
    if time > noon then buf(15):="P";                                   12810000
  end;  <<builddate>>                                                   12815000
$page "                      PROCEDURE GETDATE"                         12820000
<<************************************************************>>        12825000
<<  getdate                                                   >>        12830000
<<------------------------------------------------------------>>        12835000
<< recover the date and time that the dump was taken          >>        12840000
<<************************************************************>>        12845000
                                                                        12850000
procedure getdate;                                                      12855000
                                                                        12860000
  begin                                                                 12865000
    integer d,d',y,m,h;                                                 12870000
    double loctrl,t'convert;                                            12875000
    define time'mod'tos=assemble(ddiv;delb)#,                           12880000
              duplicate=assemble(dup)#,                                 12885000
           sysglobx'ver=double(core(%377d)+%76)#,                       12890000
           sysglobx'upd=double(core(%377d)+%74)#,                       12895000
           sysglobx'fix=double(core(%377d)+%75)#;                       12900000
    real tick'to'ms:=9.14566375e-2;                                     12905000
                                                                        12910000
    tos:=0;                                                             12915000
    tos:=core(%1012d)+%1000;        << addr of trl >>                   12920000
    loctrl:=tos;                                                        12925000
    tos:=core(loctrl+7d);           <<year:julian day>>                 12930000
    duplicate;                                                          12935000
    d:=tos.(7:9);                   <<julian day>>                      12940000
    y:=tos.(0:7);                   <<year>>                            12945000
    tos:=core(loctrl+5d);                                               12950000
    tos:=core(loctrl+6d);                                               12955000
    if machineid = model25 then begin                                   12960000
                                                                        12965000
      << backwards compatibility check:  change to 33      >>           12970000
      << introduced in b.01.01.  before then, the three    >>           12975000
      << cells checked here were not used and initially    >>           12980000
      << were set to zero.  these cells are the sysglob    >>           12985000
      << extension version, update and fix levels (mit     >>           12990000
      << numbers, not modifyable)                          >>           12995000
      if core(sysglobx'ver) = 0 and                                     13000000
         core(sysglobx'upd) = 0 and                                     13005000
         core(sysglobx'fix) = 0 then begin                              13010000
        << series 33's store number of ticks, not ms. >>                13015000
        t'convert:=tos;                                                 13020000
        t'convert:=fixr( real(t'convert)*tick'to'ms );                  13025000
        tos:=t'convert;                                                 13030000
      end;                                                              13035000
    end;                                                                13040000
    tos:=60000d;                                                        13045000
    assemble(ddiv; ddel);  << minutes >>                                13050000
    tos:=60d;                                                           13055000
    time'mod'tos;          << hours >>                                  13060000
    m:=tos;                << remainder=minutes >>                      13065000
    tos:=24d;                                                           13070000
    time'mod'tos;          << days >>                                   13075000
    h:=tos;                << remainder=hours >>                        13080000
    assemble(delb);                                                     13085000
    d:=d+tos;              << update julian day >>                      13090000
    tos:=y;                                                             13095000
    tos:=4;                                                             13100000
    assemble(div);         << test for leap year >>                     13105000
    if tos=0 then d':=366                                               13110000
    else d':=365;                                                       13115000
    assemble(del);                                                      13120000
    tos:=d;                                                             13125000
    tos:=d';                                                            13130000
    assemble(div);         << get extra years >>                        13135000
    d:=tos;                << remainder=days >>                         13140000
    if machineid=model25 then                                           13145000
      d:=d+integer(core(loctrl+3d));                                    13150000
    y:=y+tos;                                                           13155000
    if y>99 then y:=y-100;                                              13160000
    tos.(0:7):=y;                                                       13165000
    tos.(7:9):=d;                                                       13170000
    calendar:=tos;                                                      13175000
    tos.(0:8):=h;                                                       13180000
    tos.(8:8):=m;                                                       13185000
    clock:=tos;                                                         13190000
    builddate;                                                          13195000
  end;  <<getdate>>                                                     13200000
$page "                     PROCEDURE PARSEOFFSET"                      13205000
$control segment=idat4                                                  13210000
<<***********************************************************>>         13215000
<<  parseoffset                                              >>         13220000
<<----------------------------------------------------------->>         13225000
<< parse <offset> of display or print command                >>         13230000
<<***********************************************************>>         13235000
double procedure parseoffset(parmwords);                                13240000
  value parmwords;                                                      13245000
  double parmwords;  <<double-word returned by "MYCOMMAND">>            13250000
begin                                                                   13255000
                                                                        13260000
  << condition code is returned as follows:      >>                     13265000
  <<                                             >>                     13270000
  <<   ccg - syntax error                        >>                     13275000
  <<   cce - successful                          >>                     13280000
  <<   ccl - undefined "DISPLACEMENT" specified  >>                     13285000
                                                                        13290000
  << this procedure assumes the existence of the >>                     13295000
  << following procedures: getnumber, getdstaddr,>>                     13300000
  << getcstaddr, expreval, and core              >>                     13305000
                                                                        13310000
equate  maxindirect =  5,                                               13315000
           maxparms = 50;                                               13320000
                                                                        13325000
                                                                        13330000
define  alphachar = (8:1)#,                                             13335000
               cc = status.(6:2)#,                                      13340000
           length = (0:8)#;                                             13345000
                                                                        13350000
logical  flagword,       <<word returned by mycommand>>                 13355000
         infoword,       <<word returned by mycommand>>                 13360000
           status = q-1, <<status register in marker>>                  13365000
          tempptr;       <<temporary>>                                  13370000
integer      bank,       <<bank # of base address>>                     13375000
           cstnum,       <<cst to display>>                             13380000
           dstnum,       <<dst to display>>                             13385000
               in,       <<loop variable>>                              13390000
           offset,       <<words to offset>>                            13395000
      numindirect,       <<# parms with : delimiter>>                   13400000
         numparms;       <<# parms in register base>>                   13405000
double   addrbase,       <<starting address to display>>                13410000
     indirectbase;       <<addr used for indirection>>                  13415000
                                                                        13420000
double array indirectparms(0:maxindirect),                              13425000
                     parms(0:maxparms);                                 13430000
byte array      delimiters(0:3);                                        13435000
                                                                        13440000
byte pointer  string;  <<string to parse>>                              13445000
                                                                        13450000
cc:=cce;   <<assume no errors>>                                         13455000
dda := false;                                                           13460000
tos:=parmwords;    <<decode double word from mycommand>>                13465000
flagword:=tos;                                                          13470000
@string:=tos;      <<guaranteed no leading blanks>>                     13475000
                                                                        13480000
string(flagword.length):=cr;  <<required by mycommand>>                 13485000
                              <<may overlay a ",">>                     13490000
                                                                        13495000
<<parse string to separate levels of indirection>>                      13500000
<<each will consist of separate expression to evaluate>>                13505000
delimiters(0):=":";                                                     13510000
delimiters(1):=cr;                                                      13515000
mycommand(string,delimiters,maxindirect,numindirect,                    13520000
          indirectparms);                                               13525000
if <> then begin                                                        13530000
  cc:=ccg;                                                              13535000
  return; end;                                                          13540000
                                                                        13545000
<<we know there must be at least one parm; otherwise this >>            13550000
<<procedure would not have been called.  it must be       >>            13555000
<<the name of register to use as a base (which includes   >>            13560000
<<dst #s, absolute address mode, and extended address     >>            13565000
<<mode), and possibly an expression.  if no register      >>            13570000
<<is specified, then db is assumed.                       >>            13575000
                                                                        13580000
<<once again we are guaranteed at least one character >>                13585000
<<determine what register base was specified       >>                   13590000
tos:=indirectparms(0);   <<decode double word from mycommand>>          13595000
infoword:=tos;                                                          13600000
tempptr:=tos;                                                           13605000
                                                                        13610000
<<must place a <cr> at end of 1st parm (base address)>>                 13615000
<<since subsequent call to "EXPREVAL" will expect it >>                 13620000
string(infoword.length):=cr;  <<may replace a ":">>                     13625000
                                                                        13630000
if not infoword.alphachar then begin                                    13635000
  tos:=dbbankreg;                                                       13640000
  tos:=dbreg;                                                           13645000
  addrbase:=tos; end <<none specified - assume db>>                     13650000
else begin                                                              13655000
  if string = "Q" then begin   <<q relative >>                          13660000
    infoword.length:=1;                                                 13665000
    tos:=zbankreg;                                                      13670000
    tos:=qreg;                                                          13675000
    addrbase:=tos;                                                      13680000
    tos:=dbbankreg;                                                     13685000
    tos:=dbreg;                                                         13690000
    indirectbase:=tos; end                                              13695000
  else                                                                  13700000
  if string = "SY" then begin   << sysbase relative>>                   13705000
    <<set length so entire expression evaluated  >>                     13710000
    infoword.length:=2;                                                 13715000
    addrbase:=sysdb;                                                    13720000
    indirectbase:=sysdb; end                                            13725000
  else                                                                  13730000
  if string = "S" then begin    << s relative >>                        13735000
    infoword.length:=1;                                                 13740000
    tos:=zbankreg;                                                      13745000
    tos:=sreg;                                                          13750000
    addrbase:=tos;                                                      13755000
    tos:=dbbankreg;                                                     13760000
    tos:=dbreg;                                                         13765000
    indirectbase:=tos; end                                              13770000
  else                                                                  13775000
  if string = "PB" then begin    << pb relative >>               <<nsf>>13780000
    infoword.length:=2;                                          <<nsf>>13785000
    tos:=pbbankreg;                                              <<nsf>>13790000
    tos:=pbreg;                                                  <<nsf>>13795000
    addrbase:=tos;                                               <<nsf>>13800000
    tos:=pbbankreg;                                              <<nsf>>13805000
    tos:=pbreg;                                                  <<nsf>>13810000
    indirectbase:=tos; end                                       <<nsf>>13815000
  else                                                           <<nsf>>13820000
  if string = "PL" then begin    << pl relative >>               <<nsf>>13825000
    infoword.length:=2;                                          <<nsf>>13830000
    tos:=pbbankreg;                                              <<nsf>>13835000
    tos:=plreg;                                                  <<nsf>>13840000
    addrbase:=tos;                                               <<nsf>>13845000
    tos:=pbbankreg;                                              <<nsf>>13850000
    tos:=plreg;                                                  <<nsf>>13855000
    indirectbase:=tos; end                                       <<nsf>>13860000
  else                                                           <<nsf>>13865000
  if string = "P" then begin    << p relative >>                 <<nsf>>13870000
    infoword.length:=1;                                          <<nsf>>13875000
    tos:=pbbankreg;                                              <<nsf>>13880000
    tos:=preg;                                                   <<nsf>>13885000
    addrbase:=tos;                                               <<nsf>>13890000
    tos:=pbbankreg;                                              <<nsf>>13895000
    tos:=preg;                                                   <<nsf>>13900000
    indirectbase:=tos; end                                       <<nsf>>13905000
  else                                                           <<nsf>>13910000
  if string = "A" then begin    << absolute >>                          13915000
    addrbase:=0d;                                                       13920000
    <<specified address computed computed below  >>                     13925000
    <<set length so entire expression evaluated  >>                     13930000
    infoword.length:=1;                                                 13935000
    indirectbase:=0d; end                                               13940000
  else                                                                  13945000
  if string = "DB" then begin   << db relative >>                       13950000
    infoword.length:=2;                                                 13955000
    tos:=dbbankreg;                                                     13960000
    tos:=dbreg;                                                         13965000
    addrbase:=tos;                                                      13970000
    tos:=dbbankreg;                                                     13975000
    tos:=dbreg;                                                         13980000
    indirectbase:=tos; end                                              13985000
  else begin                                                            13990000
    <<for the remaining possibilities, the base value is >>             13995000
    <<delimited by either a "+" or "-".  must call       >>             14000000
    <<mycommand to parse 1st parameter again>>                          14005000
    delimiters(0):="+";                                                 14010000
    delimiters(1):="-";                                                 14015000
    delimiters(2):=cr;                                                  14020000
    mycommand(string,delimiters,maxparms,numparms,parms);               14025000
    if <> then begin                                                    14030000
      cc:=ccg;                                                          14035000
      return; end;                                                      14040000
                                                                        14045000
    tos:=parms(0);                                                      14050000
    flagword:=tos;                                                      14055000
    del;      <<don't need the byte pointer>>                           14060000
                                                                        14065000
    if string = "EA" then begin  << extended addressing >>              14070000
      bank:=getnumber(string(2),flagword.length-2);                     14075000
      if <> then begin                                                  14080000
        cc:=ccl;   <<invalid bank number>>                              14085000
        return; end;                                                    14090000
      tos:=bank;                                                        14095000
      tos:=0;                                                           14100000
      addrbase:=tos;                                                    14105000
      infoword.length:=flagword.length;                                 14110000
      indirectbase:=sysdb; end                                          14115000
    else                                                                14120000
    if string = "DA" then begin   << data >>                            14125000
      dda := true;                                                      14130000
      dstnum:=getnumber(string(2),flagword.length-2);                   14135000
      if <> then begin                                                  14140000
        cc:=ccl;   <<invalid dst number>>                               14145000
        return; end;                                                    14150000
                                                                        14155000
      <<get address of the dst number>>                                 14160000
      addrbase:=getdstaddr(dstnum);                                     14165000
      if <> then begin                                                  14170000
        cc:=ccl;                                                        14175000
        return; end;                                                    14180000
      dseg'base := addrbase;                                            14185000
      infoword.length:=flagword.length;                                 14190000
      indirectbase:=addrbase; end                                       14195000
    else                                                                14200000
    if string = "CO" then begin    <<code >>                            14205000
      cstnum:=getnumber(string(2),flagword.length-2);                   14210000
      if <> then begin                                                  14215000
        cc:=ccl;                                                        14220000
        return; end;                                                    14225000
                                                                        14230000
      <<get address of cst>>                                            14235000
      addrbase:=getcstaddr(cstnum);                                     14240000
      if <> then begin                                                  14245000
        cc:=ccl;                                                        14250000
        return; end;                                                    14255000
      infoword.length:=flagword.length;                                 14260000
      indirectbase:=addrbase; end                                       14265000
    else begin                                                          14270000
      cc:=ccl;   <<invalid specification>>                              14275000
      return; end; end;                                                 14280000
                                                                        14285000
  @string:=tempptr+infoword.length; end;                                14290000
                                                                        14295000
<<if we reach this point, we have determined the base addr>>            14300000
<<we now want to parse the expression to get the offset   >>            14305000
offset:=expreval(string);  <<already have <cr> at end>>                 14310000
if <> then begin                                                        14315000
  cc:=ccg;                                                              14320000
  return; end;                                                          14325000
                                                                        14330000
tos := addrbase;                                                        14335000
tos := tos+logical(offset);                                             14340000
addrbase := tos;                                                        14345000
                                                                        14350000
<<now loop until all levels of indirection are exhausted>>              14355000
for in:=1 until numindirect-1 do begin                                  14360000
  <<redefine address base due to indirection>>                          14365000
  addrbase:=indirectbase+double(core(addrbase));                        14370000
  tos:=indirectparms(in);  <<decode double word from mycommand>>        14375000
  infoword:=tos;                                                        14380000
  @string:=tos;   <<set pointer to start of expression>>                14385000
                                                                        14390000
  if infoword.length > 0 then begin                                     14395000
    string(infoword.length):=cr;  <<may replace a ":">>                 14400000
    offset:=expreval(string);                                           14405000
    if <> then begin                                                    14410000
      cc:=ccg;  <<unable to parse expression>>                          14415000
      return; end; end                                                  14420000
  else                                                                  14425000
    offset:=0;                                                          14430000
                                                                        14435000
  tos := addrbase;                                                      14440000
  tos := tos+logical(offset);                                           14445000
  addrbase := tos;                                                      14450000
  end;                                                                  14455000
                                                                        14460000
parseoffset:=addrbase;                                                  14465000
                                                                        14470000
end;  <<parseoffset>>                                                   14475000
$page "                     PROCEDURE PARSECOUNT"                       14480000
<<***********************************************************>>         14485000
<<  parsecount                                               >>         14490000
<<----------------------------------------------------------->>         14495000
<< parse <count> of display or print command                 >>         14500000
<<***********************************************************>>         14505000
double procedure parsecount(parmwords);                                 14510000
  value parmwords;                                                      14515000
  double parmwords;  <<double-word returned by "MYCOMMAND">>            14520000
begin                                                                   14525000
                                                                        14530000
  << condition code is returned as follows:      >>                     14535000
  <<                                             >>                     14540000
  <<   ccg - syntax error                        >>                     14545000
  <<   cce - successful                          >>                     14550000
  <<   ccl - negative count                      >>                     14555000
                                                                        14560000
  << this procedure assumes the existence of the >>                     14565000
  << global variable cr and the proc. expreval   >>                     14570000
                                                                        14575000
define  cc = status.(6:2)#;                                             14580000
define  length = infoword.(0:8)#;                                       14585000
                                                                        14590000
byte pointer  string;  <<string to parse>>                              14595000
                                                                        14600000
logical infoword,       <<word from mycommand>>                         14605000
          status = q-1, <<status register in marker>>                   14610000
            temp;       <<temporary>>                                   14615000
                                                                        14620000
cc:=cce;   <<assume no errors>>                                         14625000
                                                                        14630000
tos:=parmwords;                                                         14635000
infoword:=tos;                                                          14640000
@string:=tos;                                                           14645000
                                                                        14650000
string(length):=cr;                                                     14655000
                                                                        14660000
temp:=expreval(string);                                                 14665000
if = then                                                               14670000
  if integer(temp) < 0 then                                             14675000
    cc:=ccl                                                             14680000
  else begin                                                            14685000
    tos:=0;                                                             14690000
    tos:=temp;                                                          14695000
    parsecount:=tos; end                                                14700000
else                                                                    14705000
  cc:=ccg;                                                              14710000
                                                                        14715000
end;  <<parsecount>>                                                    14720000
$page "                     PROCEDURE PARSEMODE"                        14725000
<<***********************************************************>>         14730000
<<  parsemode                                                >>         14735000
<<----------------------------------------------------------->>         14740000
<< parse <mode> of display or print command                  >>         14745000
<<***********************************************************>>         14750000
integer procedure parsemode(parmwords);                                 14755000
  value parmwords;                                                      14760000
  double parmwords;  <<double-word returned by "MYCOMMAND">>            14765000
begin                                                                   14770000
                                                                        14775000
  << condition code is returned as follows:      >>                     14780000
  <<                                             >>                     14785000
  <<   ccg - syntax error                        >>                     14790000
  <<   cce - successful                          >>                     14795000
  <<   ccl - undefined "MODE" specified          >>                     14800000
                                                                        14805000
  << this procedure assumes the existence of the >>                     14810000
  << following global variables:                 >>                     14815000
  <<      octal'mode        integer'mode         >>                     14820000
  <<      ascii'mode        code'mode            >>                     14825000
  <<      octal'ascii                            >>              <<nsf>>14830000
                                                                        14835000
define  alphachar = flagword.(8:1)#,                                    14840000
               cc = status.(6:2)#,                                      14845000
           length = flagword.(0:8)#;                                    14850000
                                                                        14855000
logical  flagword,       <<2nd word returned by mycommand>>             14860000
           status = q-1; <<status register in marker>>                  14865000
integer  tempmode;       <<temporary>>                                  14870000
                                                                        14875000
byte pointer string;     <<the <mode> portion of command>>              14880000
                                                                        14885000
cc:=cce;   <<assume no errors>>                                         14890000
                                                                        14895000
<<retrieve values from double word returned by "MYCOMMAND">>            14900000
tos:=parmwords;                                                         14905000
flagword:=tos;                                                          14910000
@string:=tos;                                                           14915000
                                                                        14920000
if length <> 1 or not(alphachar) then begin                             14925000
  <<mode should be a single alphabetic character>>                      14930000
  cc:=ccg;                                                              14935000
  return; end;                                                          14940000
                                                                        14945000
<<determine which mode specified>>                                      14950000
tempmode:=if string = "O" then octal'mode                               14955000
          else                                                          14960000
          if string = "I" then integer'mode                             14965000
          else                                                          14970000
          if string = "A" then ascii'mode                               14975000
          else                                                          14980000
          if string = "C" then code'mode                                14985000
          else                                                   <<nsf>>14990000
          if string = "B" then octal'ascii                       <<nsf>>14995000
                          else -1;                                      15000000
                                                                        15005000
if tempmode = -1 then                                                   15010000
  cc:=ccl   <<invalid mode>>                                            15015000
else                                                                    15020000
  parsemode:=tempmode;                                                  15025000
                                                                        15030000
end;  <<parsemode>>                                                     15035000
$page "                     PROCEDURE PARSEMATCH"                       15040000
<<***********************************************************>>  <<nsf>>15045000
<<  parsematch                                               >>  <<nsf>>15050000
<<----------------------------------------------------------->>  <<nsf>>15055000
<< parse <match'suppress> of display or print command        >>  <<nsf>>15060000
<<***********************************************************>>  <<nsf>>15065000
integer procedure parsematch(parmwords);                         <<nsf>>15070000
  value parmwords;                                               <<nsf>>15075000
  double parmwords;  <<double-word returned by 'mycommand'>>     <<nsf>>15080000
begin                                                            <<nsf>>15085000
                                                                 <<nsf>>15090000
  << condition code is returned as follows:      >>              <<nsf>>15095000
  <<                                             >>              <<nsf>>15100000
  <<   ccg - syntax error                        >>              <<nsf>>15105000
  <<   cce - successful                          >>              <<nsf>>15110000
  <<   ccl - undefined "MATCH'SUPPRESS" specified>>              <<nsf>>15115000
                                                                 <<nsf>>15120000
define alphachar = flagword.(8:1)#,                              <<nsf>>15125000
              cc = status.(6:2)#,                                <<nsf>>15130000
          length = flagword.(0:8)#;                              <<nsf>>15135000
                                                                 <<nsf>>15140000
logical flagword,        << 2nd word returned by 'mycommand'>>   <<nsf>>15145000
           status = q-1, << status register in marker >>         <<nsf>>15150000
        tempmode;        << temporary >>                         <<nsf>>15155000
                                                                 <<nsf>>15160000
byte pointer string;     << the <match'suppress> part of comm.>> <<nsf>>15165000
                                                                 <<nsf>>15170000
cc:=cce;   <<assume no errors>>                                  <<nsf>>15175000
                                                                 <<nsf>>15180000
<<retrieve values from double word returned by "MYCOMMAND">>     <<nsf>>15185000
tos:=parmwords;                                                  <<nsf>>15190000
flagword:=tos;                                                   <<nsf>>15195000
@string:=tos;                                                    <<nsf>>15200000
                                                                 <<nsf>>15205000
if length <> 1 or not(alphachar) then begin                      <<nsf>>15210000
  <<match'suppress should be a single alphabetic character>>     <<nsf>>15215000
  cc:=ccg;                                                       <<nsf>>15220000
  return; end;                                                   <<nsf>>15225000
                                                                 <<nsf>>15230000
tempmode:=if string = "S" then 1                                 <<nsf>>15235000
                          else -1;                               <<nsf>>15240000
                                                                 <<nsf>>15245000
  if tempmode = -1 then                                          <<nsf>>15250000
    cc:=ccl   <<invalid match'suppress>>                         <<nsf>>15255000
  else                                                           <<nsf>>15260000
    parsematch:=tempmode;                                        <<nsf>>15265000
                                                                 <<nsf>>15270000
end;   <<parsematch>>                                            <<nsf>>15275000
$page "                     PROCEDURE PARSEDISPLAY"                     15280000
<<***********************************************************>>         15285000
<<  parsedisplay                                             >>         15290000
<<----------------------------------------------------------->>         15295000
<< parse the "DISPLAY" command                               >>         15300000
<<***********************************************************>>         15305000
procedure parsedisplay(parmstring,start,count,dispmode,match'suppress); 15310000
  integer      dispmode;  <<mode value>>                                15315000
  double          count,  <<# of words to display>>                     15320000
                  start;  <<address of 1st word to display>>            15325000
  logical match'suppress;  <<match'suppress value>>                     15330000
  byte array parmstring;  <<user input>>                                15335000
begin                                                                   15340000
                                                                        15345000
  << condition code is returned as follows:   >>                        15350000
  <<                                          >>                        15355000
  <<   ccg - unable to parse user input       >>                        15360000
  <<   cce - successful                       >>                        15365000
  <<   ccl - syntax error detected            >>                        15370000
                                                                        15375000
  << this procedure assumes the existence of the >>                     15380000
  << global variable dbregd and the following    >>                     15385000
  << procedures:                                 >>                     15390000
  <<      printerror         parseoffset         >>                     15395000
  <<      parsecount         parsemode           >>                     15400000
  <<      parsematch                             >>                     15405000
                                                                        15410000
equate  maxparms = 50;                                                  15415000
                                                                        15420000
define     cc = status.(6:2)#,                                          15425000
       length = (0:8)#;                                                 15430000
                                                                        15435000
logical   status = q-1; <<status register in marker>>                   15440000
integer numparms,       <<# parms found by "MYCOMMAND">>                15445000
            temp;       <<temporary>>                                   15450000
double     dtemp;       <<temporary>>                                   15455000
                                                                        15460000
double array parms(0:maxparms);  <<parms returned by the>>              15465000
                                 <<mycommand intrinsic  >>              15470000
                                                                        15475000
byte array delimiters(0:3);  <<delimiters for mycommand>>               15480000
                                                                        15485000
cc:=cce;   <<assume no errors>>                                         15490000
                                                                        15495000
<<parse comm. to get <offset>, <count>, <mode>, and <match'suppress> >> 15500000
delimiters(0):=",";                                                     15505000
delimiters(1):=cr;                                                      15510000
mycommand(parmstring,delimiters,maxparms,numparms,parms);               15515000
if <> then begin                                                        15520000
  printerror(0);                                                        15525000
  cc:=ccg;                                                              15530000
  return; end;                                                          15535000
                                                                        15540000
if not (0 <= numparms <= 4) then begin                                  15545000
  printerror(7);                                                        15550000
  cc:=ccl;                                                              15555000
  return; end;                                                          15560000
                                                                        15565000
<<have correct number of parms - set up defaults>>                      15570000
tos:=dbbankreg;                                                         15575000
tos:=dbreg;                                                             15580000
start:=tos;                                                             15585000
count:=1d;                                                              15590000
dispmode:=octal'mode;                                                   15595000
match'suppress:=false;                                           <<nsf>>15600000
                                                                        15605000
<<evaluate <offset>, if one was specified>>                             15610000
if numparms >= 1 then                                                   15615000
  if logical(parms(0)).length > 0 then begin                            15620000
    dtemp:=parseoffset(parms(0));                                       15625000
    if = then                                                           15630000
      start:=dtemp                                                      15635000
    else begin                                                          15640000
      if > then printerror(5)                                           15645000
           else printerror(6);                                          15650000
      cc:=ccl;                                                          15655000
      return; end; end;                                                 15660000
                                                                        15665000
<<evaluate <count>, if one was specified>>                              15670000
if numparms >= 2 then                                                   15675000
  if logical(parms(1)).length > 0 then begin                            15680000
    dtemp:=parsecount(parms(1));                                        15685000
    if = then                                                           15690000
      count:=dtemp                                                      15695000
    else begin                                                          15700000
      if > then printerror(3)                                           15705000
           else printerror(4);                                          15710000
      cc:=ccl;                                                          15715000
      return; end; end;                                                 15720000
                                                                        15725000
<<evaluate <mode>, if one was specified>>                               15730000
if numparms >= 3 then                                                   15735000
  if logical(parms(2)).length > 0 then begin                            15740000
    temp:=parsemode(parms(2));                                          15745000
    if = then                                                           15750000
      dispmode:=temp                                                    15755000
    else begin                                                          15760000
      if > then printerror(1)                                           15765000
           else printerror(2);                                          15770000
      cc:=ccl;                                                          15775000
      return; end; end;                                                 15780000
                                                                        15785000
<<evaluate <match'suppress>, if one was specified>>                     15790000
if numparms >= 4 then                                                   15795000
  if logical(parms(3)).length > 0 then begin                            15800000
    temp:=parsematch(parms(3));                                         15805000
    if = then                                                           15810000
      match'suppress:=temp                                       <<nsf>>15815000
    else begin                                                          15820000
      if > then printerror(41)                                          15825000
           else printerror(42);                                         15830000
      cc:=ccl;                                                          15835000
      return; end; end;                                                 15840000
                                                                        15845000
end;  <<parsedisplay>>                                                  15850000
$page                                                                   15855000
$control segment=idat5                                                  15860000
<<***********************************************************>>  <<nsf>>15865000
<<  parsemodify                                              >>  <<nsf>>15870000
<<----------------------------------------------------------->>  <<nsf>>15875000
<< parse the "MODIFY" command                                >>  <<nsf>>15880000
<<***********************************************************>>  <<nsf>>15885000
procedure parsemodify(parmstring,start,count,dispmode);          <<nsf>>15890000
  integer      dispmode;  <<mode value>>                         <<nsf>>15895000
  double          count,  <<# of words to modify >>              <<nsf>>15900000
                  start;  <<address of 1st word to modify >>     <<nsf>>15905000
  byte array parmstring;  <<user input>>                         <<nsf>>15910000
begin                                                            <<nsf>>15915000
                                                                 <<nsf>>15920000
  << condition code is returned as follows:   >>                 <<nsf>>15925000
  <<                                          >>                 <<nsf>>15930000
  <<   ccg - unable to parse user input       >>                 <<nsf>>15935000
  <<   cce - successful                       >>                 <<nsf>>15940000
  <<   ccl - syntax error detected            >>                 <<nsf>>15945000
                                                                 <<nsf>>15950000
  << this procedure assumes the existence of the >>              <<nsf>>15955000
  << global variable dbregd and the following    >>              <<nsf>>15960000
  << procedures:                                 >>              <<nsf>>15965000
  <<      printerror         parseoffset         >>              <<nsf>>15970000
  <<      parsecount         parsemode           >>              <<nsf>>15975000
                                                                 <<nsf>>15980000
equate  maxparms = 50;                                           <<nsf>>15985000
                                                                 <<nsf>>15990000
define     cc = status.(6:2)#,                                   <<nsf>>15995000
       length = (0:8)#;                                          <<nsf>>16000000
                                                                 <<nsf>>16005000
logical   status = q-1; <<status register in marker>>            <<nsf>>16010000
integer numparms,       <<# parms found by "MYCOMMAND">>         <<nsf>>16015000
            temp;       <<temporary>>                            <<nsf>>16020000
double     dtemp;       <<temporary>>                            <<nsf>>16025000
                                                                 <<nsf>>16030000
double array parms(0:maxparms);  <<parms returned by the>>       <<nsf>>16035000
                                 <<mycommand intrinsic  >>       <<nsf>>16040000
                                                                 <<nsf>>16045000
byte array delimiters(0:3);  <<delimiters for mycommand>>        <<nsf>>16050000
                                                                 <<nsf>>16055000
cc:=cce;   <<assume no errors>>                                  <<nsf>>16060000
                                                                 <<nsf>>16065000
<<parse comm. to get <offset>, <count>, <mode> >>                <<nsf>>16070000
delimiters(0):=",";                                              <<nsf>>16075000
delimiters(1):=cr;                                               <<nsf>>16080000
mycommand(parmstring,delimiters,maxparms,numparms,parms);        <<nsf>>16085000
if <> then begin                                                 <<nsf>>16090000
  printerror(0);                                                 <<nsf>>16095000
  cc:=ccg;                                                       <<nsf>>16100000
  return; end;                                                   <<nsf>>16105000
                                                                 <<nsf>>16110000
if not (0 <= numparms <= 3) then begin                           <<nsf>>16115000
  printerror(7);                                                 <<nsf>>16120000
  cc:=ccl;                                                       <<nsf>>16125000
  return; end;                                                   <<nsf>>16130000
                                                                 <<nsf>>16135000
<<have correct number of parms - set up defaults>>               <<nsf>>16140000
tos:=dbbankreg;                                                  <<nsf>>16145000
tos:=dbreg;                                                      <<nsf>>16150000
start:=tos;                                                      <<nsf>>16155000
count:=1d;                                                       <<nsf>>16160000
dispmode:=octal'mode;                                            <<nsf>>16165000
                                                                 <<nsf>>16170000
<<evaluate <offset>, if one was specified>>                      <<nsf>>16175000
if numparms >= 1 then                                            <<nsf>>16180000
  if logical(parms(0)).length > 0 then begin                     <<nsf>>16185000
    dtemp:=parseoffset(parms(0));                                <<nsf>>16190000
    if = then                                                    <<nsf>>16195000
      start:=dtemp                                               <<nsf>>16200000
    else begin                                                   <<nsf>>16205000
      if > then printerror(5)                                    <<nsf>>16210000
           else printerror(6);                                   <<nsf>>16215000
      cc:=ccl;                                                   <<nsf>>16220000
      return; end; end;                                          <<nsf>>16225000
                                                                 <<nsf>>16230000
<<evaluate <count>, if one was specified>>                       <<nsf>>16235000
if numparms >= 2 then                                            <<nsf>>16240000
  if logical(parms(1)).length > 0 then begin                     <<nsf>>16245000
    dtemp:=parsecount(parms(1));                                 <<nsf>>16250000
    if = then                                                    <<nsf>>16255000
      count:=dtemp                                               <<nsf>>16260000
    else begin                                                   <<nsf>>16265000
      if > then printerror(3)                                    <<nsf>>16270000
           else printerror(4);                                   <<nsf>>16275000
      cc:=ccl;                                                   <<nsf>>16280000
      return; end; end;                                          <<nsf>>16285000
                                                                 <<nsf>>16290000
<<evaluate <mode>, if one was specified>>                        <<nsf>>16295000
if numparms >= 3 then                                            <<nsf>>16300000
  if logical(parms(2)).length > 0 then begin                     <<nsf>>16305000
    temp:=parsemode(parms(2));                                   <<nsf>>16310000
    if = then                                                    <<nsf>>16315000
      dispmode:=temp                                             <<nsf>>16320000
    else begin                                                   <<nsf>>16325000
      if > then printerror(1)                                    <<nsf>>16330000
           else printerror(2);                                   <<nsf>>16335000
      cc:=ccl;                                                   <<nsf>>16340000
      return; end; end;                                          <<nsf>>16345000
                                                                 <<nsf>>16350000
end;  <<parsemodify>>                                            <<nsf>>16355000
$page                                                                   16360000
<<***********************************************>>              <<nsf>>16365000
<<  getmod                                       >>              <<nsf>>16370000
<<----------------------------------------------->>              <<nsf>>16375000
<< prompt user for values to replace those on    >>              <<nsf>>16380000
<< disk.  user input can vary, depending on how  >>              <<nsf>>16385000
<< he/she would like to enter the data.          >>              <<nsf>>16390000
<<***********************************************>>              <<nsf>>16395000
                                                                 <<nsf>>16400000
procedure getmod(startaddr,endaddr,displaymode);                 <<nsf>>16405000
  value startaddr,endaddr,displaymode;                           <<nsf>>16410000
  double startaddr,endaddr;                                      <<nsf>>16415000
  integer displaymode;                                           <<nsf>>16420000
                                                                 <<nsf>>16425000
  begin                                                          <<nsf>>16430000
                                                                 <<nsf>>16435000
  double temp'addr, addr;                                               16440000
  logical temp'valu, addr'offset = addr+1;                              16445000
  integer numchar;                                               <<nsf>>16450000
  logical array tbufl(0:39);                                     <<nsf>>16455000
  byte array tbuf(*)=tbufl;                                      <<nsf>>16460000
                                                                 <<nsf>>16465000
  temp'addr:=startaddr;                                          <<nsf>>16470000
                                                                 <<nsf>>16475000
  while temp'addr <= endaddr do begin                            <<nsf>>16480000
    if (temp'addr >= double(dst'min+4)) and                             16485000
       (temp'addr <= double(dst'max))       then                        16490000
      begin                                                             16495000
      addr := temp'addr;                                                16500000
      addr'offset.(14:2) := 2;                                          16505000
      if dcore(addr) > max'real'mem then                                16510000
        begin                                                           16515000
        printerror(83);                                                 16520000
        return;                                                         16525000
        end;                                                            16530000
      end;                                                              16535000
    temp'valu:=core(temp'addr);                                  <<nsf>>16540000
    if <> then return;                                                  16545000
    dispdump(temp'addr,temp'valu,displaymode);                   <<nsf>>16550000
    numchar:=fread(infile,lbuf,-79); if <> then return;          <<nsf>>16555000
    if numchar > 0 then begin                                    <<nsf>>16560000
      case displaymode of                                        <<nsf>>16565000
        begin  <<case>>                                          <<nsf>>16570000
          <<octal>>  temp'valu:=getnumber(buf,numchar);          <<nsf>>16575000
          <<integer>>begin                                       <<nsf>>16580000
                       if buf(0) <> "%" then begin               <<nsf>>16585000
                         tbuf:="#";                              <<nsf>>16590000
                         move tbuf(1):=buf,(numchar);            <<nsf>>16595000
                         numchar:=numchar+1;                     <<nsf>>16600000
                         temp'valu:=getnumber(tbuf,numchar); end <<nsf>>16605000
                       else                                      <<nsf>>16610000
                         temp'valu:=getnumber(buf,numchar);      <<nsf>>16615000
                     end;                                        <<nsf>>16620000
          <<ascii>>  begin                                       <<nsf>>16625000
                       temp'valu:=lbuf(0);                       <<nsf>>16630000
                       if numchar>2 then printerror(58);         <<nsf>>16635000
                       putcore(temp'addr,temp'valu); end;        <<nsf>>16640000
        end;  <<case>>                                           <<nsf>>16645000
      if = then putcore(temp'addr,temp'valu)                     <<nsf>>16650000
      else printerror(53);                                       <<nsf>>16655000
    end;                                                         <<nsf>>16660000
    temp'addr:=temp'addr+1d;                                     <<nsf>>16665000
  end;                                                           <<nsf>>16670000
                                                                 <<nsf>>16675000
end;  <<getmod>>                                                 <<nsf>>16680000
$page                                                                   16685000
<<***********************************************************>>  <<nsf>>16690000
<<  modify                                                   >>  <<nsf>>16695000
<<----------------------------------------------------------->>  <<nsf>>16700000
<< execute the "MODIFY" command                              >>  <<nsf>>16705000
<<***********************************************************>>  <<nsf>>16710000
procedure modify(parmstring,startaddr,dispcount,displaymode);           16715000
  value startaddr,dispcount,displaymode;                         <<nsf>>16720000
  byte array parmstring;                                                16725000
  integer displaymode;   <<0: octal  >>                          <<nsf>>16730000
                         <<1: integer>>                          <<nsf>>16735000
                         <<2: ascii  >>                          <<nsf>>16740000
  double    dispcount,   <<# words to modify >>                  <<nsf>>16745000
            startaddr;   <<address of 1st word to modify >>      <<nsf>>16750000
begin                                                            <<nsf>>16755000
                                                                 <<nsf>>16760000
  << this procedure assumes the existence of the >>              <<nsf>>16765000
  << global variables:                           >>              <<nsf>>16770000
  <<       outfile              octal'mode       >>              <<nsf>>16775000
  <<       ascii'mode           octaldump (proc) >>              <<nsf>>16780000
  <<       octal'ascii          listfile         >>              <<nsf>>16785000
  <<       dda                  max'real'mem     >>                     16790000
                                                                 <<nsf>>16795000
                                                                 <<nsf>>16800000
double  endaddr;  <<address of last word to modify >>            <<nsf>>16805000
                                                                 <<nsf>>16810000
endaddr:=startaddr+dispcount-1d;                                 <<nsf>>16815000
                                                                 <<nsf>>16820000
if not dda and endaddr > max'real'mem  or                               16825000
   dda and endaddr > maxmem   then                                      16830000
  begin                                                                 16835000
  printerror(16);                                                       16840000
  return;                                                               16845000
  end;                                                                  16850000
if dda and endaddr > max'real'mem  then                                 16855000
  begin                                                                 16860000
  blankbuf;                                                             16865000
  move buf := "** VIRTUAL **";                                          16870000
  printline(outfile);                                                   16875000
  end;                                                                  16880000
if octal'mode <= displaymode <= ascii'mode then                  <<nsf>>16885000
  getmod(startaddr,endaddr,displaymode);                         <<nsf>>16890000
                                                                 <<nsf>>16895000
end;  <<modify>>                                                 <<nsf>>16900000
$page "                     PROCEDURE DISPLAY"                          16905000
$control segment=idat4                                                  16910000
<<***********************************************************>>         16915000
<<  display                                                  >>         16920000
<<----------------------------------------------------------->>         16925000
<< execute the "DISPLAY" command                             >>         16930000
<<***********************************************************>>         16935000
procedure display(parmstring,startaddr,dispcount,displaymode,           16940000
                  match'suppress);                                      16945000
  value startaddr,dispcount,displaymode,match'suppress;                 16950000
  byte array parmstring;                                                16955000
  integer displaymode;   <<0: octal  >>                                 16960000
                         <<1: integer>>                                 16965000
                         <<2: ascii  >>                                 16970000
                         <<3: code   >>                                 16975000
                         <<4: octal and ascii>>                         16980000
  logical match'suppress;<<supress compare for matching memory>>        16985000
  double    dispcount,   <<# words to display>>                         16990000
            startaddr;   <<address of 1st word to display>>             16995000
begin                                                                   17000000
                                                                        17005000
  << this procedure assumes the existence of the >>                     17010000
  << global variables:                           >>                     17015000
  <<       outfile              octal'mode       >>                     17020000
  <<       ascii'mode           octaldump (proc) >>                     17025000
  <<       octal'ascii          listfile         >>                     17030000
  <<       dda                  max'real'mem     >>                     17035000
                                                                        17040000
                                                                        17045000
double  endaddr;  <<address of last word to display>>                   17050000
                                                                        17055000
endaddr:=startaddr+dispcount-1d;                                        17060000
                                                                        17065000
if not dda and endaddr > max'real'mem  or                               17070000
   dda and endaddr > maxmem   then                                      17075000
  begin                                                                 17080000
  printerror(16);                                                       17085000
  return;                                                               17090000
  end;                                                                  17095000
if dda and endaddr > max'real'mem  then                                 17100000
  begin                                                                 17105000
  blankbuf;                                                             17110000
  move buf := "** VIRTUAL **";                                          17115000
  printline(outfile);                                                   17120000
  end;                                                                  17125000
if octal'mode <= displaymode <= octal'ascii then                 <<nsf>>17130000
  octaldump(outfile,startaddr,endaddr,displaymode,match'suppress);      17135000
                                                                        17140000
end;  <<display>>                                                       17145000
$page"      GET'PNAME: Return prog name from loader aux dseg"  <<*nth*>>17150000
procedure get'pname(cstx'indx,b'target);                       <<*nth*>>17155000
value cstx'indx;                                               <<*nth*>>17160000
integer cstx'indx;                                             <<*nth*>>17165000
byte array b'target;                                           <<*nth*>>17170000
                                                               <<*nth*>>17175000
begin                                                          <<*nth*>>17180000
integer i,j,k;                                                 <<*nth*>>17185000
logical array temp(0:1);                                       <<*nth*>>17190000
byte array b'temp(*) = temp;                                   <<*nth*>>17195000
double addr,lst'addr,lax'addr,pnames'addr;                     <<*nth*>>17200000
integer ent'len;                                               <<*nth*>>17205000
logical next'table;                                            <<*nth*>>17210000
define                                                         <<*nth*>>17215000
  lst'dstno = %22#,                                            <<*nth*>>17220000
  lax'offset = 38d#,                                           <<*nth*>>17225000
  entry'len'offset = -7d#,                                     <<*nth*>>17230000
  next'table'offset = 4d#;                                     <<*nth*>>17235000
                                                               <<*nth*>>17240000
lst'addr := getdstaddr(lst'dstno);                             <<*nth*>>17245000
if lst'addr <> 0d then                                         <<*nth*>>17250000
  lax'addr := getdstaddr((core(lst'addr + lax'offset)).(1:15)) <<*nth*>>17255000
else lax'addr := 0d;                                           <<*nth*>>17260000
if lax'addr <> 0d then                                         <<*nth*>>17265000
  next'table := core(lax'addr + next'table'offset);            <<*nth*>>17270000
if lax'addr <> 0d and cstx'indx > 0 and next'table > 0 then    <<*nth*>>17275000
  begin                                                        <<*nth*>>17280000
  pnames'addr := lax'addr + double(next'table);                <<*nth*>>17285000
  ent'len := core(pnames'addr + entry'len'offset);             <<*nth*>>17290000
  addr := pnames'addr + double(cstx'indx*ent'len);             <<*nth*>>17295000
                                                               <<*nth*>>17300000
  @pbuf := @b'target;                                          <<*nth*>>17305000
  i := 0;                                                      <<*nth*>>17310000
  while i <= 2 do                                              <<*nth*>>17315000
    begin                                                      <<*nth*>>17320000
    j := 0;                                                    <<*nth*>>17325000
    while j <= 3 do                                            <<*nth*>>17330000
      begin                                                    <<*nth*>>17335000
      temp := core(addr + double(i*4+j));                      <<*nth*>>17340000
      k := 0;                                                  <<*nth*>>17345000
      while k <= 1 do                                          <<*nth*>>17350000
        begin                                                  <<*nth*>>17355000
        if b'temp(k) = " " then go next'name;                  <<*nth*>>17360000
        pbuf := b'temp(k);                                     <<*nth*>>17365000
        @pbuf := @pbuf + 1;                                    <<*nth*>>17370000
        k := k + 1;                                            <<*nth*>>17375000
        end;  << k >>                                          <<*nth*>>17380000
      j := j + 1;                                              <<*nth*>>17385000
      end;  << j >>                                            <<*nth*>>17390000
  next'name:                                                   <<*nth*>>17395000
    if i < 2 then pbuf := ".";                                 <<*nth*>>17400000
    @pbuf := @pbuf + 1;                                        <<*nth*>>17405000
    i := i + 1;                                                <<*nth*>>17410000
    end;  << i >>                                              <<*nth*>>17415000
  end;                                                         <<*nth*>>17420000
end;  << get'pname >>                                          <<*nth*>>17425000
$page "                     PROCEDURE FMTSTACK5"                        17430000
$control segment=idat5a                                                 17435000
<<*********************************************>>                <<nsf>>17440000
<<  fmtstack5                                  >>                <<nsf>>17445000
<<--------------------------------------------->>                <<nsf>>17450000
<< formats area specified as a stack           >>                <<nsf>>17455000
<<*********************************************>>                <<nsf>>17460000
procedure fmtstack5(f'num,base'addr,dstnum);                  <<860505>>17465000
value base'addr,                         <<address of pcbx>>     <<nsf>>17470000
      f'num,                            <<file to write on>>  <<860505>>17475000
      dstnum;                           << stack dst # >>     <<860505>>17480000
double base'addr;                                                <<nsf>>17485000
integer f'num,                                                <<860505>>17490000
        dstnum;                                               <<860505>>17495000
<< this procedure assumes the existence of the >>                <<nsf>>17500000
<< procedures "CORE" and "PRT'STK5"            >>                <<nsf>>17505000
begin                                                            <<nsf>>17510000
double addr;                     <<scratch copy of base'addr>>   <<nsf>>17515000
logical bank=addr,                                  <<bank #>>   <<nsf>>17520000
        offset=addr+1;                  <<offset within bank>>   <<nsf>>17525000
integer current's'ptr,                  <<pointer to delta q>>   <<nsf>>17530000
        q'init,                         <<first stack marker>>   <<nsf>>17535000
        len,                             <<param. for fwrite>>   <<nsf>>17540000
        db'ptr,                         <<seg rel db pointer>>   <<nsf>>17545000
        seg'off,                   <<temp storage for offset>>   <<nsf>>17550000
        data,                       <<contents of a location>>   <<nsf>>17555000
        count:=1,                        <<# words in pxglob>>   <<nsf>>17560000
        i:=12;                         <<col # to place info>><<850806>>17565000
                                                                 <<nsf>>17570000
array iobuf(0:39);                          <<buffer for i/o>>   <<nsf>>17575000
byte array iobufb(*)=iobuf;                                      <<nsf>>17580000
                                                                 <<nsf>>17585000
equate no'rtn=%320,                           <<no cr, no lf>>   <<nsf>>17590000
       s'space=%40,                           <<single space>>   <<nsf>>17595000
       octal=8,                                <<octal value>>   <<nsf>>17600000
       pxglob'len=12,                    <<# words in pxglob>>   <<nsf>>17605000
       seg'rel'db=1,                <<offset in pxglob of db>>   <<nsf>>17610000
       jmat'ix=3,           <<offset in pxglob of jmat index>>   <<nsf>>17615000
       jpcnt'ix=4,         <<offset in pxglob of jpcnt index>>   <<nsf>>17620000
       ip'ldn=8,               <<offset in pxglob of i/p ldn>>   <<nsf>>17625000
       op'ldn=9,               <<offset in pxglob of o/p ldn>>   <<nsf>>17630000
       jdt'dst'ix=10,    <<offset in pxglob of jdt dst index>>   <<nsf>>17635000
       jit'dst'ix=11,    <<offset in pxglob of jit dst index>>   <<nsf>>17640000
       jcut'ix=5,           <<offset in pxglob of jcut index>>   <<nsf>>17645000
       und=0,                      <<type of job - undefined>>   <<nsf>>17650000
       ses=1,                        <<type of job - session>>   <<nsf>>17655000
       job=2,                            <<type of job - job>>   <<nsf>>17660000
       task=3,                          <<type of job - task>>   <<nsf>>17665000
       seg'rel's=13,                   <<offset in pcbx of s>>   <<nsf>>17670000
       seg'rel'qinit=15;       <<offset in pcbx of q initial>>   <<nsf>>17675000
define type=(2:2)#,               <<bit location of job type>>   <<nsf>>17680000
       dup=(4:1)#,             <<bit location of duplicative>>   <<nsf>>17685000
       int=(5:1)#;             <<bit location of interactive>>   <<nsf>>17690000
                                                                 <<nsf>>17695000
   if base'addr < 0d or base'addr > maxmem  then                        17700000
     begin                                                              17705000
     printerror(86);                                                    17710000
     return;                                                            17715000
     end;                                                               17720000
                                                                        17725000
   <<dump out pxglob>>                                           <<nsf>>17730000
   write'rec(f'num,iobuf,0,s'space);                                    17735000
   move iobuf := "***PXGLOBAL***";           <<set up buffer>>   <<nsf>>17740000
   write'rec(f'num,iobuf,-14,s'space);          <<print heading>>       17745000
   if <> then quit(10);                                          <<nsf>>17750000
   write'rec(f'num,iobuf,0,s'space);         <<print blank line>>       17755000
   if <> then quit(11);                                          <<nsf>>17760000
                                                                 <<nsf>>17765000
   <<clear buffer>>                                              <<nsf>>17770000
   iobuf(0):="  ";                                               <<nsf>>17775000
   move iobuf(1):=iobuf(0),(39);    <<fill iobuf with blanks>>   <<nsf>>17780000
   addr:=base'addr;                  <<set addr to base'addr>>   <<nsf>>17785000
   seg'off:=offset;                            <<save offset>>   <<nsf>>17790000
   ascii(bank,octal,iobufb);                                  <<850806>>17795000
   move iobufb:=iobufb(3),(3);                                <<850806>>17800000
   move iobufb(3):="   ";                                     <<850806>>17805000
   ascii(offset,octal,iobufb(4));    <<move offset to iobufb>><<850806>>17810000
   move iobufb(10):=":";                                      <<850806>>17815000
                                                                 <<nsf>>17820000
   <<start printing unformatted pxglob>>                         <<nsf>>17825000
   while count <= pxglob'len do begin      <<print each word>>   <<nsf>>17830000
     if count = (pxglob'len/2)+1 then begin                      <<nsf>>17835000
       << print a line at the half-way point >>                  <<nsf>>17840000
       write'rec(f'num,iobuf,-79,s'space);                              17845000
       if <> then quit(12);                                      <<nsf>>17850000
       ascii(bank,octal,iobufb);                              <<850806>>17855000
       move iobufb:=iobufb(3),(3);                            <<850806>>17860000
       move iobufb(3):="   ";                                 <<850806>>17865000
       ascii(offset,octal,iobufb(4));                         <<850806>>17870000
       i:=12;                                                 <<850806>>17875000
     end;                                                        <<nsf>>17880000
      data:=core(addr);                      <<read in value>>   <<nsf>>17885000
      ascii(data,octal,iobufb(i));           <<convert value>>   <<nsf>>17890000
      offset := offset + 1;               <<increment offset>>   <<nsf>>17895000
      i := i + 8;                          <<increment col #>>   <<nsf>>17900000
      count := count + 1;                <<increment counter>>   <<nsf>>17905000
      end;                                                       <<nsf>>17910000
                                                                 <<nsf>>17915000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       17920000
   if <> then quit(12);                                          <<nsf>>17925000
   write'rec(f'num,iobuf,0,s'space);                                    17930000
   if <> then quit(17);                                          <<nsf>>17935000
   iobuf(0):="  ";                                               <<nsf>>17940000
   move iobuf(1):=iobuf(0),(39);              <<clear buffer>>   <<nsf>>17945000
                                                                 <<nsf>>17950000
   <<print formatted pxglob>>                                    <<nsf>>17955000
   move iobufb := "SEG REL DL:";                   <<heading>>   <<nsf>>17960000
   offset:=seg'off;                  <<set dl offset in pcbx>>   <<nsf>>17965000
   data:=core(addr);                      <<read in dl value>>   <<nsf>>17970000
   if <> then return;                                         <<850806>>17975000
   ascii(data,octal,iobufb(12));             <<convert value>>   <<nsf>>17980000
   move iobufb(19):="SEG REL DB:";                 <<heading>>   <<nsf>>17985000
   offset:=seg'off+seg'rel'db;       <<set db offset in pcbx>>   <<nsf>>17990000
   data:=core(addr);                      <<read in db value>>   <<nsf>>17995000
   if <> then return;                                         <<850806>>18000000
   ascii(data,octal,iobufb(31));             <<convert value>>   <<nsf>>18005000
   move iobufb(38):="JMAT INDEX:";                 <<heading>>   <<nsf>>18010000
   offset:=seg'off+jmat'ix;        <<set jmat offset in pcbx>>   <<nsf>>18015000
   data:=core(addr);                    <<read in jmat index>>   <<nsf>>18020000
   if <> then return;                                         <<850806>>18025000
   ascii(data,octal,iobufb(52));        <<convert value>>        <<nsf>>18030000
   move iobufb(59):="JPCNT INDEX:";                <<heading>>   <<nsf>>18035000
   offset:=seg'off+jpcnt'ix;      <<set jpcnt offset in pcbx>>   <<nsf>>18040000
   data:=core(addr);                   <<read in jpcnt index>>   <<nsf>>18045000
   if <> then return;                                         <<850806>>18050000
   ascii(data,octal,iobufb(73));       <<convert value>>         <<nsf>>18055000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       18060000
   if <> then quit(13);                                          <<nsf>>18065000
   iobuf(0):="  ";                                               <<nsf>>18070000
   move iobuf(1):=iobuf(0),(39);              <<clear buffer>>   <<nsf>>18075000
   move iobufb:="JOB IP LDN:";                     <<heading>>   <<nsf>>18080000
   offset:=seg'off+ip'ldn;       <<set offset to job i/p ldn>>   <<nsf>>18085000
   data:=core(addr);                   <<read in job i/p ldn>>   <<nsf>>18090000
   if <> then return;                                         <<850806>>18095000
   ascii(data,octal,iobufb(12));          <<convert value>>      <<nsf>>18100000
   move iobufb(19):="JOB OP LDN:";                 <<heading>>   <<nsf>>18105000
   offset:=seg'off+op'ldn;       <<set offset to job o/p ldn>>   <<nsf>>18110000
   data:=core(addr);                   <<read in job o/p ldn>>   <<nsf>>18115000
   if <> then return;                                         <<850806>>18120000
   ascii(data,octal,iobufb(31));          <<convert value>>      <<nsf>>18125000
   move iobufb(38):="JDT DST INDX:";               <<heading>>   <<nsf>>18130000
   offset:=seg'off+jdt'dst'ix;       <<set offset to jdt dst>>   <<nsf>>18135000
   data:=core(addr);                       <<read in jdt dst>>   <<nsf>>18140000
   if <> then return;                                         <<850806>>18145000
   ascii(data,octal,iobufb(52));         <<convert value>>       <<nsf>>18150000
   move iobufb(59):="JIT DST INDX:";               <<heading>>   <<nsf>>18155000
   offset:=seg'off+jit'dst'ix;       <<set offset to jit dst>>   <<nsf>>18160000
   data:=core(addr);                       <<read in jit dst>>   <<nsf>>18165000
   if <> then return;                                         <<850806>>18170000
   ascii(data,octal,iobufb(73));         <<convert value>>       <<nsf>>18175000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       18180000
   if <> then quit(14);                                          <<nsf>>18185000
   iobuf(0):="  ";                                               <<nsf>>18190000
   move iobuf(1):=iobuf(0),(39);              <<clear buffer>>   <<nsf>>18195000
   move iobufb:="JOB TYPE:";                       <<heading>>   <<nsf>>18200000
   offset:=seg'off+6;            <<mpe v/e location of flags>>   <<nsf>>18205000
   data:=core(addr);                                             <<nsf>>18210000
   if <> then return;                                         <<850806>>18215000
   if data.type=und then move iobufb(11):="UNDEF"                <<nsf>>18220000
   else if data.type=ses then move iobufb(11):="SESSION"         <<nsf>>18225000
   else if data.type=job then move iobufb(11):="JOB"             <<nsf>>18230000
   else if data.type=task then move iobufb(11):="TASK";          <<nsf>>18235000
   move iobufb(19):="DUP:";                                      <<nsf>>18240000
   if data.dup<>0 then move iobufb(31):="YES"                    <<nsf>>18245000
   else move iobufb(31):="NO";                                   <<nsf>>18250000
   move iobufb(38):="INTERACT:";                                 <<nsf>>18255000
   if data.int <> 0 then move iobufb(52):="YES"                  <<nsf>>18260000
   else move iobufb(52):="NO";                                   <<nsf>>18265000
   move iobufb(59):="JCUT INDEX:";                 <<heading>>   <<nsf>>18270000
   offset:=seg'off+jcut'ix;             <<set offset to jcut>>   <<nsf>>18275000
   data:=core(addr);                          <<read in jcut>>   <<nsf>>18280000
   if <> then return;                                         <<850806>>18285000
   ascii(data,octal,iobufb(73));        <<convert value>>        <<nsf>>18290000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       18295000
   if <> then quit(15);                                          <<nsf>>18300000
   write'rec(f'num,iobuf,0,s'space);         <<print blank line>>       18305000
   if <> then quit(16);                                          <<nsf>>18310000
   addr:=base'addr;                             <<reset addr>>   <<nsf>>18315000
   offset:=offset+1;                      <<set offset to db>>   <<nsf>>18320000
   db'ptr:=core(addr);                          <<seg rel db>>   <<nsf>>18325000
   if <> then return;                                         <<850806>>18330000
                                                                 <<nsf>>18335000
   <<seg rel s>>                                                 <<nsf>>18340000
   offset:=seg'off+seg'rel's;                                    <<nsf>>18345000
   current's'ptr:=core(addr)+logical(db'ptr-2);                  <<nsf>>18350000
   offset:=seg'off+seg'rel'qinit;      <<set offset to qinit>>   <<nsf>>18355000
   q'init:=core(addr)+logical(db'ptr);       <<seg rel qinit>>   <<nsf>>18360000
   prt'stk5(f'num,base'addr,current's'ptr,q'init,dstnum);     <<860505>>18365000
                                                                 <<nsf>>18370000
  end;  <<fmtstack5>>                                            <<nsf>>18375000
$page "                      PROCEDURE FMTSTACK4"                       18380000
$control segment=idat4a                                                 18385000
<<*********************************************>>                       18390000
<<  fmtstack4                                  >>                       18395000
<<--------------------------------------------->>                       18400000
<< formats area specified as a stack           >>                       18405000
<<*********************************************>>                       18410000
procedure fmtstack4(f'num,base'addr,dstnum);                  <<860505>>18415000
value base'addr,                         <<address of pcbx>>            18420000
      f'num,                            <<file to write on>>  <<860505>>18425000
      dstnum;                           << stack dst # >>     <<860505>>18430000
double base'addr;                                                       18435000
integer f'num,                                                <<860505>>18440000
        dstnum;                                               <<860505>>18445000
<< this procedure assumes the existence of the >>                       18450000
<< procedures "CORE" and "PRT'STK4"            >>                       18455000
begin                                                                   18460000
double addr;                     <<scratch copy of base'addr>>          18465000
logical bank=addr,                                  <<bank #>>          18470000
        offset=addr+1;                  <<offset within bank>>          18475000
integer current's'ptr,                  <<pointer to delta q>>          18480000
        q'init,                         <<first stack marker>>          18485000
        len,                             <<param. for fwrite>>          18490000
        db'ptr,                         <<seg rel db pointer>>          18495000
        seg'off,                   <<temp storage for offset>>          18500000
        data,                       <<contents of a location>>          18505000
        count:=1,                        <<# words in pxglob>>          18510000
        i:=12;                         <<col # to place info>><<850806>>18515000
                                                                        18520000
array iobuf(0:39);                          <<buffer for i/o>>          18525000
byte array iobufb(*)=iobuf;                                             18530000
                                                                        18535000
equate no'rtn=%320,                           <<no cr, no lf>>          18540000
       s'space=%40,                           <<single space>>          18545000
       octal=8,                                <<octal value>>          18550000
       pxglob'len=8,                     <<# words in pxglob>>          18555000
       seg'rel'db=1,                <<offset in pxglob of db>>          18560000
       jmat'ix=3,           <<offset in pxglob of jmat index>>          18565000
       jpcnt'ix=4,         <<offset in pxglob of jpcnt index>>          18570000
       ip'ldn=3,               <<offset in pxglob of i/p ldn>>          18575000
       op'ldn=4,               <<offset in pxglob of o/p ldn>>          18580000
       jdt'dst'ix=5,     <<offset in pxglob of jdt dst index>>          18585000
       jit'dst'ix=6,     <<offset in pxglob of jit dst index>>          18590000
       jcut'ix=7,           <<offset in pxglob of jcut index>>          18595000
       und=0,                      <<type of job - undefined>>          18600000
       ses=1,                        <<type of job - session>>          18605000
       job=2,                            <<type of job - job>>          18610000
       task=3,                          <<type of job - task>>          18615000
       seg'rel's=9,                    <<offset in pcbx of s>>          18620000
       seg'rel'qinit=11;       <<offset in pcbx of q initial>>          18625000
define jmat=(0:8)#,                   <<bit location of jmat>>          18630000
       jpcnt=(0:8)#,                 <<bit location of jpcnt>>          18635000
       ip=(8:8)#,                  <<bit location of i/p ldn>>          18640000
       op=(8:8)#,                  <<bit location of o/p ldn>>          18645000
       jdt=(6:10)#,                <<bit location of jdt dst>>          18650000
       jit=(6:10)#,                <<bit location of jit dst>>          18655000
       type=(2:2)#,               <<bit location of job type>>          18660000
       dup=(4:1)#,             <<bit location of duplicative>>          18665000
       int=(5:1)#,             <<bit location of interactive>>          18670000
       jcut=(0:8)#;                   <<bit location of jcut>>          18675000
                                                                        18680000
    if base'addr < 0d or base'addr > maxmem  then                       18685000
      begin                                                             18690000
      printerror(86);                                                   18695000
      return;                                                           18700000
      end;                                                              18705000
                                                                        18710000
   <<dump out pxglob>>                                                  18715000
   write'rec(f'num,iobuf,0,s'space);                                    18720000
   move iobuf := "***PXGLOBAL***";           <<set up buffer>>          18725000
   write'rec(f'num,iobuf,-14,s'space);          <<print heading>>       18730000
   if <> then quit(10);                                                 18735000
   write'rec(f'num,iobuf,0,s'space);         <<print blank line>>       18740000
   if <> then quit(11);                                                 18745000
                                                                        18750000
   <<clear buffer>>                                                     18755000
   iobuf(0):="  ";                                                      18760000
   move iobuf(1):=iobuf(0),(39);    <<fill iobuf with blanks>>          18765000
   addr:=base'addr;                  <<set addr to base'addr>>          18770000
   seg'off:=offset;                            <<save offset>>          18775000
   ascii(bank,octal,iobufb);                                  <<850806>>18780000
   move iobufb:=iobufb(3),(3);                                <<850806>>18785000
   move iobufb(3):="   ";                                     <<850806>>18790000
   ascii(offset,octal,iobufb(4));    <<move offset to iobufb>><<850806>>18795000
   move iobufb(10):=":";                                      <<850806>>18800000
                                                                        18805000
   <<start printing unformatted pxglob>>                                18810000
   while count <= pxglob'len do begin      <<print each word>>          18815000
      data:=core(addr);                      <<read in value>>          18820000
      if <> then return;                                      <<850806>>18825000
      ascii(data,octal,iobufb(i));           <<convert value>>          18830000
      offset := offset + 1;               <<increment offset>>          18835000
      i := i + 8;                          <<increment col #>>          18840000
      count := count + 1;                <<increment counter>>          18845000
      end;                                                              18850000
                                                                        18855000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       18860000
   if <> then quit(12);                                                 18865000
   write'rec(f'num,iobuf,0,s'space);                                    18870000
   if <> then quit(17);                                                 18875000
   iobuf(0):="  ";                                                      18880000
   move iobuf(1):=iobuf(0),(39);              <<clear buffer>>          18885000
                                                                        18890000
   <<print formatted pxglob>>                                           18895000
   move iobufb := "SEG REL DL:";                   <<heading>>          18900000
   offset:=seg'off;                  <<set dl offset in pcbx>>          18905000
   data:=core(addr);                      <<read in dl value>>          18910000
   if <> then return;                                         <<850806>>18915000
   ascii(data,octal,iobufb(12));             <<convert value>>          18920000
   move iobufb(19):="SEG REL DB:";                 <<heading>>          18925000
   offset:=seg'off+seg'rel'db;       <<set db offset in pcbx>>          18930000
   data:=core(addr);                      <<read in db value>>          18935000
   if <> then return;                                         <<850806>>18940000
   ascii(data,octal,iobufb(31));             <<convert value>>          18945000
   move iobufb(38):="JMAT INDEX:";                 <<heading>>          18950000
   offset:=seg'off+jmat'ix;        <<set jmat offset in pcbx>>          18955000
   data:=core(addr);                    <<read in jmat index>>          18960000
   if <> then return;                                         <<850806>>18965000
   ascii(data.jmat,octal,iobufb(52));        <<convert value>>          18970000
   move iobufb(59):="JPCNT INDEX:";                <<heading>>          18975000
   offset:=seg'off+jpcnt'ix;      <<set jpcnt offset in pcbx>>          18980000
   data:=core(addr);                   <<read in jpcnt index>>          18985000
   if <> then return;                                         <<850806>>18990000
   ascii(data.jpcnt,octal,iobufb(73));       <<convert value>>          18995000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       19000000
   if <> then quit(13);                                                 19005000
   iobuf(0):="  ";                                                      19010000
   move iobuf(1):=iobuf(0),(39);              <<clear buffer>>          19015000
   move iobufb:="JOB IP LDN:";                     <<heading>>          19020000
   offset:=seg'off+ip'ldn;       <<set offset to job i/p ldn>>          19025000
   data:=core(addr);                   <<read in job i/p ldn>>          19030000
   if <> then return;                                         <<850806>>19035000
   ascii(data.ip,octal,iobufb(12));          <<convert value>>          19040000
   move iobufb(19):="JOB OP LDN:";                 <<heading>>          19045000
   offset:=seg'off+op'ldn;       <<set offset to job o/p ldn>>          19050000
   data:=core(addr);                   <<read in job o/p ldn>>          19055000
   if <> then return;                                         <<850806>>19060000
   ascii(data.op,octal,iobufb(31));          <<convert value>>          19065000
   move iobufb(38):="JDT DST INDX:";               <<heading>>          19070000
   offset:=seg'off+jdt'dst'ix;       <<set offset to jdt dst>>          19075000
   data:=core(addr);                       <<read in jdt dst>>          19080000
   if <> then return;                                         <<850806>>19085000
   ascii(data.jdt,octal,iobufb(52));         <<convert value>>          19090000
   move iobufb(59):="JIT DST INDX:";               <<heading>>          19095000
   offset:=seg'off+jit'dst'ix;       <<set offset to jit dst>>          19100000
   data:=core(addr);                       <<read in jit dst>>          19105000
   if <> then return;                                         <<850806>>19110000
   ascii(data.jit,octal,iobufb(73));         <<convert value>>          19115000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       19120000
   if <> then quit(14);                                                 19125000
   iobuf(0):="  ";                                                      19130000
   move iobuf(1):=iobuf(0),(39);              <<clear buffer>>          19135000
   move iobufb:="JOB TYPE:";                       <<heading>>          19140000
   if data.type=und then move iobufb(11):="UNDEF"                       19145000
   else if data.type=ses then move iobufb(11):="SESSION"                19150000
   else if data.type=job then move iobufb(11):="JOB"                    19155000
   else if data.type=task then move iobufb(11):="TASK";                 19160000
   move iobufb(19):="DUP:";                                             19165000
   if data.dup<>0 then move iobufb(31):="YES"                           19170000
   else move iobufb(31):="NO";                                          19175000
   move iobufb(38):="INTERACT:";                                        19180000
   if data.int <> 0 then move iobufb(52):="YES"                         19185000
   else move iobufb(52):="NO";                                          19190000
   move iobufb(59):="JCUT INDEX:";                 <<heading>>          19195000
   offset:=seg'off+jcut'ix;             <<set offset to jcut>>          19200000
   data:=core(addr);                          <<read in jcut>>          19205000
   if <> then return;                                         <<850806>>19210000
   ascii(data.jcut,octal,iobufb(73));        <<convert value>>          19215000
   write'rec(f'num,iobuf,-79,s'space);           <<print buffer>>       19220000
   if <> then quit(15);                                                 19225000
   write'rec(f'num,iobuf,0,s'space);         <<print blank line>>       19230000
   if <> then quit(16);                                                 19235000
   addr:=base'addr;                             <<reset addr>>          19240000
   offset:=offset+1;                      <<set offset to db>>          19245000
   db'ptr:=core(addr);                          <<seg rel db>>          19250000
   if <> then return;                                         <<850806>>19255000
                                                                        19260000
   <<seg rel s>>                                                        19265000
   offset:=seg'off+seg'rel's;                                           19270000
   current's'ptr:=core(addr)+logical(db'ptr-2);                         19275000
   offset:=seg'off+seg'rel'qinit;      <<set offset to qinit>>          19280000
   q'init:=core(addr)+logical(db'ptr);       <<seg rel qinit>>          19285000
   prt'stk4(f'num,base'addr,current's'ptr,q'init,dstnum);     <<860505>>19290000
                                                                        19295000
  end;  <<fmtstack4>>                                                   19300000
$page "                     PROCEDURE PRT'STK5"                         19305000
$control segment=idat5a                                                 19310000
<<**********************************************>>               <<nsf>>19315000
<<  prt'stk5                                    >>               <<nsf>>19320000
<<---------------------------------------------->>               <<nsf>>19325000
<< prints formatted stack from q initial on     >>               <<nsf>>19330000
<<**********************************************>>               <<nsf>>19335000
procedure prt'stk5(f'num,adr,s,qinitl,dstnum);                <<860505>>19340000
  value f'num,                             <<file to write on>>  <<nsf>>19345000
        adr,                                      <<base'addr>>  <<nsf>>19350000
        s,                                <<seg rel s pointer>>  <<nsf>>19355000
        qinitl,          <<seg rel pointer  to beg. of stack>><<860505>>19360000
        dstnum;                                               <<860505>>19365000
                                                                 <<nsf>>19370000
  integer f'num,                                                 <<nsf>>19375000
          s,                                                     <<nsf>>19380000
          qinitl,                                             <<860505>>19385000
          dstnum;                                             <<860505>>19390000
                                                                 <<nsf>>19395000
  double adr;                                                    <<nsf>>19400000
                                                                 <<nsf>>19405000
  << this procedure assumes the exitence of the >>               <<nsf>>19410000
  << procedures "CORE", "PRINTERROR", and       >>               <<nsf>>19415000
  << "GETCORE"                                  >>               <<nsf>>19420000
                                                                 <<nsf>>19425000
                                                                 <<nsf>>19430000
  begin                                                          <<nsf>>19435000
    integer count,                <<counter for stack marker>>   <<nsf>>19440000
            j,                          <<index for stk'mrkr>>   <<nsf>>19445000
            i;                     <<col # to place info. in>>   <<nsf>>19450000
    logical delta'q,         <<# of words to previous marker>>   <<nsf>>19455000
            hold'dp,                                          <<850806>>19460000
            qinit'adr,                                        <<850806>>19465000
            hold'qi,                                          <<850806>>19470000
            hold'dq,               <<scratch copy of delta'q>>   <<nsf>>19475000
            hold's;                      <<scratch copy of s>>   <<nsf>>19480000
    define cst'seg = stk'mrkr(j-2).(8:8)#,                       <<nsf>>19485000
       phys'mapped = stk'mrkr(j-3).(1:1)#;                       <<nsf>>19490000
    double hold'adr,                   <<scratch copy of adr>>   <<nsf>>19495000
           pcb'adr;                                              <<nsf>>19500000
                                                                 <<nsf>>19505000
    logical hold'bnk=hold'adr,                                   <<nsf>>19510000
            hold'off=hold'adr+1,                                 <<nsf>>19515000
            pcb'bnk=pcb'adr,                                            19520000
            pcb'off=pcb'adr+1;                                          19525000
    logical bnk=adr,                                             <<nsf>>19530000
            off=adr+1;                                           <<nsf>>19535000
    logical offset;                                              <<nsf>>19540000
    logical curprocstk;                                          <<nsf>>19545000
    double dstbase,                                              <<nsf>>19550000
           dstbaseoffset;                                        <<nsf>>19555000
    integer stkdst;                                              <<nsf>>19560000
                                                                 <<nsf>>19565000
    array buf(0:39),                            <<i/o buffer>>   <<nsf>>19570000
          stk'mrkr(0:3);                <<holds stack marker>>   <<nsf>>19575000
                                                                 <<nsf>>19580000
    byte array bufb(*)=buf;                                      <<nsf>>19585000
                                                                 <<nsf>>19590000
    equate octal=8,                            <<octal value>>   <<nsf>>19595000
           s'space=%40,                       <<single space>>   <<nsf>>19600000
           stk'words=4;         <<# of words in stack marker>>   <<nsf>>19605000
                                                                 <<nsf>>19610000
    hold'adr:=adr;                              <<initialize>>   <<nsf>>19615000
    qinit'adr:=logical(qinitl)+off;                           <<850806>>19620000
    hold'qi:=qinitl;                                          <<850806>>19625000
                                                                 <<nsf>>19630000
    <<if this is current stack, we must treat it differently>>   <<nsf>>19635000
    dstbase:=double(core(2d));                                   <<nsf>>19640000
<< find the dst # of the current process, if any. >>          <<860505>>19645000
    pcb'bnk := core(%1003d) land %37;                                   19650000
    pcb'off := (core(%1003d) land %177740) + %1000;                     19655000
    stkdst:=core(pcb'adr + double(core(4d)) + 3d).(2:14);               19660000
    if not(validdst(dstnum)) and core(4d)<>0  then begin      <<851230>>19665000
      printerror(71);                                         <<851230>>19670000
      return;                                                 <<851230>>19675000
    end;                                                      <<851230>>19680000
    dstbaseoffset:=double(dstnum*4)+dstbase;                  <<860505>>19685000
    curprocstk:=(dstnum = stkdst);                            <<860505>>19690000
    offset := logical(s);                                        <<nsf>>19695000
    if (core(4d) <> 0 ) and curprocstk then                      <<nsf>>19700000
       begin                                                     <<nsf>>19705000
       move buf:="* CURRENT PROCESS *";                          <<nsf>>19710000
       write'rec(f'num,buf,-19,s'space);                                19715000
       if <> then quit(21);                                      <<nsf>>19720000
       blankbuf;  printline(outfile);                                   19725000
       offset := qreg - off;                                     <<nsf>>19730000
       end;                                                      <<nsf>>19735000
                                                                 <<nsf>>19740000
    if curprocstk and zbankreg = 0 and sreg > core(5d) and    <<850806>>19745000
      sreg < core(6d) then begin << on ics at time of dump >> <<850806>>19750000
      hold'bnk:=core(double(core(5d))-5d);                    <<850806>>19755000
      hold'off:=core(double(core(5d))-6d) +                   <<850806>>19760000
                core(double(core(5d))-4d);                    <<850806>>19765000
      hold'off:=hold'off - 2;  << q = s-2 >>                  <<850806>>19770000
      delta'q:=core(hold'adr);                                <<850806>>19775000
      if <> then return;                                      <<850806>>19780000
      hold'dq:=delta'q;  offset:=qreg;                        <<850830>>19785000
      hold's:=integer(hold'off);                              <<850806>>19790000
      hold'qi:=qinit'adr - 1;                                 <<850806>>19795000
    end else begin                                            <<850806>>19800000
    <<check for valid stack by stepping thru>>                   <<nsf>>19805000
    hold'off:=hold'off+offset;               <<seg rel offset>>  <<nsf>>19810000
    delta'q:=core(hold'adr);                <<seg rel delta q>>  <<nsf>>19815000
    if <> then return;                                        <<850806>>19820000
    hold'dq:=delta'q;                  <<temp copy of delta q>>  <<nsf>>19825000
    hold's:=integer(offset);                 <<temp copy of s>>  <<nsf>>19830000
    hold'qi:=qinitl;                                          <<850806>>19835000
    end;                                                      <<850806>>19840000
                                                                 <<nsf>>19845000
    while hold's>logical(hold'qi) do begin <<while ok >>      <<850806>>19850000
          if ctrly then <<escape hatch>>                         <<nsf>>19855000
             begin                                               <<nsf>>19860000
             move buf:=" <CONTROL-Y>";                           <<nsf>>19865000
             write'rec(f'num,buf,-12,%60);                              19870000
             return;                                             <<nsf>>19875000
             end;                                                <<nsf>>19880000
          hold's:=hold's-hold'dq;    <<set to previous marker>>  <<nsf>>19885000
          hold'off:=hold'off-logical(hold'dq);                   <<nsf>>19890000
          hold'dq:=core(hold'adr);             <<read delta q>>  <<nsf>>19895000
          hold'dp:=core(hold'adr-2d);                         <<850806>>19900000
          if curprocstk and new'firmware and                  <<850806>>19905000
            hold'dp = %40000 and (hold's-hold'dq) = qinit'adr <<850806>>19910000
            then go good'enough;                              <<850806>>19915000
          if hold'dq=0 and hold's<>logical(hold'qi) then begin<<850806>>19920000
             printerror(35);  <<invalid stack; delta q = 0>>     <<nsf>>19925000
             return;                                             <<nsf>>19930000
             end;                                                <<nsf>>19935000
          end;                                                   <<nsf>>19940000
                                                                 <<nsf>>19945000
    if hold's<>logical(hold'qi) then begin<<if not at morgue>><<850806>>19950000
       printerror(20);                                           <<nsf>>19955000
       return;                                                   <<nsf>>19960000
       end;                                                      <<nsf>>19965000
    good'enough:                                              <<850806>>19970000
    if vm'inuse and adr >= vm'min then                                  19975000
      begin                                                             19980000
      move bufb := "** VIRTUAL **";                                     19985000
      write'rec(f'num,buf,-13,s'space);                                 19990000
      move bufb := "DSEG REL ADDR  ";                                   19995000
      end                                                               20000000
    else                                                                20005000
      move bufb := "BANK    ADDRESS";                                   20010000
    move bufb(15) := "   X     DELTA P STATUS  DELTA Q SEGMENT";        20015000
                                                                 <<nsf>>20020000
    write'rec(f'num,buf,-55,s'space);                                   20025000
    if <> then quit (21);                                        <<nsf>>20030000
    write'rec(f'num,buf,0,s'space);                                     20035000
    if <> then quit(22);                                         <<nsf>>20040000
                                                                 <<nsf>>20045000
      <<re initialize>>                                          <<nsf>>20050000
                                                                 <<nsf>>20055000
    if curprocstk and zbankreg = 0 and sreg > core(5d) and    <<850806>>20060000
      sreg < core(6d) then begin << on ics at time of dump >> <<850806>>20065000
      hold'bnk:=core(double(core(5d))-5d);                    <<850806>>20070000
      hold'off:=core(double(core(5d))-6d) +                   <<850806>>20075000
                core(double(core(5d))-4d);                    <<850806>>20080000
      hold'off:=hold'off - 2;  << q = s-2 >>                  <<850806>>20085000
      delta'q:=core(hold'adr);                                <<850806>>20090000
      if <> then return;                                      <<850806>>20095000
      hold'dq:=delta'q;  offset:=qreg;                        <<850830>>20100000
      hold's:=integer(hold'off);                              <<850806>>20105000
      hold'qi:=qinit'adr - 1;                                 <<850806>>20110000
    end else begin                                            <<850806>>20115000
    hold'adr:=adr;                            <<reset to pcbx>>  <<nsf>>20120000
    hold's:=integer(offset);           <<reset to last marker>>  <<nsf>>20125000
    hold'off:=hold'off+logical(hold's);  <<set to last marker>>  <<nsf>>20130000
    end;                                                      <<850806>>20135000
                                                                 <<nsf>>20140000
       <<begin outer loop to print all markers>>                 <<nsf>>20145000
                                                                 <<nsf>>20150000
    while hold's > logical(hold'qi) do begin                  <<850806>>20155000
          if ctrly then return;                                  <<nsf>>20160000
          delta'q:=core(hold'adr);              <<get delta q>>  <<nsf>>20165000
          hold'off:=                                             <<nsf>>20170000
             hold'off-logical(stk'words-1);      <<abs offset>>  <<nsf>>20175000
                                                                 <<nsf>>20180000
          getcore(hold'adr,stk'words,stk'mrkr); <<read marker>>  <<nsf>>20185000
                                                                 <<nsf>>20190000
          buf(0):="  ";                                          <<nsf>>20195000
          move buf(1):=buf(0),(39);            <<clear buffer>>  <<nsf>>20200000
                                                                 <<nsf>>20205000
          if vm'inuse and adr >= vm'min  then                           20210000
            ascii(logical(hold'adr-dseg'base),octal,bufb)               20215000
          else                                                          20220000
            begin                                                       20225000
          ascii(hold'bnk,octal,bufb);                            <<nsf>>20230000
                                                                 <<nsf>>20235000
          ascii(hold'off,octal,bufb(8));       <<load offset>>   <<nsf>>20240000
            end;                                                        20245000
              <<begin inner loop to print each marker>>          <<nsf>>20250000
                                                                 <<nsf>>20255000
          count:=1;                            << initialize>>   <<nsf>>20260000
          J:=0;                                <<     "     >>   <<NSF>>20265000
          I:=16;                               <<     "     >>   <<NSF>>20270000
                                                                 <<nsf>>20275000
          while count <= stk'words do begin                      <<nsf>>20280000
                 if ctrly then return;                           <<nsf>>20285000
                 ascii(stk'mrkr(j),octal,bufb(i));               <<nsf>>20290000
                 count:=count+1;           <<increment count>>   <<nsf>>20295000
                 j:=j+1;          <<increment stk'mrkr indes>>   <<nsf>>20300000
                 i:=i+8;                   <<increment col #>>   <<nsf>>20305000
                 end;                                            <<nsf>>20310000
                                                                 <<nsf>>20315000
          if new'firmware <> 0 then begin                        <<nsf>>20320000
            if phys'mapped=0 then move bufb(i):="USER SEGMENT"   <<nsf>>20325000
            else begin                                           <<nsf>>20330000
                                                                        20335000
              name'cst(cst'seg,buf(i/2));                               20340000
                                                                        20345000
            end;                                                 <<nsf>>20350000
          end else begin                                         <<nsf>>20355000
            if cst'seg > %300 then move bufb(i):="USER SEGMENT"  <<nsf>>20360000
            else begin                                           <<nsf>>20365000
                                                                        20370000
              name'cst(cst'seg,buf(i/2));                               20375000
                                                                        20380000
            end;                                                 <<nsf>>20385000
          end;                                                   <<nsf>>20390000
          hold's:=hold's-delta'q;         <<decrement hold's>>   <<nsf>>20395000
          hold'off:=hold'off+logical(stk'words-1);            <<850806>>20400000
          if curprocstk and new'firmware and core(hold'adr-2d)<<850806>>20405000
             = %40000 then hold's:=0; <<gets us out of loop>> <<850806>>20410000
          hold'off:=hold'off - delta'q;                       <<850806>>20415000
                                                                 <<nsf>>20420000
          write'rec(f'num,buf,-79,s'space);      <<print buffer>>       20425000
          if <> then quit(23);                                   <<nsf>>20430000
          end;                                                   <<nsf>>20435000
  end;  <<prt'stk5>>                                             <<nsf>>20440000
$page "                     PROCEDURE PRT'STK4"                         20445000
$control segment=idat4a                                                 20450000
<<**********************************************>>                      20455000
<<  prt'stk4                                    >>                      20460000
<<---------------------------------------------->>                      20465000
<< prints formatted stack from q initial on     >>                      20470000
<<**********************************************>>                      20475000
procedure prt'stk4(f'num,adr,s,qinitl,dstnum);                <<860505>>20480000
  value f'num,                             <<file to write on>>         20485000
        adr,                                      <<base'addr>>         20490000
        s,                                <<seg rel s pointer>>         20495000
        qinitl,          <<seg rel pointer  to beg. of stack>><<860505>>20500000
        dstnum;          << dst # to format >>                <<860505>>20505000
                                                              <<860505>>20510000
                                                                        20515000
  integer f'num,                                                        20520000
          s,                                                            20525000
          qinitl,                                             <<860505>>20530000
          dstnum;                                             <<860505>>20535000
                                                                        20540000
  double adr;                                                           20545000
                                                                        20550000
  << this procedure assumes the exitence of the >>                      20555000
  << procedures "CORE", "PRINTERROR", and       >>                      20560000
  << "GETCORE"                                  >>                      20565000
                                                                        20570000
                                                                        20575000
  begin                                                                 20580000
    integer count,                <<counter for stack marker>>          20585000
            j,                          <<index for stk'mrkr>>          20590000
            i;                     <<col # to place info. in>>          20595000
    logical delta'q,         <<# of words to previous marker>>          20600000
            hold'dq,               <<scratch copy of delta'q>>          20605000
            hold's;                      <<scratch copy of s>>          20610000
    define cst'seg = stk'mrkr(j-2).(8:8)#;                       <<nsf>>20615000
                                                                        20620000
    double hold'adr;                   <<scratch copy of adr>>          20625000
                                                                        20630000
                                                                        20635000
    logical hold'bnk=hold'adr,                                          20640000
            hold'off=hold'adr+1;                                        20645000
    logical bnk=adr,                                                    20650000
            off=adr+1;                                                  20655000
    logical offset;                                                     20660000
    logical curprocstk;                                                 20665000
    double dstbase,                                                     20670000
           dstbaseoffset;                                               20675000
    integer stkdst;                                                     20680000
                                                                        20685000
    array buf(0:39),                            <<i/o buffer>>          20690000
          stk'mrkr(0:3);                <<holds stack marker>>          20695000
                                                                        20700000
    byte array bufb(*)=buf;                                             20705000
                                                                        20710000
    equate octal=8,                            <<octal value>>          20715000
           s'space=%40,                       <<single space>>          20720000
           stk'words=4;         <<# of words in stack marker>>          20725000
                                                                        20730000
    hold'adr:=adr;                              <<initialize>>          20735000
                                                                        20740000
    <<if this is current stack, we must treat it differently>>          20745000
    dstbase:=double(core(2d));                                          20750000
    stkdst:=core(double(core(4d)+3)).(1:10);                            20755000
    if not(validdst(dstnum)) and core(4d)<>0  then begin      <<851230>>20760000
      printerror(71);                                         <<851230>>20765000
      return;                                                 <<851230>>20770000
    end;                                                      <<851230>>20775000
    dstbaseoffset:=double(stkdst*4)+dstbase;                            20780000
    curprocstk:=if core(dstbaseoffset+2d)=bnk and                       20785000
                   core(dstbaseoffset+3d)=off then                      20790000
                   true else false;                                     20795000
    offset := logical(s);                                               20800000
    if (core(4d) <> 0 ) and curprocstk then                             20805000
       begin                                                            20810000
       move buf:="* CURRENT PROCESS *";                                 20815000
       write'rec(f'num,buf,-19,s'space);                                20820000
       if <> then quit(21);                                             20825000
       offset := qreg - off;                                            20830000
       end;                                                             20835000
                                                                        20840000
    <<check for valid stack by stepping thru>>                          20845000
    hold'off:=hold'off+offset;               <<seg rel offset>>         20850000
    delta'q:=core(hold'adr);                <<seg rel delta q>>         20855000
    hold'dq:=delta'q;                  <<temp copy of delta q>>         20860000
    hold's:=integer(offset);                 <<temp copy of s>>         20865000
                                                                        20870000
    while hold's > logical(qinitl) do begin <<while we have 'em>>       20875000
          if ctrly then <<escape hatch>>                                20880000
             begin                                                      20885000
             move buf:=" <CONTROL-Y>";                                  20890000
             write'rec(f'num,buf,-12,%60);                              20895000
             return;                                                    20900000
             end;                                                       20905000
          hold's:=hold's-hold'dq;    <<set to previous marker>>         20910000
          hold'off:=hold'off-logical(hold'dq);                          20915000
          hold'dq:=core(hold'adr);             <<read delta q>>         20920000
          if hold'dq=0 and hold's <> logical(qinitl) then begin         20925000
             printerror(35);  <<invalid stack; delta q = 0>>            20930000
             return;                                                    20935000
             end;                                                       20940000
          end;                                                          20945000
                                                                        20950000
    if hold's <> logical(qinitl) then begin <<if not at morgue>>        20955000
       printerror(20);                                                  20960000
       return;                                                          20965000
       end;                                                             20970000
                                                                        20975000
    move buf:=                                                          20980000
    "BANK    ADDRESS   X     DELTA P STATUS  DELTA Q SEGMENT";          20985000
                                                                        20990000
    write'rec(f'num,buf,-55,s'space);                                   20995000
    if <> then quit (21);                                               21000000
    write'rec(f'num,buf,0,s'space);                                     21005000
    if <> then quit(22);                                                21010000
                                                                        21015000
      <<re initialize>>                                                 21020000
                                                                        21025000
    hold'adr:=adr;                            <<reset to pcbx>>         21030000
    hold's:=integer(offset);           <<reset to last marker>>         21035000
    hold'off:=hold'off+logical(hold's);  <<set to last marker>>         21040000
                                                                        21045000
       <<begin outer loop to print all markers>>                        21050000
                                                                        21055000
    while hold's > logical(qinitl) do begin                             21060000
          if ctrly then return;                                         21065000
          delta'q:=core(hold'adr);              <<get delta q>>         21070000
          hold'off:=                                                    21075000
             hold'off-logical(stk'words-1);      <<abs offset>>         21080000
                                                                        21085000
          getcore(hold'adr,stk'words,stk'mrkr); <<read marker>>         21090000
                                                                        21095000
          buf(0):="  ";                                                 21100000
          move buf(1):=buf(0),(39);            <<clear buffer>>         21105000
                                                                        21110000
          ascii(hold'bnk,octal,bufb);                                   21115000
                                                                        21120000
          ascii(hold'off,octal,bufb(8));       <<load offset>>          21125000
              <<begin inner loop to print each marker>>                 21130000
                                                                        21135000
          count:=1;                            << initialize>>          21140000
          J:=0;                                <<     "     >>          21145000
          I:=16;                               <<     "     >>          21150000
                                                                        21155000
          while count <= stk'words do begin                             21160000
                 if ctrly then return;                                  21165000
                 ascii(stk'mrkr(j),octal,bufb(i));                      21170000
                 count:=count+1;           <<increment count>>          21175000
                 j:=j+1;          <<increment stk'mrkr indes>>          21180000
                 i:=i+8;                   <<increment col #>>          21185000
                 end;                                                   21190000
                                                                        21195000
          if cst'seg > %300 then move bufb(i):="USER SEGMENT"    <<nsf>>21200000
          else begin                                             <<nsf>>21205000
                                                                        21210000
            name'cst(cst'seg,buf(i/2));                                 21215000
                                                                        21220000
          end;                                                   <<nsf>>21225000
          hold's:=hold's-delta'q;         <<decrement hold's>>          21230000
          hold'off:=off+logical(hold's); <<abs end of marker>>          21235000
                                                                        21240000
          write'rec(f'num,buf,-79,s'space);      <<print buffer>>       21245000
          if <> then quit(23);                                          21250000
          end;                                                          21255000
  end;  <<prt'stk4>>                                                    21260000
$page "                    PROCEDURE PROCDEAD"                          21265000
<<**********************************************>>                      21270000
<<  procdead                                    >>                      21275000
<<---------------------------------------------->>                      21280000
<< returns true if pin is dead                  >>                      21285000
<<**********************************************>>                      21290000
  logical procedure procdead(pnum);                                     21295000
                                                                        21300000
  value pnum;  <<requested pin>>                                        21305000
  logical pnum;                                                         21310000
                                                                        21315000
  << this procedure assumes the existence of the >>                     21320000
  << procedure "CORE"                            >>                     21325000
                                                                        21330000
                                                                        21335000
    begin                                                               21340000
    double base,pcbbase,offset;                                  <<nsf>>21345000
    integer pcbentsize,flagoffset;                               <<nsf>>21350000
    pcbbase:=getdstaddr(3);                                      <<nsf>>21355000
    pcbentsize:=%20+(mpeversion-4)*5;                            <<nsf>>21360000
    flagoffset:=15+(mpeversion-4)*6;                             <<nsf>>21365000
    base:=pcbbase+double(pnum*logical(pcbentsize));              <<nsf>>21370000
                                                                        21375000
    offset:=base+double(flagoffset);  <<pcb entry flag addr>>    <<nsf>>21380000
                                                                        21385000
    <<check if process is dead. the last>>                              21390000
    <<word of its pcb entry will be set >>                              21395000
    <<to %177777 (-1) if it is.         >>                              21400000
                                                                        21405000
    if integer(core(offset))=%177777                             <<nsf>>21410000
      then procdead:=true                                               21415000
      else procdead:=false;                                             21420000
                                                                        21425000
    end;  <<procdead>>                                                  21430000
$page"               PROCEDURE NAME'IT"                                 21435000
<<*********************************************>>                       21440000
<<  name'it                                    >>                       21445000
<<--------------------------------------------->>                       21450000
<< names pin if associated to a system name    >>                       21455000
<<*********************************************>>                       21460000
  procedure name'it(pnum,buffer);                                       21465000
                                                                        21470000
  value pnum;  <<requested pin>>                                        21475000
  logical pnum;                                                         21480000
byte array buffer;                                                      21485000
                                                                        21490000
  << this procedure assumes the existence of the >>                     21495000
  << procedure "CORE"                            >>                     21500000
                                                                        21505000
                                                                        21510000
    begin                                                               21515000
                                                                        21520000
  logical array pinnum(0:11);  <<array containing    >>                 21525000
                               <<the pin's associated>>                 21530000
                               <<to the system names >>                 21535000
                                                                        21540000
    byte array sysname(0:6*12-1)=pb:= <<array of    >>                  21545000
                                      <<system names>>                  21550000
      "PROGEN",                                                         21555000
      "      ",                                                         21560000
      "UCOP  ",                                                         21565000
      "PFAIL ",                                                         21570000
      "DEVREC",                                                         21575000
      "DRUSG ",                                                         21580000
      "STMSG ",                                                         21585000
      "LOG   ",                                                         21590000
      "LOAD  ",                                                         21595000
      "IOMESS",                                                         21600000
      "SYSIO ",                                                         21605000
      "MEMLOG";                                                         21610000
                                                                        21615000
                                                                        21620000
    integer index:=0;                                                   21625000
    logical offset;                                                     21630000
    integer pcbentsize;                                          <<nsf>>21635000
                                                                        21640000
    define name'addr=%1141#; <<addr of table base>>                     21645000
                                                                        21650000
    pcbentsize:=%20+(mpeversion-4)*5;                            <<nsf>>21655000
                                                                        21660000
    <<get the pin's from the table>>                                    21665000
                                                                        21670000
    while index <= 11 do                                                21675000
      begin                                                             21680000
      offset:=logical(name'addr+index); <<offset=entry in table>>       21685000
      pinnum(index):=core(double(offset))/logical(pcbentsize);   <<nsf>>21690000
      index:=index+1;                                                   21695000
      end;                                                              21700000
                                                                        21705000
    index:=0;                                                           21710000
                                                                        21715000
    <<check if the pin has >>                                           21720000
    <<a system-defined name>>                                           21725000
                                                                        21730000
    while index<=11 do                                                  21735000
      begin                                                             21740000
      if pnum=pinnum(index) then                                        21745000
        begin                                                           21750000
        <<if the pin is a match,>>                                      21755000
        <<assign it a name      >>                                      21760000
        move buffer:=sysname(index*6),(6);                              21765000
        index:=index+12;                                                21770000
        end;                                                            21775000
      index:=index+1;                                                   21780000
      end;                                                              21785000
    end;  <<name'it>>                                                   21790000
$page"               PROCEDURE CURRENT"                                 21795000
<<*********************************************>>                       21800000
<<  current                                    >>                       21805000
<<--------------------------------------------->>                       21810000
<< returns true if pin is current              >>                       21815000
<<*********************************************>>                       21820000
                                                                        21825000
  logical procedure current(pin);                                       21830000
                                                                        21835000
  value pin;                                                            21840000
  logical pin;   <<process id number>>                                  21845000
                                                                        21850000
  << this procedure assumes the existence of the >>                     21855000
  << procedure "CORE"                            >>                     21860000
                                                                        21865000
    begin                                                               21870000
                                                                        21875000
    double  curpcb;  <<addr of current pcb entry>>               <<nsf>>21880000
    double  pcbbase,pcbaddr;                                     <<nsf>>21885000
    integer pcbentsize;                                          <<nsf>>21890000
                                                                        21895000
    curpcb:=double(core(4d));  <<get cpcb from core>>            <<nsf>>21900000
                                                                        21905000
    pcbaddr:=double(%1000*(mpeversion-4))+3d;                    <<nsf>>21910000
    pcbentsize:=%20+(mpeversion-4)*5;                            <<nsf>>21915000
    pcbbase:=double(core(pcbaddr)+logical((mpeversion-4)*%1000));<<nsf>>21920000
                                                                        21925000
  <<check if pin is current>>                                           21930000
  if mpeversion = 4 then begin                                   <<nsf>>21935000
    if (curpcb-pcbbase)/double(pcbentsize)=double(pin)           <<nsf>>21940000
      then current:=true                                                21945000
      else current:=false; end                                          21950000
  else begin                                                     <<nsf>>21955000
    if curpcb/double(pcbentsize)=double(pin)                     <<nsf>>21960000
      then current:=true                                         <<nsf>>21965000
      else current:=false;                                       <<nsf>>21970000
    end;                                                         <<nsf>>21975000
                                                                        21980000
  end;   <<current>>                                                    21985000
$page"               PROCEDURE FMTPCBENTRY4"                            21990000
<<*********************************************>>                       21995000
<<  fmtpcbentry4                               >>                       22000000
<<--------------------------------------------->>                       22005000
<< formats and prints pcb entry                >>                       22010000
<<*********************************************>>                       22015000
                                                                        22020000
procedure fmtpcbentry4(flnum,pin,pcbentry);                             22025000
                                                                        22030000
value flnum, <<file no of output file>>                                 22035000
      pin;   <<process id number>>                                      22040000
integer flnum;      <<file number>>                                     22045000
logical pin;       <<process id number>>                                22050000
                                                                        22055000
logical array pcbentry;   <<pcb entry>>                                 22060000
                                                                        22065000
  << this procedure assumes the existence of the >>                     22070000
  << procedure "PROCDEAD"                        >>                     22075000
                                                                        22080000
  begin                                                                 22085000
  integer lnum,     <<line count>>                                      22090000
          num,      <<integer to convert to ascii>>                     22095000
          len,      <<length of ascii string>>                          22100000
          count,    <<count for        >>                               22105000
          type;     <<process type>>                                    22110000
                                                                        22115000
  logical dnum;     <<double to convert to ascii>>                      22120000
  logical array ltxt(0:39);                                             22125000
  byte array text(*)=ltxt;                                              22130000
                                                                        22135000
  byte array btxt(0:5);    <<array for ascii conversions>>              22140000
  byte array dbtxt(0:11); <<arry for double to ascii convert>>          22145000
                                                                        22150000
                                                                        22155000
  define                                                                22160000
                                                                        22165000
    <<process idlentification>>                                         22170000
      ptype=9#,xptype=(6:3)#,                                           22175000
                                                                        22180000
    <<data segmlents>>                                                  22185000
      xds=2#,xxds=(1:10)#,                                              22190000
      absdb=2#,xabsdb=(0:1)#,                                           22195000
      stk=3#,xstk=(1:10)#,                                              22200000
      oval=3#,xoval=(0:1)#,                                             22205000
                                                                        22210000
    <<family info>>                                                     22215000
      fr=5#,xfr=(0:8)#,                                                 22220000
      son=5#,xson=(8:8)#,                                               22225000
      br=6#,xbr=(0:8)#,                                                 22230000
      oa=8#,xoa=(4:2)#,                                                 22235000
                                                                        22240000
    <<wakes and events>>                                                22245000
      wake=4#,event=10#,                                                22250000
      m=(0:1)#,rg=(1:1)#,                                               22255000
      rl=(2:1)#,ma=(3:1)#,                                              22260000
      bio=(4:1)#,io=(5:1)#,                                             22265000
      ucop=(6:1)#,junk=(7:1)#,                                          22270000
      timer=(8:1)#,msg=(9:1)#,                                          22275000
      wson=(10:1)#,fathr=(11:1)#,                                       22280000
      imp=(12:1)#,sir=(13:1)#,                                          22285000
      tmout=(14:1)#,mem=(15:1)#,                                        22290000
                                                                        22295000
    <<resources>>                                                       22300000
      crit=0#,xcrit=(2:1)#,                                             22305000
      hsir=0#,xhsir=(3:1)#,                                             22310000
      sc=3#,xsc=(11:1)#,                                                22315000
      nimp=8#,xnimp=(8:8)#,                                             22320000
      pimp=7#,xpimp=(0:8)#,                                             22325000
                                                                        22330000
    <<miscellaneous>>                                                   22335000
      bms=9#,xbms=(1:2)#,                                               22340000
      ppc=9#,xppc=(3:2)#,                                               22345000
      pcst=11#,xpcst=(0:16)#,                                           22350000
      pxpt=12#,xpxpt=(0:16)#,                                           22355000
      sl=1#,xsl=(0:16)#,                                                22360000
      bplk=7#,xbplk=(8:8)#,                                             22365000
                                                                        22370000
    <<queue links>>                                                     22375000
      nqpn=14#,xnqpn=(0:16)#,                                           22380000
      pqpn=15#,xpqpn=(0:16)#,                                           22385000
                                                                        22390000
                                                                        22395000
    <<pseudo interrupts>>                                               22400000
      psim=8#,xpsim=(0:3)#,                                             22405000
      hk=9#,xhk=(10:1)#,                                                22410000
      sk=9#,xsk=(11:1)#,                                                22415000
      st=9#,xst=(12:1)#,                                                22420000
      hb=9#,xhb=(13:1)#,                                                22425000
      cy=9#,xcy=(14:1)#,                                                22430000
      bk=9#,xbk=(15:1)#,                                                22435000
      ritbk=0#,xritbk=(15:1)#,                                          22440000
      piovr=0#,xpiovr=(4:1)#,                                           22445000
                                                                        22450000
    <<life/death>>                                                      22455000
      live=9#,xlive=(0:1)#,                                             22460000
      dead=8#,xdead=(6:1)#,                                             22465000
      fac=8#,xfac=(7:1)#,                                               22470000
                                                                        22475000
    <<schedule information>>                                            22480000
      pri=13#,xpri=(8:8)#,                                              22485000
      dispq=13#,xdispq=(0:1)#,                                          22490000
      lq=13#,xlq=(1:1)#,                                                22495000
      cq=13#,xcq=(2:1)#,                                                22500000
      dq=13#,xdq=(3:1)#,                                                22505000
      eq=13#,xeq=(4:1)#,                                                22510000
      inter=13#,xinter=(5:1)#,                                          22515000
      corer=13#,xcorer=(6:1)#,                                          22520000
      hipri=0#,xhipri=(13:1)#,                                          22525000
      usedq=0#,xusedq=(12:1)#,                                          22530000
      trw=0#,xtrw=(11:1)#,                                              22535000
      sw=0#,xsw=(10:1)#,                                                22540000
      lw=0#,xlw=(9:1)#,                                                 22545000
      mp=0#,xmp=(8:1)#,                                                 22550000
      pc=0#,xpc=(7:1)#,                                                 22555000
      ipexp=0#,xipexp=(6:1)#,                                           22560000
      hspri=0#,xhspri=(5:1)#,                                           22565000
      sar=0#,xsar=(0:1)#,                                               22570000
      sov=9#,xsov=(5:1)#;                                               22575000
                                                                        22580000
                                                                        22585000
<<************************************************>>                    22590000
<<checkbit                                        >>                    22595000
<<------------------------------------------------>>                    22600000
<<this subroutine checks if the bit sent via the  >>                    22605000
<<bit parameter is set or not. if it is, then the >>                    22610000
<<string constant, "YES", is inserted into the    >>                    22615000
<<output buffer at the column specified by col.   >>                    22620000
<<************************************************>>                    22625000
                                                                        22630000
                                                                        22635000
  subroutine ckbit(bit,col);                                            22640000
                                                                        22645000
  value col,bit;                                                        22650000
  integer col;  <<col in which to insert yes>>                          22655000
  logical bit;  <<bit to be tested>>                                    22660000
                                                                        22665000
                                                                        22670000
    begin                                                               22675000
    if bit then move text(col):="YES";                                  22680000
    end;                                                                22685000
                                                                        22690000
                                                                        22695000
                                                                        22700000
      lnum:=1;   <<initialize the line count>>                          22705000
      while lnum<=23 do   <<loop thru the format lines>>                22710000
        begin                                                           22715000
        text:=" "; move text(1):=text,(78);                             22720000
        case lnum of  <<branch to appropriate >>                        22725000
          begin         <<format line.          >>                      22730000
          ;   <<0 case>>                                                22735000
            begin  <<line 1>>                                           22740000
            move text(4):="PROCESS ID";                                 22745000
            if procdead(pin) <<call procdead for test>>                 22750000
              then move text(29):="****NOT IN USE****";                 22755000
            move text(65):="SCHEDULE INFO";                             22760000
            end;                                                        22765000
                                                                        22770000
            begin  <<line 2>>                                           22775000
            move text(2):="--------------";                             22780000
            move text(39):="RESOURCES";                                 22785000
            move text(65):="-------------";                             22790000
            end;                                                        22795000
                                                                        22800000
            begin  <<line 3>>                                           22805000
            move text(4):="PIN: %";                                     22810000
            len:=ascii(pin,8,btxt); <<conversion>>                      22815000
            move text(11):=btxt(6-len),(len); <<insert pin>>            22820000
            move text(24):="WAKE  EVENT";                               22825000
            move text(37):="-------------";                             22830000
            move text(52):="PSEUDO INT";                                22835000
            move text(68):="PRI:";                                      22840000
            num:=pcbentry(pri).xpri; <<get prio>>                       22845000
            len:=ascii(num,8,btxt); <<convert prio>>                    22850000
            move text(73):=btxt(6-len),(len); <<insert prio>>           22855000
            end;                                                        22860000
                                                                        22865000
                                                                        22870000
            begin  <<line 4>>                                           22875000
            if current(pin) <<call current for test>>                   22880000
              then move text(4):="(CURRENT)" <<insert if true>>         22885000
              else                                                      22890000
            move text(24):="MASKS FLAGS";                               22895000
            move text(41):="CRIT:";                                     22900000
            ckbit(pcbentry(crit).xcrit,47); <<test if critcal>>         22905000
            move text(52):="-----------";                               22910000
            end;                                                        22915000
                                                                        22920000
            begin  <<line 5>>                                           22925000
            move text(2):="PTYPE:";                                     22930000
            num:=pcbentry(ptype).xptype;  <<get proc type #>>           22935000
            type:=num;                                                  22940000
            case num of <<assign process type>>                         22945000
              begin                                                     22950000
              move text(9):="USER";  <<ptype=0>>                        22955000
              move text(9):="USONM"; <<ptype=1>>                        22960000
              move text(9):="UMAIN"; <<ptype=2>>                        22965000
              move text(9):="UMTSK"; <<ptype=3>>                        22970000
              move text(9):="SYST";  <<ptype=4>>                        22975000
              move text(9):="SYS";   <<ptype=5>>                        22980000
              move text(9):="SYSTU"; <<ptype=6>>                        22985000
              ;                      <<ptype=7>>                        22990000
              end;                                                      22995000
            move text(24):="----- -----";                               23000000
            move text(41):="HSIR:";                                     23005000
            ckbit(pcbentry(hsir).xhsir,47); <<test hsir>>               23010000
            move text(53):="PSIM:";                                     23015000
            num:=pcbentry(psim).xpsim; <<get pseudo int mode>>          23020000
            case num of  <<test psim>>                                  23025000
              begin                                                     23030000
              ;   <<num=0>>                                             23035000
              move text(59):="HK";  <<hard kill>>                       23040000
              move text(59):="SK";  <<soft kill>>                       23045000
              move text(59):="ST";  <<stop>>                            23050000
              move text(59):="HB";  <<hibernate>>                       23055000
              move text(59):="CY";  <<escape>>                          23060000
              move text(59):="BK";  <<break>>                           23065000
              move text(59):="NORM";  <<normal>>                        23070000
              end;                                                      23075000
            move text(66):="DISPQ:";                                    23080000
            ckbit(pcbentry(dispq).xdispq,73); <<test dispq>>            23085000
             end;                                                       23090000
                                                                        23095000
                                                                        23100000
            begin  <<line 6>>                                           23105000
            move text(3):="NAME:";                                      23110000
            name'it(pin,text(9)); <<name the process>>                  23115000
            move text(22):="M:";                                        23120000
            ckbit(pcbentry(wake).m,25); <<test m wake flag>>            23125000
            ckbit(pcbentry(event).m,31); <<test m event flag>>          23130000
            move text(43):="SC:";                                       23135000
            ckbit(pcbentry(sc).xsc,47); <<test sc flag>>                23140000
            move text(55):="HK:";                                       23145000
            ckbit(pcbentry(hk).xhk,59); <<test hk flag>>                23150000
            move text(69):="LQ:";                                       23155000
            ckbit(pcbentry(lq).xlq,73); <<test lq flag>>                23160000
            end;                                                        23165000
                                                                        23170000
            begin  <<line 7>>                                           23175000
            move text(21):="RG:";                                       23180000
            ckbit(pcbentry(wake).rg,25); <<test rg wake flag>>          23185000
            ckbit(pcbentry(event).rg,31); <<test rg event>>             23190000
            move text(37):="NEXT IMP:";                                 23195000
            num:=pcbentry(nimp).xnimp; <<get nimp 4>>                   23200000
            if num <> 0 then  <<check for next imp proc>>               23205000
              begin                                                     23210000
              len:=ascii(num,8,btxt); <<convert nimp>>                  23215000
              move text(47):=btxt(6-len),(len); <<insert nimp>>         23220000
              end;                                                      23225000
            move text(55):="SK:";                                       23230000
            ckbit(pcbentry(sk).xsk,59);  <<test sk flag>>               23235000
            move text(69):="CQ:";                                       23240000
            ckbit(pcbentry(cq).xcq,73);  <<test cq flag>>               23245000
            end;                                                        23250000
                                                                        23255000
                                                                        23260000
            begin  <<line 8>>                                           23265000
            move text(21):="RL:";                                       23270000
            ckbit(pcbentry(wake).rl,25); <<test rl wake flag>>          23275000
            ckbit(pcbentry(event).rl,31); <<test rl event>>             23280000
            move text(37):="PREV IMP:";                                 23285000
            num:=pcbentry(pimp).xpimp; <<get pimp>>                     23290000
            if num <> 0 then <<check for prev imp proc>>                23295000
              begin                                                     23300000
              len:=ascii(num,8,btxt); <<convert pimp>>                  23305000
              move text(47):=btxt(6-len),(len); <<insert pimp>>         23310000
              end;                                                      23315000
            move text(55):="ST:";                                       23320000
            ckbit(pcbentry(st).xst,59);  <<test st flag>>               23325000
            move text(69):="DQ:";                                       23330000
            ckbit(pcbentry(dq).xdq,73);  <<test dq flag>>               23335000
            end;                                                        23340000
                                                                        23345000
            begin  <<line 9>>                                           23350000
            move text(2):="DATA SEGMENTS";                              23355000
            move text(21):="MA:";                                       23360000
            ckbit(pcbentry(wake).ma,25); <<test ma wake flag>>          23365000
            ckbit(pcbentry(event).ma,31); <<test ma event>>             23370000
            move text(55):="HB:";                                       23375000
            ckbit(pcbentry(hb).xhb,59); <<test hb flag>>                23380000
            move text(69):="EQ:";                                       23385000
            ckbit(pcbentry(eq).xeq,73); <<test eq flag>>                23390000
            end;                                                        23395000
                                                                        23400000
            begin  <<line 10>>                                          23405000
            move text(2):="--------------";                             23410000
            move text(20):="BIO:";                                      23415000
            ckbit(pcbentry(wake).bio,25); <<test bio wake>>             23420000
            ckbit(pcbentry(event).bio,31); <<test bio event>>           23425000
            move text(37):="MISCELLANEOUS";                             23430000
            move text(55):="CY:";                                       23435000
            ckbit(pcbentry(cy).xcy,59); <<test cy flag>>                23440000
            move text(66):="INTER:";                                    23445000
            ckbit(pcbentry(inter).xinter,73);  <<test inter>>           23450000
            end;                                                        23455000
                                                                        23460000
                                                                        23465000
            begin  <<line 11>>                                          23470000
            move text(6):="XDS:";                                       23475000
            num:=pcbentry(xds).xxds; <<get xds>>                        23480000
            if num <> 0 then  <<check for ex data seg>>                 23485000
              begin                                                     23490000
             len:=ascii(num,8,btxt);  <<convert xds>>                   23495000
             move text(11):=btxt(6-len),(len); <<insert xds>>           23500000
              end;                                                      23505000
            move text(21):="IO:";                                       23510000
            ckbit(pcbentry(wake).io,25); <<test io wake flag>>          23515000
            ckbit(pcbentry(event).io,31); <<test io event>>             23520000
            move text(37):="-------------";                             23525000
            move text(55):="BK:";                                       23530000
            ckbit(pcbentry(bk).xbk,59); <<test bk flag>>                23535000
            move text(66):="CORER:";                                    23540000
            ckbit(pcbentry(corer).xcorer,73); <<test corer>>            23545000
            end;                                                        23550000
                                                                        23555000
            begin  <<line 12>>                                          23560000
            move text(3):="ABS DB:";                                    23565000
            ckbit(pcbentry(absdb).xabsdb,11); <<test absdb>>            23570000
            move text(19):="UCOP:";                                     23575000
            ckbit(pcbentry(wake).ucop,25); <<test ucop wake>>           23580000
            ckbit(pcbentry(event).ucop,31); <<test ucop event>>         23585000
            move text(41):="BMS:";                                      23590000
            num:=pcbentry(bms).xbms;  <<get bms>>                       23595000
            case num of <<test bms>>                                    23600000
              begin                                                     23605000
              move text(46):="SNF";  <<sent to fr>>                     23610000
              move text(46):="REF";  <<received from fr>>               23615000
              move text(46):="SNS";  <<sent to son>>                    23620000
              move text(46):="RES";  <<received from son>>              23625000
              end;                                                      23630000
            move text(52):="RITBK:";                                    23635000
            ckbit(pcbentry(ritbk).xritbk,59); <<test ritbk>>            23640000
            end;                                                        23645000
                                                                        23650000
            begin  <<line 13>>                                          23655000
            move text(19):="JUNK:";                                     23660000
            ckbit(pcbentry(wake).junk,25); <<test junk wake>>           23665000
            ckbit(pcbentry(event).junk,31); <<test junk event>>         23670000
            move text(41):="PPC:";                                      23675000
            num:=pcbentry(ppc).xppc; <<get ppc>>                        23680000
            case num of <<test ppc>>                                    23685000
              begin                                                     23690000
              move text(46):="NUL";   <<null>>                          23695000
               move text(46):="STF";   <<son to fr>>                    23700000
               move text(46):="FTS";   <<fr to son>>                    23705000
               move text(46):="BLK";   <<blocked>>                      23710000
               end;                                                     23715000
            move text(52):="PIOVR:";                                    23720000
            ckbit(pcbentry(piovr).xpiovr,59); <<test piovr>>            23725000
            move text(66):="HIPRI:";                                    23730000
            ckbit(pcbentry(hipri).xhipri,73);  <<test hipri>>           23735000
            end;                                                        23740000
                                                                        23745000
                                                                        23750000
            begin  <<line 14>>                                          23755000
            move text(4):="STACK:";                                     23760000
            num:=pcbentry(stk).xstk; <<get stk addr>>                   23765000
            if num <> 0 then                                            23770000
              begin                                                     23775000
              len:=ascii(num,8,btxt); <<convert stk addr>>              23780000
              move text(11):=btxt(6-len),(len); <<insert stk addr>>     23785000
              end;                                                      23790000
            move text(18):="TIMER:";                                    23795000
            ckbit(pcbentry(wake).timer,25); <<test timer wake>>         23800000
            ckbit(pcbentry(event).timer,31); <<test tmr event>>         23805000
            move text(40):="PCST:";                                     23810000
            dnum:=pcbentry(pcst); <<get pcst>>                          23815000
            num:=integer(dnum); <<convert pcst to integer>>             23820000
            if num <> 0 then <<check for nonzero pcst>>                 23825000
              begin                                                     23830000
              len:=dascii(double(dnum),8,dbtxt); <<convert>>            23835000
              move text(46):=dbtxt(11-len),(len); <<insert pcst>>       23840000
              end;                                                      23845000
            move text(66):="USEDQ:";                                    23850000
            ckbit(pcbentry(usedq).xusedq,73); <<test usedq>>            23855000
            end;                                                        23860000
                                                                        23865000
            begin  <<line 15>>                                          23870000
            move text(3):="OV ALC:";                                    23875000
            ckbit(pcbentry(oval).xoval,11); <<test oval flag>>          23880000
            move text(20):="MSG:";                                      23885000
            ckbit(pcbentry(wake).msg,25); <<test msg wake>>             23890000
            ckbit(pcbentry(event).msg,31); <<test msg event>>           23895000
            move text(37):="PBX PTR:";                                  23900000
            dnum:=pcbentry(pxpt); <<get pbx ptr>>                       23905000
            num:=integer(dnum); <<convert pbx ptr to integer>>          23910000
            if num <> 0 then <<check for nonzero pbx ptr>>              23915000
              begin                                                     23920000
              len:=dascii(double(dnum),8,dbtxt); <<convert>>            23925000
              move text(46):=dbtxt(11-len),(len); <<insert pbx ptr>>    23930000
              end;                                                      23935000
            move text(68):="TRW:";                                      23940000
            ckbit(pcbentry(trw).xtrw,73); <<test trw flag>>             23945000
            end;                                                        23950000
                                                                        23955000
            begin  <<line 16>>                                          23960000
            move text(20):="SON:";                                      23965000
            ckbit(pcbentry(wake).wson,25); <<test son wake>>            23970000
            ckbit(pcbentry(event).wson,31); <<test son event>>          23975000
            move text(38):="SL PTR:";                                   23980000
            dnum:=pcbentry(sl); <<get sl>>                              23985000
            num:=integer(dnum); <<convert sl to integer>>               23990000
            if num <> 0 then <<check for nonzero sl>>                   23995000
              begin                                                     24000000
              len:=dascii(double(dnum),8,dbtxt); <<convert>>            24005000
              move text(46):=dbtxt(11-len),(len); <<insert sl>>         24010000
              end;                                                      24015000
            move text(69):="SW:";                                       24020000
            ckbit(pcbentry(sw).xsw,73); <<test sw flag>>                24025000
            end;                                                        24030000
                                                                        24035000
            begin  <<line 17>>                                          24040000
            move text(18):="FATHR:";                                    24045000
            ckbit(pcbentry(wake).fathr,25); <<test fr wake>>            24050000
            ckbit(pcbentry(event).fathr,31); <<test fr event>>          24055000
            move text(38):="BPLINK:";                                   24060000
            num:=pcbentry(bplk).xbplk; <<get bk pt link>>               24065000
            if num <> 0 then  <<check for nonzero bplk>>                24070000
              begin                                                     24075000
             len:=ascii(dnum,8,btxt); <<convert to ascii>>              24080000
             move text(46):=btxt(6-len),(len);  <<insert bplk>>         24085000
              end;                                                      24090000
            move text(52):="LIFE/DEATH";                                24095000
            move text(69):="LW:";                                       24100000
            ckbit(pcbentry(lw).xlw,73); <<test lw flag>>                24105000
            end;                                                        24110000
                                                                        24115000
            begin  <<line 18>>                                          24120000
            move text(3):="FAMILY INFO";                                24125000
            move text(20):="IMP:";                                      24130000
            ckbit(pcbentry(wake).imp,25); <<test imp wake>>             24135000
            ckbit(pcbentry(event).imp,31); <<test imp event>>           24140000
            move text(52):="-----------";                               24145000
            move text(69):="MP:";                                       24150000
            ckbit(pcbentry(mp).xmp,73); <<test mp flag>>                24155000
            end;                                                        24160000
                                                                        24165000
            begin <<line 19>>                                           24170000
            move text(2):="--------------";                             24175000
            move text(20):="SIR:";                                      24180000
            ckbit(pcbentry(wake).sir,25); <<test sir wake>>             24185000
            ckbit(pcbentry(event).sir,31); <<test sir event>>           24190000
            move text(38):="QUEUE LINKS";                               24195000
            move text(53):="LIVE:";                                     24200000
            ckbit(pcbentry(live).xlive,59);<<test live flag>>           24205000
            move text(69):="PC:";                                       24210000
            ckbit(pcbentry(pc).xpc,73); <<test pc flag>>                24215000
            end;                                                        24220000
                                                                        24225000
                                                                        24230000
            begin  <<line 20>>                                          24235000
            move text(4):="FATHER:";                                    24240000
            num:=pcbentry(fr).xfr;  <<get father ptr>>                  24245000
            if num <> 0 then                                            24250000
              begin                                                     24255000
              len:=ascii(num,8,btxt); <<convert fr ptr>>                24260000
              move text(12):=btxt(6-len),(len); <<insert father ptr>>   24265000
              end;                                                      24270000
            move text(18):="TMOUT:";                                    24275000
            ckbit(pcbentry(wake).tmout,25); <<test tmout wake>>         24280000
            ckbit(pcbentry(event).tmout,31);<<test tmout evnt>>         24285000
            move text(37):="-------------";                             24290000
            move text(53):="DEAD:";                                     24295000
            ckbit(pcbentry(dead).xdead,59);  <<test dead flag>>         24300000
            move text(66):="IPEXP:";                                    24305000
            ckbit(pcbentry(ipexp).xipexp,73); <<test ipexp>>            24310000
            end;                                                        24315000
                                                                        24320000
            begin  <<line 21>>                                          24325000
            move text(7):="SON:";                                       24330000
            num:=pcbentry(son).xson; <<get son ptr>>                    24335000
            if num <> 0 then  <<check for nonzero son ptr>>             24340000
              begin                                                     24345000
              len:=ascii(num,8,btxt); <<convert son ptr>>               24350000
              move text(12):=btxt(6-len),(len); <<insert son ptr>>      24355000
              end;                                                      24360000
            move text(20):="MEM:";                                      24365000
            ckbit(pcbentry(wake).mem,25); <<test mem wake>>             24370000
            ckbit(pcbentry(event).mem,31); <<test mem event>>           24375000
            move text(37):="NQPIN:";                                    24380000
            dnum:=pcbentry(nqpn); <<get next q pin>>                    24385000
            num:=integer(dnum); <<convert next q pin>>                  24390000
            if (num <> 0) and (num<>-1) then <<ck for next q pin>>      24395000
              begin                                                     24400000
              len:=dascii(double(dnum),8,dbtxt);  <<convert>>           24405000
              move text(44):=dbtxt(11-len),(len); <<insert nqpn>>       24410000
              end;                                                      24415000
            move text(54):="FAC:";                                      24420000
            ckbit(pcbentry(fac).xfac,59); <<test fac flag>>             24425000
            move text(66):="HSPRI:";                                    24430000
            ckbit(pcbentry(hspri).xhspri,73); <<test hspri>>            24435000
            end;                                                        24440000
                                                                        24445000
                                                                        24450000
            begin  <<line 22>>                                          24455000
            move text(3):="BROTHER:";                                   24460000
            num:=pcbentry(br).xbr; <<get br ptr>>                       24465000
            if num <> 0 then <<check for nonzero br ptr>>               24470000
              begin                                                     24475000
             len:=ascii(num,8,btxt);  <<convert br ptr>>                24480000
             move text(12):=btxt(6-len),(len); <<insert br ptr>>        24485000
              end;                                                      24490000
            move text(37):="PQPIN:";                                    24495000
            dnum:=pcbentry(pqpn); <<get prev q pin>>                    24500000
            num:=integer(dnum); <<convert pqpn to integer>>             24505000
            if (num<>0) and (num<>-1) then <<ck for valid pqpn>>        24510000
              begin                                                     24515000
             len:=dascii(double(dnum),8,dbtxt); <<convert>>             24520000
             move text(44):=dbtxt(11-len),(len); <<insert pqpn>>        24525000
              end;                                                      24530000
            move text(68):="SAR:";                                      24535000
            ckbit(pcbentry(sar).xsar,73); <<test sar flag>>             24540000
            end;                                                        24545000
                                                                        24550000
                                                                        24555000
            begin  <<line 23>>                                          24560000
            move text(8):="OA:";                                        24565000
            num:=pcbentry(oa).xoa; <<test oa flag>>                     24570000
            case num of                                                 24575000
              begin                                                     24580000
              ;        << other source>>                                24585000
              move text(12):="F";  <<father>>                           24590000
              move text(12):="S";  <<son>>                              24595000
              move text(12):="R";  <<rit>>                              24600000
              end;                                                      24605000
            move text(68):="SOV:";                                      24610000
            ckbit(pcbentry(sov).xsov,73);                               24615000
            end;                                                        24620000
          end;  <<case statement>>                                      24625000
                                                                        24630000
        write'rec(flnum,ltxt,-79,0);  <<print out formated line>>       24635000
                                                                        24640000
        lnum:=lnum+1;  <<increment line count>>                         24645000
        end; <<while stmt>>                                             24650000
    end;  <<fmtpcbentry4>>                                              24655000
$page "                PROCEDURE FMTPCBENTRY5"                          24660000
$control segment=idat5                                                  24665000
<<*********************************************>>                <<nsf>>24670000
<<  fmtpcbentry5                               >>                <<nsf>>24675000
<<--------------------------------------------->>                <<nsf>>24680000
<< formats and prints pcb entry                >>                <<nsf>>24685000
<<*********************************************>>                <<nsf>>24690000
                                                                 <<nsf>>24695000
procedure fmtpcbentry5(flnum,pin,pcbentry);                      <<nsf>>24700000
                                                                 <<nsf>>24705000
value flnum, <<file no of output file>>                          <<nsf>>24710000
      pin;   <<process id number>>                               <<nsf>>24715000
integer flnum;      <<file number>>                              <<nsf>>24720000
logical pin;       <<process id number>>                         <<nsf>>24725000
                                                                 <<nsf>>24730000
logical array pcbentry;   <<pcb entry>>                          <<nsf>>24735000
                                                                 <<nsf>>24740000
  << this procedure assumes the existence of the >>              <<nsf>>24745000
  << procedure "PROCDEAD"                        >>              <<nsf>>24750000
                                                                 <<nsf>>24755000
  begin                                                          <<nsf>>24760000
  integer lnum,     <<line count>>                               <<nsf>>24765000
          num,      <<integer to convert to ascii>>              <<nsf>>24770000
          len,      <<length of ascii string>>                   <<nsf>>24775000
          count,    <<count for        >>                        <<nsf>>24780000
          type;     <<process type>>                             <<nsf>>24785000
                                                                 <<nsf>>24790000
  logical dnum;     <<double to convert to ascii>>               <<nsf>>24795000
  logical array ltxt(0:39);                                      <<nsf>>24800000
  byte array text(*)=ltxt;                                       <<nsf>>24805000
                                                                 <<nsf>>24810000
  byte array btxt(0:5);    <<array for ascii conversions>>       <<nsf>>24815000
  byte array dbtxt(0:11); <<arry for double to ascii convert>>   <<nsf>>24820000
                                                                 <<nsf>>24825000
                                                                 <<nsf>>24830000
  define                                                         <<nsf>>24835000
                                                                 <<nsf>>24840000
    <<process idlentification>>                                  <<nsf>>24845000
      ptype=9#,xptype=(6:3)#,                                    <<nsf>>24850000
                                                                 <<nsf>>24855000
    <<data segmlents>>                                           <<nsf>>24860000
      xds=2#,xxds=(2:14)#,                                       <<nsf>>24865000
      absdb=2#,xabsdb=(0:1)#,                                    <<nsf>>24870000
      stk=3#,xstk=(2:14)#,                                       <<nsf>>24875000
      oval=3#,xoval=(0:1)#,                                      <<nsf>>24880000
                                                                 <<nsf>>24885000
    <<family info>>                                              <<nsf>>24890000
      fr=5#,                                                     <<nsf>>24895000
      son=6#,                                                    <<nsf>>24900000
      br=7#,                                                     <<nsf>>24905000
      oa=8#,xoa=(4:2)#,                                          <<nsf>>24910000
                                                                 <<nsf>>24915000
    <<wakes and events>>                                         <<nsf>>24920000
      wake=4#,event=10#,                                         <<nsf>>24925000
      m=(0:1)#,rg=(1:1)#,                                        <<nsf>>24930000
      rl=(2:1)#,ma=(3:1)#,                                       <<nsf>>24935000
      bio=(4:1)#,io=(5:1)#,                                      <<nsf>>24940000
      ucop=(6:1)#,junk=(7:1)#,                                   <<nsf>>24945000
      timer=(8:1)#,msg=(9:1)#,                                   <<nsf>>24950000
      wson=(10:1)#,fathr=(11:1)#,                                <<nsf>>24955000
      imp=(12:1)#,sir=(13:1)#,                                   <<nsf>>24960000
      tmout=(14:1)#,mem=(15:1)#,                                 <<nsf>>24965000
                                                                 <<nsf>>24970000
    <<resources>>                                                <<nsf>>24975000
      crit=0#,xcrit=(2:1)#,                                      <<nsf>>24980000
      hsir=0#,xhsir=(3:1)#,                                      <<nsf>>24985000
      sc=3#,xsc=(1:1)#,                                          <<nsf>>24990000
      nimp=17#,                                                  <<nsf>>24995000
      pimp=16#,                                                  <<nsf>>25000000
                                                                 <<nsf>>25005000
    <<miscellaneous>>                                            <<nsf>>25010000
      bms=9#,xbms=(1:2)#,                                        <<nsf>>25015000
      ppc=9#,xppc=(3:2)#,                                        <<nsf>>25020000
      pcst=11#,xpcst=(0:32)#,                                    <<nsf>>25025000
        pxpt=14#,xpxpt=(0:16)#,                                         25030000
      sl=1#,                                                     <<nsf>>25035000
      bplk=18#,                                                  <<nsf>>25040000
                                                                 <<nsf>>25045000
    <<queue links>>                                              <<nsf>>25050000
      nqpn=19#,                                                  <<nsf>>25055000
      pqpn=20#,                                                  <<nsf>>25060000
                                                                 <<nsf>>25065000
                                                                 <<nsf>>25070000
    <<pseudo interrupts>>                                        <<nsf>>25075000
      psim=8#,xpsim=(0:3)#,                                      <<nsf>>25080000
      hk=9#,xhk=(10:1)#,                                         <<nsf>>25085000
      sk=9#,xsk=(11:1)#,                                         <<nsf>>25090000
      st=9#,xst=(12:1)#,                                         <<nsf>>25095000
      hb=9#,xhb=(13:1)#,                                         <<nsf>>25100000
      cy=9#,xcy=(14:1)#,                                         <<nsf>>25105000
      bk=9#,xbk=(15:1)#,                                         <<nsf>>25110000
      ritbk=0#,xritbk=(15:1)#,                                   <<nsf>>25115000
      piovr=0#,xpiovr=(4:1)#,                                    <<nsf>>25120000
                                                                 <<nsf>>25125000
    <<life/death>>                                               <<nsf>>25130000
      live=9#,xlive=(0:1)#,                                      <<nsf>>25135000
      dead=8#,xdead=(6:1)#,                                      <<nsf>>25140000
      fac=8#,xfac=(7:1)#,                                        <<nsf>>25145000
                                                                 <<nsf>>25150000
    <<schedule information>>                                     <<nsf>>25155000
      pri=13#,xpri=(8:8)#,                                       <<nsf>>25160000
      dispq=13#,xdispq=(0:1)#,                                   <<nsf>>25165000
      lq=13#,xlq=(1:1)#,                                         <<nsf>>25170000
      cq=13#,xcq=(2:1)#,                                         <<nsf>>25175000
      dq=13#,xdq=(3:1)#,                                         <<nsf>>25180000
      eq=13#,xeq=(4:1)#,                                         <<nsf>>25185000
      inter=13#,xinter=(5:1)#,                                   <<nsf>>25190000
      corer=13#,xcorer=(6:1)#,                                   <<nsf>>25195000
      hipri=0#,xhipri=(13:1)#,                                   <<nsf>>25200000
      usedq=0#,xusedq=(12:1)#,                                   <<nsf>>25205000
      trw=0#,xtrw=(11:1)#,                                       <<nsf>>25210000
      sw=0#,xsw=(10:1)#,                                         <<nsf>>25215000
      lw=0#,xlw=(9:1)#,                                          <<nsf>>25220000
      mp=0#,xmp=(8:1)#,                                          <<nsf>>25225000
      pc=0#,xpc=(7:1)#,                                          <<nsf>>25230000
      ipexp=0#,xipexp=(6:1)#,                                    <<nsf>>25235000
      hspri=0#,xhspri=(5:1)#,                                    <<nsf>>25240000
      sar=0#,xsar=(0:1)#,                                        <<nsf>>25245000
      sov=9#,xsov=(5:1)#;                                        <<nsf>>25250000
                                                                 <<nsf>>25255000
                                                                 <<nsf>>25260000
<<************************************************>>             <<nsf>>25265000
<<checkbit                                        >>             <<nsf>>25270000
<<------------------------------------------------>>             <<nsf>>25275000
<<this subroutine checks if the bit sent via the  >>             <<nsf>>25280000
<<bit parameter is set or not. if it is, then the >>             <<nsf>>25285000
<<string constant, "YES", is inserted into the    >>             <<nsf>>25290000
<<output buffer at the column specified by col.   >>             <<nsf>>25295000
<<************************************************>>             <<nsf>>25300000
                                                                 <<nsf>>25305000
                                                                 <<nsf>>25310000
  subroutine ckbit(bit,col);                                     <<nsf>>25315000
                                                                 <<nsf>>25320000
  value col,bit;                                                 <<nsf>>25325000
  integer col;  <<col in which to insert yes>>                   <<nsf>>25330000
  logical bit;  <<bit to be tested>>                             <<nsf>>25335000
                                                                 <<nsf>>25340000
                                                                 <<nsf>>25345000
    begin                                                        <<nsf>>25350000
    if bit then move text(col):="YES";                           <<nsf>>25355000
    end;                                                         <<nsf>>25360000
                                                                 <<nsf>>25365000
                                                                 <<nsf>>25370000
                                                                 <<nsf>>25375000
      lnum:=1;   <<initialize the line count>>                   <<nsf>>25380000
      while lnum<=23 do   <<loop thru the format lines>>         <<nsf>>25385000
        begin                                                    <<nsf>>25390000
        text:=" "; move text(1):=text,(78);                             25395000
        case lnum of  <<branch to appropriate >>                 <<nsf>>25400000
          begin         <<format line.          >>               <<nsf>>25405000
          ;   <<0 case>>                                         <<nsf>>25410000
            begin  <<line 1>>                                    <<nsf>>25415000
            move text(4):="PROCESS ID";                          <<nsf>>25420000
            if procdead(pin) <<call procdead for test>>          <<nsf>>25425000
              then move text(29):="****NOT IN USE****";          <<nsf>>25430000
            move text(65):="SCHEDULE INFO";                      <<nsf>>25435000
            end;                                                 <<nsf>>25440000
                                                                 <<nsf>>25445000
            begin  <<line 2>>                                    <<nsf>>25450000
            move text(2):="--------------";                      <<nsf>>25455000
            move text(39):="RESOURCES";                          <<nsf>>25460000
            move text(65):="-------------";                      <<nsf>>25465000
            end;                                                 <<nsf>>25470000
                                                                 <<nsf>>25475000
            begin  <<line 3>>                                    <<nsf>>25480000
            move text(4):="PIN: %";                              <<nsf>>25485000
            len:=ascii(pin,8,btxt); <<conversion>>               <<nsf>>25490000
            move text(11):=btxt(6-len),(len); <<insert pin>>     <<nsf>>25495000
            move text(24):="WAKE  EVENT";                        <<nsf>>25500000
            move text(37):="-------------";                      <<nsf>>25505000
            move text(52):="PSEUDO INT";                         <<nsf>>25510000
            move text(68):="PRI:";                               <<nsf>>25515000
            num:=pcbentry(pri).xpri; <<get prio>>                <<nsf>>25520000
            len:=ascii(num,8,btxt); <<convert prio>>             <<nsf>>25525000
            move text(73):=btxt(6-len),(len); <<insert prio>>    <<nsf>>25530000
            end;                                                 <<nsf>>25535000
                                                                 <<nsf>>25540000
                                                                 <<nsf>>25545000
            begin  <<line 4>>                                    <<nsf>>25550000
            if current(pin) <<call current for test>>            <<nsf>>25555000
              then move text(4):="(CURRENT)" <<insert if true>>  <<nsf>>25560000
              else                                               <<nsf>>25565000
            move text(24):="MASKS FLAGS";                        <<nsf>>25570000
            move text(41):="CRIT:";                              <<nsf>>25575000
            ckbit(pcbentry(crit).xcrit,47); <<test if critcal>>  <<nsf>>25580000
            move text(52):="-----------";                        <<nsf>>25585000
            end;                                                 <<nsf>>25590000
                                                                 <<nsf>>25595000
            begin  <<line 5>>                                    <<nsf>>25600000
            move text(2):="PTYPE:";                              <<nsf>>25605000
            num:=pcbentry(ptype).xptype;  <<get proc type #>>    <<nsf>>25610000
            type:=num;                                           <<nsf>>25615000
            case num of <<assign process type>>                  <<nsf>>25620000
              begin                                              <<nsf>>25625000
              move text(9):="USER";  <<ptype=0>>                 <<nsf>>25630000
              move text(9):="USONM"; <<ptype=1>>                 <<nsf>>25635000
              move text(9):="UMAIN"; <<ptype=2>>                 <<nsf>>25640000
              move text(9):="UMTSK"; <<ptype=3>>                 <<nsf>>25645000
              move text(9):="SYST";  <<ptype=4>>                 <<nsf>>25650000
              move text(9):="SYS";   <<ptype=5>>                 <<nsf>>25655000
              move text(9):="SYSTU"; <<ptype=6>>                 <<nsf>>25660000
              ;                      <<ptype=7>>                 <<nsf>>25665000
              end;                                               <<nsf>>25670000
            move text(24):="----- -----";                        <<nsf>>25675000
            move text(41):="HSIR:";                              <<nsf>>25680000
            ckbit(pcbentry(hsir).xhsir,47); <<test hsir>>        <<nsf>>25685000
            move text(53):="PSIM:";                              <<nsf>>25690000
            num:=pcbentry(psim).xpsim; <<get pseudo int mode>>   <<nsf>>25695000
            case num of  <<test psim>>                           <<nsf>>25700000
              begin                                              <<nsf>>25705000
              ;   <<num=0>>                                      <<nsf>>25710000
              move text(59):="HK";  <<hard kill>>                <<nsf>>25715000
              move text(59):="SK";  <<soft kill>>                <<nsf>>25720000
              move text(59):="ST";  <<stop>>                     <<nsf>>25725000
              move text(59):="HB";  <<hibernate>>                <<nsf>>25730000
              move text(59):="CY";  <<escape>>                   <<nsf>>25735000
              move text(59):="BK";  <<break>>                    <<nsf>>25740000
              move text(59):="NORM";  <<normal>>                 <<nsf>>25745000
              end;                                               <<nsf>>25750000
            move text(66):="DISPQ:";                             <<nsf>>25755000
            ckbit(pcbentry(dispq).xdispq,73); <<test dispq>>     <<nsf>>25760000
             end;                                                <<nsf>>25765000
                                                                 <<nsf>>25770000
                                                                 <<nsf>>25775000
            begin  <<line 6>>                                    <<nsf>>25780000
            move text(3):="NAME:";                               <<nsf>>25785000
            name'it(pin,text(9)); <<name the process>>           <<nsf>>25790000
            move text(22):="M:";                                 <<nsf>>25795000
            ckbit(pcbentry(wake).m,25); <<test m wake flag>>     <<nsf>>25800000
            ckbit(pcbentry(event).m,31); <<test m event flag>>   <<nsf>>25805000
            move text(43):="SC:";                                <<nsf>>25810000
            ckbit(pcbentry(sc).xsc,47); <<test sc flag>>         <<nsf>>25815000
            move text(55):="HK:";                                <<nsf>>25820000
            ckbit(pcbentry(hk).xhk,59); <<test hk flag>>         <<nsf>>25825000
            move text(69):="LQ:";                                <<nsf>>25830000
            ckbit(pcbentry(lq).xlq,73); <<test lq flag>>         <<nsf>>25835000
            end;                                                 <<nsf>>25840000
                                                                 <<nsf>>25845000
            begin  <<line 7>>                                    <<nsf>>25850000
            move text(21):="RG:";                                <<nsf>>25855000
            ckbit(pcbentry(wake).rg,25); <<test rg wake flag>>   <<nsf>>25860000
            ckbit(pcbentry(event).rg,31); <<test rg event>>      <<nsf>>25865000
            move text(37):="NEXT IMP:";                          <<nsf>>25870000
            num:=pcbentry(nimp)/21; <<get nimp 5>>               <<nsf>>25875000
            if num <> 0 then  <<check for next imp proc>>        <<nsf>>25880000
              begin                                              <<nsf>>25885000
              len:=ascii(num,8,btxt); <<convert nimp>>           <<nsf>>25890000
              move text(47):=btxt(6-len),(len); <<insert nimp>>  <<nsf>>25895000
              end;                                               <<nsf>>25900000
            move text(55):="SK:";                                <<nsf>>25905000
            ckbit(pcbentry(sk).xsk,59);  <<test sk flag>>        <<nsf>>25910000
            move text(69):="CQ:";                                <<nsf>>25915000
            ckbit(pcbentry(cq).xcq,73);  <<test cq flag>>        <<nsf>>25920000
            end;                                                 <<nsf>>25925000
                                                                 <<nsf>>25930000
                                                                 <<nsf>>25935000
            begin  <<line 8>>                                    <<nsf>>25940000
            move text(21):="RL:";                                <<nsf>>25945000
            ckbit(pcbentry(wake).rl,25); <<test rl wake flag>>   <<nsf>>25950000
            ckbit(pcbentry(event).rl,31); <<test rl event>>      <<nsf>>25955000
            move text(37):="PREV IMP:";                          <<nsf>>25960000
            num:=pcbentry(pimp)/21; <<get pimp>>                 <<nsf>>25965000
            if num <> 0 then <<check for prev imp proc>>         <<nsf>>25970000
              begin                                              <<nsf>>25975000
              len:=ascii(num,8,btxt); <<convert pimp>>           <<nsf>>25980000
              move text(47):=btxt(6-len),(len); <<insert pimp>>  <<nsf>>25985000
              end;                                               <<nsf>>25990000
            move text(55):="ST:";                                <<nsf>>25995000
            ckbit(pcbentry(st).xst,59);  <<test st flag>>        <<nsf>>26000000
            move text(69):="DQ:";                                <<nsf>>26005000
            ckbit(pcbentry(dq).xdq,73);  <<test dq flag>>        <<nsf>>26010000
            end;                                                 <<nsf>>26015000
                                                                 <<nsf>>26020000
            begin  <<line 9>>                                    <<nsf>>26025000
            move text(2):="DATA SEGMENTS";                       <<nsf>>26030000
            move text(21):="MA:";                                <<nsf>>26035000
            ckbit(pcbentry(wake).ma,25); <<test ma wake flag>>   <<nsf>>26040000
            ckbit(pcbentry(event).ma,31); <<test ma event>>      <<nsf>>26045000
            move text(55):="HB:";                                <<nsf>>26050000
            ckbit(pcbentry(hb).xhb,59); <<test hb flag>>         <<nsf>>26055000
            move text(69):="EQ:";                                <<nsf>>26060000
            ckbit(pcbentry(eq).xeq,73); <<test eq flag>>         <<nsf>>26065000
            end;                                                 <<nsf>>26070000
                                                                 <<nsf>>26075000
            begin  <<line 10>>                                   <<nsf>>26080000
            move text(2):="--------------";                      <<nsf>>26085000
            move text(20):="BIO:";                               <<nsf>>26090000
            ckbit(pcbentry(wake).bio,25); <<test bio wake>>      <<nsf>>26095000
            ckbit(pcbentry(event).bio,31); <<test bio event>>    <<nsf>>26100000
            move text(37):="MISCELLANEOUS";                      <<nsf>>26105000
            move text(55):="CY:";                                <<nsf>>26110000
            ckbit(pcbentry(cy).xcy,59); <<test cy flag>>         <<nsf>>26115000
            move text(66):="INTER:";                             <<nsf>>26120000
            ckbit(pcbentry(inter).xinter,73);  <<test inter>>    <<nsf>>26125000
            end;                                                 <<nsf>>26130000
                                                                 <<nsf>>26135000
                                                                 <<nsf>>26140000
            begin  <<line 11>>                                   <<nsf>>26145000
            move text(6):="XDS:";                                <<nsf>>26150000
            num:=pcbentry(xds).xxds; <<get xds>>                 <<nsf>>26155000
            if num <> 0 then  <<check for ex data seg>>          <<nsf>>26160000
              begin                                              <<nsf>>26165000
             len:=ascii(num,8,btxt);  <<convert xds>>            <<nsf>>26170000
             move text(11):=btxt(6-len),(len); <<insert xds>>    <<nsf>>26175000
              end;                                               <<nsf>>26180000
            move text(21):="IO:";                                <<nsf>>26185000
            ckbit(pcbentry(wake).io,25); <<test io wake flag>>   <<nsf>>26190000
            ckbit(pcbentry(event).io,31); <<test io event>>      <<nsf>>26195000
            move text(37):="-------------";                      <<nsf>>26200000
            move text(55):="BK:";                                <<nsf>>26205000
            ckbit(pcbentry(bk).xbk,59); <<test bk flag>>         <<nsf>>26210000
            move text(66):="CORER:";                             <<nsf>>26215000
            ckbit(pcbentry(corer).xcorer,73); <<test corer>>     <<nsf>>26220000
            end;                                                 <<nsf>>26225000
                                                                 <<nsf>>26230000
            begin  <<line 12>>                                   <<nsf>>26235000
            move text(3):="ABS DB:";                             <<nsf>>26240000
            ckbit(pcbentry(absdb).xabsdb,11); <<test absdb>>     <<nsf>>26245000
            move text(19):="UCOP:";                              <<nsf>>26250000
            ckbit(pcbentry(wake).ucop,25); <<test ucop wake>>    <<nsf>>26255000
            ckbit(pcbentry(event).ucop,31); <<test ucop event>>  <<nsf>>26260000
            move text(41):="BMS:";                               <<nsf>>26265000
            num:=pcbentry(bms).xbms;  <<get bms>>                <<nsf>>26270000
            case num of <<test bms>>                             <<nsf>>26275000
              begin                                              <<nsf>>26280000
              move text(46):="SNF";  <<sent to fr>>              <<nsf>>26285000
              move text(46):="REF";  <<received from fr>>        <<nsf>>26290000
              move text(46):="SNS";  <<sent to son>>             <<nsf>>26295000
              move text(46):="RES";  <<received from son>>       <<nsf>>26300000
              end;                                               <<nsf>>26305000
            move text(52):="RITBK:";                             <<nsf>>26310000
            ckbit(pcbentry(ritbk).xritbk,59); <<test ritbk>>     <<nsf>>26315000
            end;                                                 <<nsf>>26320000
                                                                 <<nsf>>26325000
            begin  <<line 13>>                                   <<nsf>>26330000
            move text(19):="JUNK:";                              <<nsf>>26335000
            ckbit(pcbentry(wake).junk,25); <<test junk wake>>    <<nsf>>26340000
            ckbit(pcbentry(event).junk,31); <<test junk event>>  <<nsf>>26345000
            move text(41):="PPC:";                               <<nsf>>26350000
            num:=pcbentry(ppc).xppc; <<get ppc>>                 <<nsf>>26355000
            case num of <<test ppc>>                             <<nsf>>26360000
              begin                                              <<nsf>>26365000
              move text(46):="NUL";   <<null>>                   <<nsf>>26370000
               move text(46):="STF";   <<son to fr>>             <<nsf>>26375000
               move text(46):="FTS";   <<fr to son>>             <<nsf>>26380000
               move text(46):="BLK";   <<blocked>>               <<nsf>>26385000
               end;                                              <<nsf>>26390000
            move text(52):="PIOVR:";                             <<nsf>>26395000
            ckbit(pcbentry(piovr).xpiovr,59); <<test piovr>>     <<nsf>>26400000
            move text(66):="HIPRI:";                             <<nsf>>26405000
            ckbit(pcbentry(hipri).xhipri,73);  <<test hipri>>    <<nsf>>26410000
            end;                                                 <<nsf>>26415000
                                                                 <<nsf>>26420000
                                                                 <<nsf>>26425000
            begin  <<line 14>>                                   <<nsf>>26430000
            move text(4):="STACK:";                              <<nsf>>26435000
            num:=pcbentry(stk).xstk; <<get stk addr>>            <<nsf>>26440000
            if num <> 0 then                                     <<nsf>>26445000
              begin                                              <<nsf>>26450000
              len:=ascii(num,8,btxt); <<convert stk addr>>       <<nsf>>26455000
              move text(11):=btxt(6-len),(len); <<insert stk addr<<nsf>>26460000
            if vm'inuse and getdstaddr(num) >= vm'min  then             26465000
              text(11+len) := "V";                                      26470000
              end;                                               <<nsf>>26475000
            move text(18):="TIMER:";                             <<nsf>>26480000
            ckbit(pcbentry(wake).timer,25); <<test timer wake>>  <<nsf>>26485000
            ckbit(pcbentry(event).timer,31); <<test tmr event>>  <<nsf>>26490000
            move text(40):="PCST:";                              <<nsf>>26495000
            dnum:=pcbentry(pcst); <<get pcst>>                   <<nsf>>26500000
            num:=integer(dnum); <<convert pcst to integer>>      <<nsf>>26505000
            if num <> 0 then <<check for nonzero pcst>>          <<nsf>>26510000
              begin                                              <<nsf>>26515000
              len:=dascii(double(dnum),8,dbtxt); <<convert>>     <<nsf>>26520000
              move text(46):=dbtxt(11-len),(len); <<insert pcst>><<nsf>>26525000
              end;                                               <<nsf>>26530000
            move text(66):="USEDQ:";                             <<nsf>>26535000
            ckbit(pcbentry(usedq).xusedq,73); <<test usedq>>     <<nsf>>26540000
            end;                                                 <<nsf>>26545000
                                                                 <<nsf>>26550000
            begin  <<line 15>>                                   <<nsf>>26555000
            move text(3):="OV ALC:";                             <<nsf>>26560000
            ckbit(pcbentry(oval).xoval,11); <<test oval flag>>   <<nsf>>26565000
            move text(20):="MSG:";                               <<nsf>>26570000
            ckbit(pcbentry(wake).msg,25); <<test msg wake>>      <<nsf>>26575000
            ckbit(pcbentry(event).msg,31); <<test msg event>>    <<nsf>>26580000
            move text(37):="PBX PTR:";                           <<nsf>>26585000
            dnum:=pcbentry(pxpt); <<get pbx ptr>>                <<nsf>>26590000
            num:=integer(dnum); <<convert pbx ptr to integer>>   <<nsf>>26595000
            if num <> 0 then <<check for nonzero pbx ptr>>       <<nsf>>26600000
              begin                                              <<nsf>>26605000
              len:=dascii(double(dnum),8,dbtxt); <<convert>>     <<nsf>>26610000
              move text(46):=dbtxt(11-len),(len); <<insert pbx>> <<nsf>>26615000
              end;                                               <<nsf>>26620000
            move text(68):="TRW:";                               <<nsf>>26625000
            ckbit(pcbentry(trw).xtrw,73); <<test trw flag>>      <<nsf>>26630000
            end;                                                 <<nsf>>26635000
                                                                 <<nsf>>26640000
            begin  <<line 16>>                                   <<nsf>>26645000
            move text(20):="SON:";                               <<nsf>>26650000
            ckbit(pcbentry(wake).wson,25); <<test son wake>>     <<nsf>>26655000
            ckbit(pcbentry(event).wson,31); <<test son event>>   <<nsf>>26660000
            move text(38):="SL PTR:";                            <<nsf>>26665000
            dnum:=pcbentry(sl); <<get sl>>                       <<nsf>>26670000
            num:=integer(dnum); <<convert sl to integer>>        <<nsf>>26675000
            if num <> 0 then <<check for nonzero sl>>            <<nsf>>26680000
              begin                                              <<nsf>>26685000
              len:=dascii(double(dnum),8,dbtxt); <<convert>>     <<nsf>>26690000
              move text(46):=dbtxt(11-len),(len); <<insert sl>>  <<nsf>>26695000
              end;                                               <<nsf>>26700000
            move text(69):="SW:";                                <<nsf>>26705000
            ckbit(pcbentry(sw).xsw,73); <<test sw flag>>         <<nsf>>26710000
            end;                                                 <<nsf>>26715000
                                                                 <<nsf>>26720000
            begin  <<line 17>>                                   <<nsf>>26725000
            move text(18):="FATHR:";                             <<nsf>>26730000
            ckbit(pcbentry(wake).fathr,25); <<test fr wake>>     <<nsf>>26735000
            ckbit(pcbentry(event).fathr,31); <<test fr event>>   <<nsf>>26740000
            move text(38):="BPLINK:";                            <<nsf>>26745000
            num:=pcbentry(bplk); <<get bk pt link>>              <<nsf>>26750000
            if num <> 0 then  <<check for nonzero bplk>>         <<nsf>>26755000
              begin                                              <<nsf>>26760000
             len:=ascii(dnum,8,btxt); <<convert to ascii>>       <<nsf>>26765000
             move text(46):=btxt(6-len),(len);  <<insert bplk>>  <<nsf>>26770000
              end;                                               <<nsf>>26775000
            move text(52):="LIFE/DEATH";                         <<nsf>>26780000
            move text(69):="LW:";                                <<nsf>>26785000
            ckbit(pcbentry(lw).xlw,73); <<test lw flag>>         <<nsf>>26790000
            end;                                                 <<nsf>>26795000
                                                                 <<nsf>>26800000
            begin  <<line 18>>                                   <<nsf>>26805000
            move text(3):="FAMILY INFO";                         <<nsf>>26810000
            move text(20):="IMP:";                               <<nsf>>26815000
            ckbit(pcbentry(wake).imp,25); <<test imp wake>>      <<nsf>>26820000
            ckbit(pcbentry(event).imp,31); <<test imp event>>    <<nsf>>26825000
            move text(52):="-----------";                        <<nsf>>26830000
            move text(69):="MP:";                                <<nsf>>26835000
            ckbit(pcbentry(mp).xmp,73); <<test mp flag>>         <<nsf>>26840000
            end;                                                 <<nsf>>26845000
                                                                 <<nsf>>26850000
            begin <<line 19>>                                    <<nsf>>26855000
            move text(2):="--------------";                      <<nsf>>26860000
            move text(20):="SIR:";                               <<nsf>>26865000
            ckbit(pcbentry(wake).sir,25); <<test sir wake>>      <<nsf>>26870000
            ckbit(pcbentry(event).sir,31); <<test sir event>>    <<nsf>>26875000
            move text(38):="QUEUE LINKS";                        <<nsf>>26880000
            move text(53):="LIVE:";                              <<nsf>>26885000
            ckbit(pcbentry(live).xlive,59);<<test live flag>>    <<nsf>>26890000
            move text(69):="PC:";                                <<nsf>>26895000
            ckbit(pcbentry(pc).xpc,73); <<test pc flag>>         <<nsf>>26900000
            end;                                                 <<nsf>>26905000
                                                                 <<nsf>>26910000
                                                                 <<nsf>>26915000
            begin  <<line 20>>                                   <<nsf>>26920000
            move text(4):="FATHER:";                             <<nsf>>26925000
            num:=pcbentry(fr)/21;   <<get father ptr>>           <<nsf>>26930000
            if num <> 0 then                                     <<nsf>>26935000
              begin                                              <<nsf>>26940000
              len:=ascii(num,8,btxt); <<convert fr ptr>>         <<nsf>>26945000
              move text(12):=btxt(6-len),(len); <<insert fthr ptr<<nsf>>26950000
              end;                                               <<nsf>>26955000
            move text(18):="TMOUT:";                             <<nsf>>26960000
            ckbit(pcbentry(wake).tmout,25); <<test tmout wake>>  <<nsf>>26965000
            ckbit(pcbentry(event).tmout,31);<<test tmout evnt>>  <<nsf>>26970000
            move text(37):="-------------";                      <<nsf>>26975000
            move text(53):="DEAD:";                              <<nsf>>26980000
            ckbit(pcbentry(dead).xdead,59);  <<test dead flag>>  <<nsf>>26985000
            move text(66):="IPEXP:";                             <<nsf>>26990000
            ckbit(pcbentry(ipexp).xipexp,73); <<test ipexp>>     <<nsf>>26995000
            end;                                                 <<nsf>>27000000
                                                                 <<nsf>>27005000
            begin  <<line 21>>                                   <<nsf>>27010000
            move text(7):="SON:";                                <<nsf>>27015000
            num:=pcbentry(son)/21;   <<get son ptr>>             <<nsf>>27020000
            if num <> 0 then  <<check for nonzero son ptr>>      <<nsf>>27025000
              begin                                              <<nsf>>27030000
              len:=ascii(num,8,btxt); <<convert son ptr>>        <<nsf>>27035000
              move text(12):=btxt(6-len),(len); <<insert son ptr><<nsf>>27040000
              end;                                               <<nsf>>27045000
            move text(20):="MEM:";                               <<nsf>>27050000
            ckbit(pcbentry(wake).mem,25); <<test mem wake>>      <<nsf>>27055000
            ckbit(pcbentry(event).mem,31); <<test mem event>>    <<nsf>>27060000
            move text(37):="NQPIN:";                             <<nsf>>27065000
            dnum:=pcbentry(nqpn)/21; <<get next q pin>>          <<nsf>>27070000
            num:=integer(dnum); <<convert next q pin>>           <<nsf>>27075000
            if (num <> 0) and (num<>-1) then <<ck for next q pin><<nsf>>27080000
              begin                                              <<nsf>>27085000
              len:=dascii(double(dnum),8,dbtxt);  <<convert>>    <<nsf>>27090000
              move text(44):=dbtxt(11-len),(len); <<insert nqpn>><<nsf>>27095000
              end;                                               <<nsf>>27100000
            move text(54):="FAC:";                               <<nsf>>27105000
            ckbit(pcbentry(fac).xfac,59); <<test fac flag>>      <<nsf>>27110000
            move text(66):="HSPRI:";                             <<nsf>>27115000
            ckbit(pcbentry(hspri).xhspri,73); <<test hspri>>     <<nsf>>27120000
            end;                                                 <<nsf>>27125000
                                                                 <<nsf>>27130000
                                                                 <<nsf>>27135000
            begin  <<line 22>>                                   <<nsf>>27140000
            move text(3):="BROTHER:";                            <<nsf>>27145000
            num:=pcbentry(br)/21;  <<get br ptr>>                <<nsf>>27150000
            if num <> 0 then <<check for nonzero br ptr>>        <<nsf>>27155000
              begin                                              <<nsf>>27160000
             len:=ascii(num,8,btxt);  <<convert br ptr>>         <<nsf>>27165000
             move text(12):=btxt(6-len),(len); <<insert br ptr>> <<nsf>>27170000
              end;                                               <<nsf>>27175000
            move text(37):="PQPIN:";                             <<nsf>>27180000
            dnum:=pcbentry(pqpn)/21; <<get prev q pin>>          <<nsf>>27185000
            num:=integer(dnum); <<convert pqpn to integer>>      <<nsf>>27190000
            if (num<>0) and (num<>-1) then <<ck for valid pqpn>> <<nsf>>27195000
              begin                                              <<nsf>>27200000
             len:=dascii(double(dnum),8,dbtxt); <<convert>>      <<nsf>>27205000
             move text(44):=dbtxt(11-len),(len); <<insert pqpn>> <<nsf>>27210000
              end;                                               <<nsf>>27215000
            move text(68):="SAR:";                               <<nsf>>27220000
            ckbit(pcbentry(sar).xsar,73); <<test sar flag>>      <<nsf>>27225000
            end;                                                 <<nsf>>27230000
                                                                 <<nsf>>27235000
                                                                 <<nsf>>27240000
            begin  <<line 23>>                                   <<nsf>>27245000
            move text(8):="OA:";                                 <<nsf>>27250000
            num:=pcbentry(oa).xoa; <<test oa flag>>              <<nsf>>27255000
            case num of                                          <<nsf>>27260000
              begin                                              <<nsf>>27265000
              ;        << other source>>                         <<nsf>>27270000
              move text(12):="F";  <<father>>                    <<nsf>>27275000
              move text(12):="S";  <<son>>                       <<nsf>>27280000
              move text(12):="R";  <<rit>>                       <<nsf>>27285000
              end;                                               <<nsf>>27290000
            blankbuf;                                          <<*nth*>>27295000
            get'pname(pcbentry(pxpt),buf);                     <<*nth*>>27300000
            if buf >= "A" and buf <= "Z" then                  <<*nth*>>27305000
              begin                                            <<*nth*>>27310000
              move text(18) := "USER PGM NAME:  ";             <<*nth*>>27315000
              move text(33) := buf,(26);                       <<*nth*>>27320000
              end;                                             <<*nth*>>27325000
            blankbuf;                                          <<*nth*>>27330000
            move text(68):="SOV:";                               <<nsf>>27335000
            ckbit(pcbentry(sov).xsov,73);                        <<nsf>>27340000
            end;                                                 <<nsf>>27345000
          end;  <<case statement>>                               <<nsf>>27350000
                                                                 <<nsf>>27355000
        write'rec(flnum,ltxt,-79,0);  <<print out formated line>>       27360000
                                                                 <<nsf>>27365000
        lnum:=lnum+1;  <<increment line count>>                  <<nsf>>27370000
        end; <<while stmt>>                                      <<nsf>>27375000
    end;  <<fmtpcbentry5>>                                       <<nsf>>27380000
$page"                        PROCEDURE FMTPINS4"                       27385000
$control segment=idat4a                                                 27390000
<<**********************************************************>>          27395000
<<  fmtpins4                                                >>          27400000
<<---------------------------------------------------------->>          27405000
<<  this procedure will format all pins in the pcb table    >>          27410000
<<  and print a one line description about each.            >>          27415000
<<**********************************************************>>          27420000
                                                                        27425000
procedure fmtpins4(prntfile);                                           27430000
  value prntfile;                                                       27435000
  integer prntfile;                                                     27440000
                                                                        27445000
begin                                                                   27450000
                                                                        27455000
  logical array pcbentry(0:20),ltxt(0:39);                              27460000
  byte array text(*)=ltxt,btxt(0:5),dbtxt(0:11),ltr(0:0);               27465000
  integer pcbentsize,num,len,count,type,i,j,n,offset;                   27470000
  logical pin;                                                          27475000
  double pcbaddr,stopaddr,curradr;                                      27480000
  define                                                                27485000
                                                                        27490000
    <<process identification>>                                          27495000
      ptype=9#,xptype=(6:3)#,                                           27500000
                                                                        27505000
    <<data segments>>                                                   27510000
      xds=2#,xxds=(1:10)#,                                              27515000
      absdb=2#,xabsdb=(0:1)#,                                           27520000
      stk=3#,xstk=(1:10)#,                                              27525000
      oval=3#,xoval=(0:1)#,                                             27530000
                                                                        27535000
    <<family info>>                                                     27540000
      fr=5#,xfr=(0:8)#,                                                 27545000
      son=5#,xson=(8:8)#,                                               27550000
      br=6#,xbr=(0:8)#,                                                 27555000
      oa=8#,xoa=(4:2)#,                                                 27560000
                                                                        27565000
    <<wakes and events>>                                                27570000
      wake=pcbentry(4)#,event=pcbentry(10)#,                            27575000
      m=(0:1)#,rg=(1:1)#,                                               27580000
      rl=(2:1)#,ma=(3:1)#,                                              27585000
      bio=(4:1)#,io=(5:1)#,                                             27590000
      ucop=(6:1)#,junk=(7:1)#,                                          27595000
      timer=(8:1)#,msg=(9:1)#,                                          27600000
      wson=(10:1)#,fathr=(11:1)#,                                       27605000
      imp=(12:1)#,sir=(13:1)#,                                          27610000
      tmout=(14:1)#,mem=(15:1)#,                                        27615000
                                                                        27620000
    <<resources>>                                                       27625000
      crit=0#,xcrit=(2:1)#,                                             27630000
      hsir=0#,xhsir=(3:1)#,                                             27635000
      sc=3#,xsc=(11:1)#,                                                27640000
      nimp=8#,xnimp=(8:8)#,                                             27645000
      pimp=7#,xpimp=(0:8)#,                                             27650000
                                                                        27655000
    <<miscellaneous>>                                                   27660000
      bms=9#,xbms=(1:2)#,                                               27665000
      ppc=9#,xppc=(3:2)#,                                               27670000
      pcst=11#,xpcst=(0:16)#,                                           27675000
      pxpt=12#,xpxpt=(0:16)#,                                           27680000
      sl=1#,xsl=(0:16)#,                                                27685000
      bplk=7#,xbplk=(8:8)#,                                             27690000
                                                                        27695000
    <<queue links>>                                                     27700000
      nqpn=14#,xnqpn=(0:16)#,                                           27705000
      pqpn=15#,xpqpn=(0:16)#,                                           27710000
                                                                        27715000
                                                                        27720000
    <<pseudo interrupts>>                                               27725000
      psim=8#,xpsim=(0:3)#,                                             27730000
      hk=9#,xhk=(10:1)#,                                                27735000
      sk=9#,xsk=(11:1)#,                                                27740000
      st=9#,xst=(12:1)#,                                                27745000
      hb=9#,xhb=(13:1)#,                                                27750000
      cy=9#,xcy=(14:1)#,                                                27755000
      bk=9#,xbk=(15:1)#,                                                27760000
      ritbk=0#,xritbk=(15:1)#,                                          27765000
      piovr=0#,xpiovr=(4:1)#,                                           27770000
                                                                        27775000
    <<life/death>>                                                      27780000
      live=9#,xlive=(0:1)#,                                             27785000
      dead=8#,xdead=(6:1)#,                                             27790000
      fac=8#,xfac=(7:1)#,                                               27795000
                                                                        27800000
    <<schedule information>>                                            27805000
      pri=13#,xpri=(8:8)#,                                              27810000
      dispq=13#,xdispq=(0:1)#,                                          27815000
      lq=13#,xlq=(1:1)#,                                                27820000
      cq=13#,xcq=(2:1)#,                                                27825000
      dq=13#,xdq=(3:1)#,                                                27830000
      eq=13#,xeq=(4:1)#,                                                27835000
      inter=13#,xinter=(5:1)#,                                          27840000
      corer=13#,xcorer=(6:1)#,                                          27845000
      hipri=0#,xhipri=(13:1)#,                                          27850000
      usedq=0#,xusedq=(12:1)#,                                          27855000
      trw=0#,xtrw=(11:1)#,                                              27860000
      sw=0#,xsw=(10:1)#,                                                27865000
      lw=0#,xlw=(9:1)#,                                                 27870000
      mp=0#,xmp=(8:1)#,                                                 27875000
      pc=0#,xpc=(7:1)#,                                                 27880000
      ipexp=0#,xipexp=(6:1)#,                                           27885000
      hspri=0#,xhspri=(5:1)#,                                           27890000
      sar=0#,xsar=(0:1)#,                                               27895000
      sov=9#,xsov=(5:1)#,                                               27900000
                                                                        27905000
      pcb'status=pcbentry(15)#,                                         27910000
      max'pcbs=pcbentry(0)#;                                            27915000
                                                                        27920000
  equate not'in'use = %177777;                                          27925000
                                                                        27930000
<<**************************************************>>                  27935000
<<checkbit                                          >>                  27940000
<<-------------------------------------------------->>                  27945000
<<this subroutine checks the bit sent via the bit   >>                  27950000
<<parameter, and if set, moves the letter passed    >>                  27955000
<<to the column specified in the array 'text'.      >>                  27960000
<<**************************************************>>                  27965000
                                                                        27970000
  subroutine ckbit(bit,col,ltr);                                        27975000
    value col,bit,ltr;                                                  27980000
    integer col;                                                        27985000
    logical bit;                                                        27990000
    byte ltr;                                                           27995000
                                                                        28000000
  begin                                                                 28005000
    if bit then text(col):=ltr;                                         28010000
  end;  <<ckbit>>                                                       28015000
                                                                        28020000
  pcbaddr:=getdstaddr(3);                                               28025000
                                                                        28030000
  pcbentsize:=%20;                                                      28035000
  getcore(pcbaddr,pcbentsize,pcbentry);                                 28040000
  if <> then return;                                                    28045000
  stopaddr:=pcbaddr+double(max'pcbs*logical(pcbentsize));               28050000
                                                                        28055000
  curradr:=pcbaddr+double(pcbentsize);                                  28060000
                                                                        28065000
  move buf:=("               A                          T  ",           28070000
             "F  T                         RP  D"),2;                   28075000
  i:=tos-@buf;                                                          28080000
  write'rec(prntfile,lbuf,-i,0);                                        28085000
  move buf:=("               B                        UJI  ",           28090000
             "A  M                CH       II  I"),2;                   28095000
  i:=tos-@buf;                                                          28100000
  write'rec(prntfile,lbuf,-i,0);                                        28105000
  move buf:=("               S                      B CUMMS",           28110000
             "TISOM     PREV NEXT RS       TO TS"),2;                   28115000
  i:=tos-@buf;                                                          28120000
  write'rec(prntfile,lbuf,-i,0);                                        28125000
  move buf:=("               N FTHR  SON  BRO O  RRMIIONESO",           28130000
             "HMIUE     IMPD IMPD II HSSHCBBV RP"),2;                   28135000
  i:=tos-@buf;                                                          28140000
  write'rec(prntfile,lbuf,-i,0);                                        28145000
  move buf:=("PIN    XDS  STKT  PIN  PIN  PIN A MGLAOOPKRGN",           28150000
             "RPRTM PRI  PIN  PIN TR KKTBYKKR WQ"),2;                   28155000
  i:=tos-@buf;                                                          28160000
  write'rec(prntfile,lbuf,-i,0);                                        28165000
                                                                        28170000
  while curradr < stopaddr and not stop'print do begin                  28175000
    if ctrly then begin                                                 28180000
      write'rec(prntfile,ltxt,0,0);                                     28185000
      move text:=" <CONTROL-Y>";                                        28190000
      write'rec(prntfile,ltxt,-12,%60);                                 28195000
      return;                                                           28200000
    end;                                                                28205000
    getcore(curradr,pcbentsize,pcbentry);                               28210000
    if <> then return;                                                  28215000
    if pcb'status <> not'in'use then begin                              28220000
      move text:=" "; move text(1):=text,(79);                          28225000
      pin:=logical((curradr-pcbaddr)/16d);                              28230000
      len:=ascii(pin,8,btxt);                                           28235000
      move text(4-len):=btxt(6-len),(len);                              28240000
      if current(pin) then move text(4):="*";                           28245000
      if pcbentry(xds).xxds <> 0 then begin                             28250000
        len:=ascii(pcbentry(xds).xxds,8,btxt);                          28255000
        move text(10-len):=btxt(6-len),(len); end;                      28260000
      if pcbentry(stk).xstk <> 0 then begin                             28265000
        len:=ascii(pcbentry(stk).xstk,8,btxt);                          28270000
        move text(15-len):=btxt(6-len),(len);                           28275000
        lfds(pcbentry(stk).xstk,0);                                     28280000
        if <> then text(15):="A"; end; <<mark absent stacks>>           28285000
      if pcbentry(fr).xfr <> 0 then begin                               28290000
        len:=ascii(pcbentry(fr).xfr,8,btxt);                            28295000
        move text(21-len):=btxt(6-len),(len); end;                      28300000
      if pcbentry(son).xson <> 0 then begin                             28305000
        len:=ascii(pcbentry(son).xson,8,btxt);                          28310000
        move text(26-len):=btxt(6-len),(len); end;                      28315000
      if pcbentry(br).xbr <> 0 then begin                               28320000
        len:=ascii(pcbentry(br).xbr,8,btxt);                            28325000
        move text(31-len):=btxt(6-len),(len); end;                      28330000
      offset:=32;                                                       28335000
      if pcbentry(oa).xoa = 1 then text(offset):="F"                    28340000
      else if pcbentry(oa).xoa = 2 then text(offset):="S"               28345000
      else if pcbentry(oa).xoa = 3 then text(offset):="O";              28350000
      offset:=31;                                                       28355000
      ckbit(wake.m,offset+3,"M");                                       28360000
      ckbit(wake.rg,offset+4,"G");                                      28365000
      ckbit(wake.rl,offset+5,"L");                                      28370000
      ckbit(wake.ma,offset+6,"M");                                      28375000
      ckbit(wake.bio,offset+7,"B");                                     28380000
      ckbit(wake.io,offset+8,"I");                                      28385000
      ckbit(wake.ucop,offset+9,"U");                                    28390000
      ckbit(wake.junk,offset+10,"J");                                   28395000
      ckbit(wake.timer,offset+11,"T");                                  28400000
      ckbit(wake.msg,offset+12,"M");                                    28405000
      ckbit(wake.wson,offset+13,"S");                                   28410000
      ckbit(wake.fathr,offset+14,"F");                                  28415000
      ckbit(wake.imp,offset+15,"I");                                    28420000
      ckbit(wake.sir,offset+16,"S");                                    28425000
      ckbit(wake.tmout,offset+17,"T");                                  28430000
      ckbit(wake.mem,offset+18,"M");                                    28435000
                                                                        28440000
      len:=ascii(pcbentry(pri).xpri,-10,text(offset+22));               28445000
    <<move text(53-len):=btxt(6-len),(len);>>                           28450000
      if pcbentry(nimp).xnimp <> 0 then begin                           28455000
        len:=ascii(pcbentry(nimp).xnimp,8,btxt);                        28460000
        move text(offset+28-len):=btxt(6-len),(len); end;               28465000
      if pcbentry(pimp).xpimp <> 0 then begin                           28470000
        len:=ascii(pcbentry(pimp).xpimp,8,btxt);                        28475000
        move text(offset+33-len):=btxt(6-len),(len); end;               28480000
      offset:=61;                                                       28485000
      ckbit(pcbentry(crit).xcrit,offset+4,"C");                         28490000
      ckbit(pcbentry(hsir).xhsir,offset+5,"S");                         28495000
                                                                        28500000
      ckbit(pcbentry(hk).xhk,offset+7,"H");                             28505000
      ckbit(pcbentry(sk).xsk,offset+8,"S");                             28510000
      ckbit(pcbentry(st).xst,offset+9,"T");                             28515000
      ckbit(pcbentry(hb).xhb,offset+10,"H");                            28520000
      ckbit(pcbentry(cy).xcy,offset+11,"Y");                            28525000
      ckbit(pcbentry(bk).xbk,offset+12,"B");                            28530000
      ckbit(pcbentry(ritbk).xritbk,offset+13,"R");                      28535000
      ckbit(pcbentry(piovr).xpiovr,offset+14,"P");                      28540000
      ckbit(pcbentry(trw).xtrw,offset+16,"T");                          28545000
      ckbit(pcbentry(dispq).xdispq,offset+17,"D");                      28550000
                                                                        28555000
      write'rec(prntfile,ltxt,-79,0);                                   28560000
    end;                                                                28565000
    curradr:=curradr+double(pcbentsize);                                28570000
  end;  <<while stmt>>                                                  28575000
                                                                        28580000
end;  <<fmtpins4>>                                                      28585000
$page "                            PROCEDURE FMTPINS5"                  28590000
$control segment=idat5a                                                 28595000
<<**********************************************************>>          28600000
<<  fmtpins5                                                >>          28605000
<<---------------------------------------------------------->>          28610000
<<  this procedure will format all pins in the pcb table    >>          28615000
<<  and print a one line description about each.            >>          28620000
<<**********************************************************>>          28625000
                                                                        28630000
procedure fmtpins5(prntfile);                                           28635000
  value prntfile;                                                       28640000
  integer prntfile;                                                     28645000
                                                                        28650000
begin                                                                   28655000
                                                                        28660000
  logical array pcbentry(0:24),ltxt(0:39);                              28665000
  byte array text(*)=ltxt,btxt(0:5),dbtxt(0:11),ltr(0:0);               28670000
  integer pcbentsize,num,len,count,type,i,j,n,offset;                   28675000
  logical pin;                                                          28680000
  double pcbaddr,stopaddr,curradr;                                      28685000
  define                                                                28690000
                                                                        28695000
    <<process identification>>                                          28700000
      ptype=9#,xptype=(6:3)#,                                           28705000
                                                                        28710000
    <<data segments>>                                                   28715000
      xds=2#,xxds=(2:14)#,                                              28720000
      absdb=2#,xabsdb=(0:1)#,                                           28725000
      stk=3#,xstk=(2:14)#,                                              28730000
      oval=3#,xoval=(0:1)#,                                             28735000
                                                                        28740000
    <<family info>>                                                     28745000
      fr=5#,                                                            28750000
      son=6#,                                                           28755000
      br=7#,                                                            28760000
      oa=8#,xoa=(4:2)#,                                                 28765000
                                                                        28770000
    <<wakes and events>>                                                28775000
      wake=pcbentry(4)#,event=pcbentry(10)#,                            28780000
      m=(0:1)#,rg=(1:1)#,                                               28785000
      rl=(2:1)#,ma=(3:1)#,                                              28790000
      bio=(4:1)#,io=(5:1)#,                                             28795000
      ucop=(6:1)#,junk=(7:1)#,                                          28800000
      timer=(8:1)#,msg=(9:1)#,                                          28805000
      wson=(10:1)#,fathr=(11:1)#,                                       28810000
      imp=(12:1)#,sir=(13:1)#,                                          28815000
      tmout=(14:1)#,mem=(15:1)#,                                        28820000
                                                                        28825000
    <<resources>>                                                       28830000
      crit=0#,xcrit=(2:1)#,                                             28835000
      hsir=0#,xhsir=(3:1)#,                                             28840000
      sc=3#,xsc=(1:1)#,                                                 28845000
      nimp=17#,                                                         28850000
      pimp=16#,                                                         28855000
                                                                        28860000
    <<miscellaneous>>                                                   28865000
      bms=9#,xbms=(1:2)#,                                               28870000
      ppc=9#,xppc=(3:2)#,                                               28875000
      pcst=11#,xpcst=(0:32)#,                                           28880000
      pxpt=14#,xpxpt=(0:16)#,                                           28885000
      sl=1#,                                                            28890000
      bplk=18#,                                                         28895000
                                                                        28900000
    <<queue links>>                                                     28905000
      nqpn=19#,                                                         28910000
      pqpn=20#,                                                         28915000
                                                                        28920000
                                                                        28925000
    <<pseudo interrupts>>                                               28930000
      psim=8#,xpsim=(0:3)#,                                             28935000
      hk=9#,xhk=(10:1)#,                                                28940000
      sk=9#,xsk=(11:1)#,                                                28945000
      st=9#,xst=(12:1)#,                                                28950000
      hb=9#,xhb=(13:1)#,                                                28955000
      cy=9#,xcy=(14:1)#,                                                28960000
      bk=9#,xbk=(15:1)#,                                                28965000
      ritbk=0#,xritbk=(15:1)#,                                          28970000
      piovr=0#,xpiovr=(4:1)#,                                           28975000
                                                                        28980000
    <<life/death>>                                                      28985000
      live=9#,xlive=(0:1)#,                                             28990000
      dead=8#,xdead=(6:1)#,                                             28995000
      fac=8#,xfac=(7:1)#,                                               29000000
                                                                        29005000
    <<schedule information>>                                            29010000
      pri=13#,xpri=(8:8)#,                                              29015000
      dispq=13#,xdispq=(0:1)#,                                          29020000
      lq=13#,xlq=(1:1)#,                                                29025000
      cq=13#,xcq=(2:1)#,                                                29030000
      dq=13#,xdq=(3:1)#,                                                29035000
      eq=13#,xeq=(4:1)#,                                                29040000
      inter=13#,xinter=(5:1)#,                                          29045000
      corer=13#,xcorer=(6:1)#,                                          29050000
      hipri=0#,xhipri=(13:1)#,                                          29055000
      usedq=0#,xusedq=(12:1)#,                                          29060000
      trw=0#,xtrw=(11:1)#,                                              29065000
      sw=0#,xsw=(10:1)#,                                                29070000
      lw=0#,xlw=(9:1)#,                                                 29075000
      mp=0#,xmp=(8:1)#,                                                 29080000
      pc=0#,xpc=(7:1)#,                                                 29085000
      ipexp=0#,xipexp=(6:1)#,                                           29090000
      hspri=0#,xhspri=(5:1)#,                                           29095000
      sar=0#,xsar=(0:1)#,                                               29100000
      sov=9#,xsov=(5:1)#,                                               29105000
                                                                        29110000
      pcb'status=pcbentry(20)#,                                         29115000
      max'pcbs=pcbentry(0)#;                                            29120000
                                                                        29125000
  equate not'in'use = %177777;                                          29130000
                                                                        29135000
<<**************************************************>>                  29140000
<<checkbit                                          >>                  29145000
<<-------------------------------------------------->>                  29150000
<<this subroutine checks the bit sent via the bit   >>                  29155000
<<parameter, and if set, moves the letter passed    >>                  29160000
<<to the column specified in the array 'text'.      >>                  29165000
<<**************************************************>>                  29170000
                                                                        29175000
  subroutine ckbit(bit,col,ltr);                                        29180000
    value col,bit,ltr;                                                  29185000
    integer col;                                                        29190000
    logical bit;                                                        29195000
    byte ltr;                                                           29200000
                                                                        29205000
  begin                                                                 29210000
    if bit then text(col):=ltr;                                         29215000
  end;  <<ckbit>>                                                       29220000
                                                                        29225000
  pcbaddr:=getdstaddr(3);                                               29230000
                                                                        29235000
  pcbentsize:=%25;                                                      29240000
  getcore(pcbaddr,pcbentsize,pcbentry);                                 29245000
  if <> then return;                                                    29250000
  stopaddr:=pcbaddr+double(max'pcbs*logical(pcbentsize));               29255000
                                                                        29260000
  curradr:=pcbaddr+double(pcbentsize);                                  29265000
                                                                        29270000
  move buf:=("                                          T  ",           29275000
             "F  T                         RP  D"),2;                   29280000
  i:=tos-@buf;                                                          29285000
  write'rec(prntfile,lbuf,-i,0);                                        29290000
  move buf:=("               V                        UJI  ",           29295000
             "A  M                CH       II  I"),2;                   29300000
  i:=tos-@buf;                                                          29305000
  write'rec(prntfile,lbuf,-i,0);                                        29310000
  move buf:=("               I                      B CUMMS",           29315000
             "TISOM     PREV NEXT RS       TO TS"),2;                   29320000
  i:=tos-@buf;                                                          29325000
  write'rec(prntfile,lbuf,-i,0);                                        29330000
  move buf:=("               R FTHR  SON  BRO O  RRMIIONESO",           29335000
             "HMIUE     IMPD IMPD II HSSHCBBV RP"),2;                   29340000
  i:=tos-@buf;                                                          29345000
  write'rec(prntfile,lbuf,-i,0);                                        29350000
  move buf:=("PIN    XDS  STKT  PIN  PIN  PIN A MGLAOOPKRGN",           29355000
             "RPRTM PRI  PIN  PIN TR KKTBYKKR WQ"),2;                   29360000
  i:=tos-@buf;                                                          29365000
  write'rec(prntfile,lbuf,-i,0);                                        29370000
                                                                        29375000
  while curradr < stopaddr and not stop'print do begin                  29380000
    if ctrly then begin                                                 29385000
      write'rec(prntfile,ltxt,0,0);                                     29390000
      move text:=" <CONTROL-Y>";                                        29395000
      write'rec(prntfile,ltxt,-12,%60);                                 29400000
      return;                                                           29405000
    end;                                                                29410000
    getcore(curradr,pcbentsize,pcbentry);                               29415000
    if <> then return;                                                  29420000
    if pcb'status <> not'in'use then begin                              29425000
      move text:=" "; move text(1):=text,(79);                          29430000
      pin:=logical((curradr-pcbaddr)/21d);                              29435000
      len:=ascii(pin,8,btxt);                                           29440000
      move text(4-len):=btxt(6-len),(len);                              29445000
      if current(pin) then move text(4):="*";                           29450000
      if pcbentry(xds).xxds <> 0 then begin                             29455000
        len:=ascii(pcbentry(xds).xxds,8,btxt);                          29460000
        move text(10-len):=btxt(6-len),(len); end;                      29465000
      if pcbentry(stk).xstk <> 0 then begin                             29470000
        len:=ascii(pcbentry(stk).xstk,8,btxt);                          29475000
        move text(15-len):=btxt(6-len),(len);                           29480000
        lfds(pcbentry(stk).xstk,0);                                     29485000
        if <> then text(15):="A"   <<mark absent stacks>>               29490000
        else if vm'inuse and                                            29495000
          getdstaddr(pcbentry(stk).xstk) >                              29500000
            max'real'mem  then text(15):="V"; end;                      29505000
      if pcbentry(fr) <> 0 then begin                                   29510000
        len:=ascii(pcbentry(fr)/21,8,btxt);                             29515000
        move text(21-len):=btxt(6-len),(len); end;                      29520000
      if pcbentry(son) <> 0 then begin                                  29525000
        len:=ascii(pcbentry(son)/21,8,btxt);                            29530000
        move text(26-len):=btxt(6-len),(len); end;                      29535000
      if pcbentry(br) <> 0 then begin                                   29540000
        len:=ascii(pcbentry(br)/21,8,btxt);                             29545000
        move text(31-len):=btxt(6-len),(len); end;                      29550000
      offset:=32;                                                       29555000
      if pcbentry(oa).xoa = 1 then text(offset):="F"                    29560000
      else if pcbentry(oa).xoa = 2 then text(offset):="S"               29565000
      else if pcbentry(oa).xoa = 3 then text(offset):="O";              29570000
      offset:=31;                                                       29575000
      ckbit(wake.m,offset+3,"M");                                       29580000
      ckbit(wake.rg,offset+4,"G");                                      29585000
      ckbit(wake.rl,offset+5,"L");                                      29590000
      ckbit(wake.ma,offset+6,"M");                                      29595000
      ckbit(wake.bio,offset+7,"B");                                     29600000
      ckbit(wake.io,offset+8,"I");                                      29605000
      ckbit(wake.ucop,offset+9,"U");                                    29610000
      ckbit(wake.junk,offset+10,"J");                                   29615000
      ckbit(wake.timer,offset+11,"T");                                  29620000
      ckbit(wake.msg,offset+12,"M");                                    29625000
      ckbit(wake.wson,offset+13,"S");                                   29630000
      ckbit(wake.fathr,offset+14,"F");                                  29635000
      ckbit(wake.imp,offset+15,"I");                                    29640000
      ckbit(wake.sir,offset+16,"S");                                    29645000
      ckbit(wake.tmout,offset+17,"T");                                  29650000
      ckbit(wake.mem,offset+18,"M");                                    29655000
                                                                        29660000
      len:=ascii(pcbentry(pri).xpri,-10,text(offset+22));               29665000
    <<move text(53-len):=btxt(6-len),(len);>>                           29670000
      if pcbentry(nimp) <> 0 then begin                                 29675000
        len:=ascii(pcbentry(nimp)/21,8,btxt);                           29680000
        move text(offset+28-len):=btxt(6-len),(len); end;               29685000
      if pcbentry(pimp) <> 0 then begin                                 29690000
        len:=ascii(pcbentry(pimp)/21,8,btxt);                           29695000
        move text(offset+33-len):=btxt(6-len),(len); end;               29700000
      offset:=61;                                                       29705000
      ckbit(pcbentry(crit).xcrit,offset+4,"C");                         29710000
      ckbit(pcbentry(hsir).xhsir,offset+5,"S");                         29715000
                                                                        29720000
      ckbit(pcbentry(hk).xhk,offset+7,"H");                             29725000
      ckbit(pcbentry(sk).xsk,offset+8,"S");                             29730000
      ckbit(pcbentry(st).xst,offset+9,"T");                             29735000
      ckbit(pcbentry(hb).xhb,offset+10,"H");                            29740000
      ckbit(pcbentry(cy).xcy,offset+11,"Y");                            29745000
      ckbit(pcbentry(bk).xbk,offset+12,"B");                            29750000
      ckbit(pcbentry(ritbk).xritbk,offset+13,"R");                      29755000
      ckbit(pcbentry(piovr).xpiovr,offset+14,"P");                      29760000
      ckbit(pcbentry(trw).xtrw,offset+16,"T");                          29765000
      ckbit(pcbentry(dispq).xdispq,offset+17,"D");                      29770000
                                                                        29775000
      write'rec(prntfile,ltxt,-79,0);                                   29780000
    end;                                                                29785000
    curradr:=curradr+double(pcbentsize);                                29790000
  end;  <<while stmt>>                                                  29795000
                                                                        29800000
end;  <<fmtpins5>>                                                      29805000
$control segment=idat5                                                  29810000
$page "              PROCEDURE PRNTCIP4"                                29815000
<<***********************************************************>>  <<nsf>>29820000
<<  prntcip4                                                 >>  <<nsf>>29825000
<<----------------------------------------------------------->>  <<nsf>>29830000
<< this procedure will take a pcb entry and attmpt to        >>  <<nsf>>29835000
<< find the associated stack.  if found, it will format the  >>  <<nsf>>29840000
<< db+01 area as the image of the last command typed in by   >>  <<nsf>>29845000
<< the owner of the pcb.                                     >>  <<nsf>>29850000
<<***********************************************************>>  <<nsf>>29855000
                                                                 <<nsf>>29860000
procedure prntcip4(prntfile,addr);                               <<nsf>>29865000
  value prntfile,addr;                                           <<nsf>>29870000
  integer prntfile,addr;                                       <<dougw>>29875000
                                                                 <<nsf>>29880000
  begin                                                          <<nsf>>29885000
    equate  pcbdst = 3;                                        <<dougw>>29890000
                                                               <<dougw>>29895000
                                                                 <<nsf>>29900000
    define  unassigned=buffer(0)#,                               <<nsf>>29905000
            pcb'stk'no=buffer(3).(1:10)#,                        <<nsf>>29910000
             pcb'alive=buffer(9).(0:1)#,                         <<nsf>>29915000
              pcb'type=buffer(9).(6:3)#;                         <<nsf>>29920000
                                                                 <<nsf>>29925000
    define  job'in'dev=wrk'buf(3).(8:8)#,                        <<nsf>>29930000
           job'out'dev=wrk'buf(4).(8:8)#,                        <<nsf>>29935000
             proc'type=wrk'buf(6).(2:2)#;                        <<nsf>>29940000
                                                                 <<nsf>>29945000
    integer pin,n,ii,numchar,outchar,stk'dst,temp'addr;        <<dougw>>29950000
    logical array buffer(0:37);                                  <<nsf>>29955000
    byte array bufferb(*)=buffer;                                <<nsf>>29960000
    logical array buf'wrk'l(0:2);                                <<nsf>>29965000
    byte array buf'wrk(*)=buf'wrk'l;                             <<nsf>>29970000
    logical array wrk'buf(0:34);                                 <<nsf>>29975000
    byte array wrk'bufb(*)=wrk'buf;                              <<nsf>>29980000
                                                                 <<nsf>>29985000
                                                                 <<nsf>>29990000
    equate entry'length=16,                                      <<nsf>>29995000
             free'entry=%100000,                                 <<nsf>>30000000
                session=1,                                       <<nsf>>30005000
                    job=2,                                       <<nsf>>30010000
              user'main=2,                                       <<nsf>>30015000
         user'main'task=3;                                       <<nsf>>30020000
                                                                 <<nsf>>30025000
    mfds (buffer, pcbdst, addr, entry'length);                 <<dougw>>30030000
    if <> then return;                                           <<nsf>>30035000
                                                                 <<nsf>>30040000
    if unassigned=free'entry then return;                        <<nsf>>30045000
    if pcb'type <> user'main or pcb'alive <> 1                   <<nsf>>30050000
    then return;                                                 <<nsf>>30055000
    move buf(0):=" "; move buf(1):=buf,(79);                     <<nsf>>30060000
    move buf:="#";                                               <<nsf>>30065000
    pin := addr / 16;                                          <<dougw>>30070000
    ascii(pin,8,buf'wrk);                                        <<nsf>>30075000
    for ii:=0 until 5 do begin                                   <<nsf>>30080000
      if buf'wrk(ii)<>"0" then go digit;                         <<nsf>>30085000
    end;                                                         <<nsf>>30090000
                                                                 <<nsf>>30095000
    digit:  outchar:=6-ii;                                       <<nsf>>30100000
    move buf(5+ii):=buf'wrk(ii),(outchar);                       <<nsf>>30105000
                                                                 <<nsf>>30110000
      stk'dst:=getstackdst(pin);                                 <<nsf>>30115000
      ascii(stk'dst,8,buf'wrk);                                  <<nsf>>30120000
      for ii:=0 until 5 do begin                                 <<nsf>>30125000
        if buf'wrk(ii)<>"0" then go digit2;                      <<nsf>>30130000
      end;                                                       <<nsf>>30135000
      digit2:  outchar:=6-ii;                                    <<nsf>>30140000
      move buf(11+ii):=buf'wrk(ii),(outchar);                    <<nsf>>30145000
                                                                 <<nsf>>30150000
      mfds (wrk'buf, stk'dst, 0, 16);                          <<dougw>>30155000
      if <> then  move buf(37):="*** UNAVAILABLE SEGMENT ***"  <<dougw>>30160000
      else begin                                                 <<nsf>>30165000
        if proc'type=session then begin                          <<nsf>>30170000
          ascii(job'in'dev,10,buf(20));                          <<nsf>>30175000
          ascii(job'out'dev,10,buf(26));                         <<nsf>>30180000
        end;                                                     <<nsf>>30185000
        if proc'type=session then                                <<nsf>>30190000
          move buf(1):="S???" else                               <<nsf>>30195000
          if proc'type=job then                                  <<nsf>>30200000
            move buf(1):="J???";                                 <<nsf>>30205000
        temp'addr := lfds (stk'dst, 1) + 1;                    <<dougw>>30210000
        numchar:=0;                                            <<dougw>>30215000
        mfds (wrk'buf, stk'dst, temp'addr, 35);                <<dougw>>30220000
        while numchar < 41 do                                  <<dougw>>30225000
          begin                                                <<dougw>>30230000
            if wrk'bufb (numchar) <> %15 then                  <<dougw>>30235000
              begin                                            <<dougw>>30240000
                move buf(37+numchar):=wrk'bufb(numchar),(1);   <<dougw>>30245000
                numchar := numchar + 1;                        <<dougw>>30250000
              end                                              <<dougw>>30255000
            else                                               <<dougw>>30260000
              begin                                            <<dougw>>30265000
                <<force end of loop>>                          <<dougw>>30270000
                numchar := numchar + 41;                       <<dougw>>30275000
              end;                                             <<dougw>>30280000
          end;                                                 <<dougw>>30285000
                                                                 <<nsf>>30290000
    end;                                                         <<nsf>>30295000
                                                                 <<nsf>>30300000
    write'rec(prntfile,lbuf,-79,0);                                     30305000
end;  <<prntcip4>>                                               <<nsf>>30310000
$page "               PROCEDURE PRNTCIP5"                        <<nsf>>30315000
<<***********************************************************>>  <<nsf>>30320000
<<  prntcip5                                                 >>  <<nsf>>30325000
<<----------------------------------------------------------->>  <<nsf>>30330000
<< this procedure will take a pcb entry and attmpt to        >>  <<nsf>>30335000
<< find the associated stack.  if found, it will format the  >>  <<nsf>>30340000
<< db+01 area as the image of the last command typed in by   >>  <<nsf>>30345000
<< the owner of the pcb.                                     >>  <<nsf>>30350000
<<***********************************************************>>  <<nsf>>30355000
                                                                 <<nsf>>30360000
procedure prntcip5(prntfile,addr);                               <<nsf>>30365000
  value prntfile,addr;                                           <<nsf>>30370000
  integer prntfile,addr;                                       <<dougw>>30375000
                                                                 <<nsf>>30380000
  begin                                                          <<nsf>>30385000
                                                                 <<nsf>>30390000
    equate  pcbdst = 3;                                        <<dougw>>30395000
                                                               <<dougw>>30400000
    define  unassigned=buffer(20)#,                              <<nsf>>30405000
            pcb'stk'no=buffer(3).(2:14)#,                        <<nsf>>30410000
             pcb'alive=buffer(9).(0:1)#,                         <<nsf>>30415000
              pcb'type=buffer(9).(6:3)#;                         <<nsf>>30420000
                                                                 <<nsf>>30425000
    define  job'in'dev=wrk'buf(8)#,                              <<nsf>>30430000
           job'out'dev=wrk'buf(9)#,                              <<nsf>>30435000
             proc'type=wrk'buf(6).(2:2)#;                        <<nsf>>30440000
                                                                 <<nsf>>30445000
    integer pin,n,ii,numchar,outchar,stk'dst,temp'addr;        <<dougw>>30450000
    logical array buffer(0:37);                                  <<nsf>>30455000
    byte array bufferb(*)=buffer;                                <<nsf>>30460000
    logical array buf'wrk'l(0:2);                                <<nsf>>30465000
    byte array buf'wrk(*)=buf'wrk'l;                             <<nsf>>30470000
    logical array wrk'buf(0:34);                                 <<nsf>>30475000
    byte array wrk'bufb(*)=wrk'buf;                              <<nsf>>30480000
                                                                 <<nsf>>30485000
                                                                 <<nsf>>30490000
    equate entry'length=16,                                      <<nsf>>30495000
             free'entry=%177777,                                 <<nsf>>30500000
                session=1,                                       <<nsf>>30505000
                    job=2,                                       <<nsf>>30510000
              user'main=2,                                       <<nsf>>30515000
         user'main'task=3;                                       <<nsf>>30520000
                                                                 <<nsf>>30525000
    mfds (buffer, pcbdst, addr, entry'length);                 <<dougw>>30530000
    if <> then return;                                           <<nsf>>30535000
                                                                 <<nsf>>30540000
    if unassigned=free'entry then return;                        <<nsf>>30545000
    if pcb'type <> user'main or pcb'alive <> 1                   <<nsf>>30550000
    then return;                                                 <<nsf>>30555000
    move buf(0):=" "; move buf(1):=buf,(79);                     <<nsf>>30560000
    move buf:="#????";                                           <<nsf>>30565000
    pin := addr / 21;                                          <<dougw>>30570000
    ascii(pin,8,buf'wrk);                                        <<nsf>>30575000
    for ii:=0 until 5 do begin                                   <<nsf>>30580000
      if buf'wrk(ii)<>"0" then go digit;                         <<nsf>>30585000
    end;                                                         <<nsf>>30590000
                                                                 <<nsf>>30595000
    digit:  outchar:=6-ii;                                       <<nsf>>30600000
    move buf(5+ii):=buf'wrk(ii),(outchar);                       <<nsf>>30605000
                                                                 <<nsf>>30610000
      stk'dst:=getstackdst(pin);                                 <<nsf>>30615000
      ascii(stk'dst,8,buf'wrk);                                  <<nsf>>30620000
      for ii:=0 until 5 do begin                                 <<nsf>>30625000
        if buf'wrk(ii)<>"0" then go digit2;                      <<nsf>>30630000
      end;                                                       <<nsf>>30635000
      digit2:  outchar:=6-ii;                                    <<nsf>>30640000
      move buf(11+ii):=buf'wrk(ii),(outchar);                    <<nsf>>30645000
      if vm'inuse and getdstaddr(stk'dst) >= vm'min then                30650000
        buf(17) := "V";                                                 30655000
                                                                 <<nsf>>30660000
      mfds (wrk'buf, stk'dst, 0, 16);                          <<dougw>>30665000
      if <> then  move buf(37):="*** UNAVAILABLE SEGMENT ***"  <<dougw>>30670000
      else begin                                                 <<nsf>>30675000
        if proc'type=session then begin                          <<nsf>>30680000
          ascii(job'in'dev,10,buf(20));                          <<nsf>>30685000
          ascii(job'out'dev,10,buf(26));                         <<nsf>>30690000
        end;                                                     <<nsf>>30695000
        if proc'type=session then                                <<nsf>>30700000
          move buf(1):="S???" else                               <<nsf>>30705000
          if proc'type=job then                                  <<nsf>>30710000
            move buf(1):="J???";                                 <<nsf>>30715000
        temp'addr := lfds (stk'dst, 1) + 1;                    <<dougw>>30720000
        numchar:=0;                                            <<dougw>>30725000
        mfds (wrk'buf, stk'dst, temp'addr, 35);                <<dougw>>30730000
        while numchar < 41 do                                  <<dougw>>30735000
          begin                                                <<dougw>>30740000
            if wrk'bufb (numchar) <> %15 then                  <<dougw>>30745000
              begin                                            <<dougw>>30750000
                move buf(37+numchar):=wrk'bufb(numchar),(1);   <<dougw>>30755000
                numchar := numchar + 1;                        <<dougw>>30760000
              end                                              <<dougw>>30765000
            else                                               <<dougw>>30770000
              begin                                            <<dougw>>30775000
                <<force end of loop>>                          <<dougw>>30780000
                numchar := numchar + 41;                       <<dougw>>30785000
              end;                                             <<dougw>>30790000
          end;                                                 <<dougw>>30795000
                                                                 <<nsf>>30800000
    end;                                                         <<nsf>>30805000
                                                                 <<nsf>>30810000
    write'rec(prntfile,lbuf,-79,0);                                     30815000
                                                                 <<nsf>>30820000
end;  <<prntcip5>>                                               <<nsf>>30825000
$page "                         PROCEDURE PRNTCI4"                      30830000
$control segment=idat5                                                  30835000
<<***********************************************************>>  <<nsf>>30840000
<<  prntci4                                                  >>  <<nsf>>30845000
<<----------------------------------------------------------->>  <<nsf>>30850000
<< this procedure will take a jmat entry and attempt to      >>  <<nsf>>30855000
<< find the associated stack.  if found, it will format the  >>  <<nsf>>30860000
<< db+01 area as the image of the last command typed in by   >>  <<nsf>>30865000
<< the owner of the pcb.                                     >>  <<nsf>>30870000
<<***********************************************************>>  <<nsf>>30875000
                                                                 <<nsf>>30880000
procedure prntci4(prntfile,addr);                                <<nsf>>30885000
  value prntfile,addr;                                           <<nsf>>30890000
  integer prntfile,addr;                                       <<dougw>>30895000
                                                                 <<nsf>>30900000
  begin                                                          <<nsf>>30905000
                                                                 <<nsf>>30910000
  equate   jmatdst = 25;                                       <<dougw>>30915000
                                                               <<dougw>>30920000
    define   jmat'type=buffer(1).(0:2)#,                         <<nsf>>30925000
           jmat'number=buffer(1).(2:14)#,                        <<nsf>>30930000
         jmat'main'pin=buffer(22).(0:8)#,                        <<nsf>>30935000
            jmat'state=buffer(0).(0:6)#;                         <<nsf>>30940000
                                                                 <<nsf>>30945000
    integer n,ii,numchar,outchar,stk'dst,temp'addr;            <<dougw>>30950000
    logical array buffer(0:37);                                  <<nsf>>30955000
    byte array bufferb(*)=buffer;                                <<nsf>>30960000
    logical array pcbbuf(0:20);                                  <<nsf>>30965000
    logical array buf'wrk'l(0:2);                                <<nsf>>30970000
    byte array buf'wrk(*)=buf'wrk'l;                             <<nsf>>30975000
    logical array wrk'buf(0:34);                                 <<nsf>>30980000
    byte array wrk'bufb(*)=wrk'buf;                              <<nsf>>30985000
                                                                 <<nsf>>30990000
    equate entry'length=26,                                      <<nsf>>30995000
             free'entry=0,                                       <<nsf>>31000000
                session=1,                                       <<nsf>>31005000
                    job=2,                                       <<nsf>>31010000
            user'name'b=4,                                       <<nsf>>31015000
            user'name'e=11,                                      <<nsf>>31020000
            acct'name'b=12,                                      <<nsf>>31025000
            acct'name'e=19;                                      <<nsf>>31030000
                                                                 <<nsf>>31035000
    mfds (buffer, jmatdst, addr, entry'length);                <<dougw>>31040000
                                                                 <<nsf>>31045000
    if <> then return;                                           <<nsf>>31050000
                                                                 <<nsf>>31055000
    if jmat'state=free'entry then return;                        <<nsf>>31060000
                                                                 <<nsf>>31065000
    move buf(0):=" "; move buf(1):=buf,(79);                     <<nsf>>31070000
    move buf:="#";                                               <<nsf>>31075000
    if jmat'type=session then move buf(1):="S"                   <<nsf>>31080000
    else move buf(1):="J";                                       <<nsf>>31085000
    ascii(jmat'number,10,buf(2));                                <<nsf>>31090000
    ascii(jmat'main'pin,8,buf'wrk);                              <<nsf>>31095000
    for ii:=0 until 5 do begin                                   <<nsf>>31100000
      if buf'wrk(ii)<>"0" then go digit;                         <<nsf>>31105000
    end;                                                         <<nsf>>31110000
                                                                 <<nsf>>31115000
    digit:  outchar:=6-ii;                                       <<nsf>>31120000
    move buf(5+ii):=buf'wrk(ii),(outchar);                       <<nsf>>31125000
                                                                 <<nsf>>31130000
    numchar:=0; outchar:=19;                                     <<nsf>>31135000
    for ii:=user'name'b until user'name'e do begin               <<nsf>>31140000
      if bufferb(ii)<>" " then numchar:=numchar+1;               <<nsf>>31145000
    end;                                                         <<nsf>>31150000
    if numchar>0 then begin                                      <<nsf>>31155000
      move buf(outchar):=bufferb(user'name'b),(numchar);         <<nsf>>31160000
      outchar:=outchar+numchar+1;                                <<nsf>>31165000
      move buf(outchar-1):=".";                                  <<nsf>>31170000
    end;                                                         <<nsf>>31175000
    numchar:=0;                                                  <<nsf>>31180000
    for ii:=acct'name'b until acct'name'e do begin               <<nsf>>31185000
      if bufferb(ii)<>" " then numchar:=numchar+1;               <<nsf>>31190000
    end;                                                         <<nsf>>31195000
    if numchar>0 then begin                                      <<nsf>>31200000
      move buf(outchar):=bufferb(acct'name'b),(numchar);         <<nsf>>31205000
    end;                                                         <<nsf>>31210000
                                                                 <<nsf>>31215000
    if jmat'main'pin <> 0 then begin                             <<nsf>>31220000
      stk'dst:=getstackdst(jmat'main'pin);                       <<nsf>>31225000
      ascii(stk'dst,8,buf'wrk);                                  <<nsf>>31230000
      for ii:=0 until 5 do begin                                 <<nsf>>31235000
        if buf'wrk(ii)<>"0" then go digit2;                      <<nsf>>31240000
      end;                                                       <<nsf>>31245000
      digit2:  outchar:=6-ii;                                    <<nsf>>31250000
      move buf(11+ii):=buf'wrk(ii),(outchar);                    <<nsf>>31255000
                                                                 <<nsf>>31260000
      temp'addr := lfds (stk'dst, 1) + 1;                      <<dougw>>31265000
      numchar:=0;                                              <<dougw>>31270000
      mfds (wrk'buf, stk'dst, temp'addr, 35);                  <<dougw>>31275000
      if <> then                                               <<dougw>>31280000
         move buf(37) := "*** UNAVAILABLE SEGMENT ***"         <<dougw>>31285000
      else                                                     <<dougw>>31290000
        while numchar < 41 do                                  <<dougw>>31295000
          begin                                                <<dougw>>31300000
            if wrk'bufb (numchar) <> %15 then                  <<dougw>>31305000
              begin                                            <<dougw>>31310000
                move buf(37+numchar):=wrk'bufb(numchar),(1);   <<dougw>>31315000
                numchar := numchar + 1;                        <<dougw>>31320000
              end                                              <<dougw>>31325000
            else                                               <<dougw>>31330000
              begin                                            <<dougw>>31335000
                <<force end of loop>>                          <<dougw>>31340000
                numchar := numchar + 41;                       <<dougw>>31345000
              end;                                             <<dougw>>31350000
          end;                                                 <<dougw>>31355000
    end;                                                         <<nsf>>31360000
                                                                 <<nsf>>31365000
    write'rec(prntfile,lbuf,-79,0);                                     31370000
                                                                 <<nsf>>31375000
end;  <<prntci4>>                                                <<nsf>>31380000
$page "                       PROCEDURE PRNTCI5"                        31385000
<<***********************************************************>>  <<nsf>>31390000
<<  prntci5                                                  >>  <<nsf>>31395000
<<----------------------------------------------------------->>  <<nsf>>31400000
<< this procedure will take a jmat entry and attempt to      >>  <<nsf>>31405000
<< find the associated stack.  if found, it will format the  >>  <<nsf>>31410000
<< db+01 area as the image of the last command typed in by   >>  <<nsf>>31415000
<< the owner of the pcb.                                     >>  <<nsf>>31420000
<<***********************************************************>>  <<nsf>>31425000
                                                                 <<nsf>>31430000
procedure prntci5(prntfile,addr);                                <<nsf>>31435000
  value prntfile,addr;                                           <<nsf>>31440000
  integer prntfile,addr;                                       <<dougw>>31445000
                                                                 <<nsf>>31450000
  begin                                                          <<nsf>>31455000
                                                                 <<nsf>>31460000
  equate   jmatdst = 25;                                       <<dougw>>31465000
                                                               <<dougw>>31470000
    define   jmat'type=buffer(1).(0:2)#,                         <<nsf>>31475000
           jmat'number=buffer(1).(2:14)#,                        <<nsf>>31480000
         jmat'main'pin=buffer(25)#,                              <<nsf>>31485000
            jmat'state=buffer(0).(0:6)#;                         <<nsf>>31490000
                                                                 <<nsf>>31495000
    integer n,ii,numchar,outchar,stk'dst,temp'addr;            <<dougw>>31500000
    logical array buffer(0:37);                                  <<nsf>>31505000
    byte array bufferb(*)=buffer;                                <<nsf>>31510000
    logical array pcbbuf(0:20);                                  <<nsf>>31515000
    logical array buf'wrk'l(0:2);                                <<nsf>>31520000
    byte array buf'wrk(*)=buf'wrk'l;                             <<nsf>>31525000
    logical array wrk'buf(0:34);                                 <<nsf>>31530000
    byte array wrk'bufb(*)=wrk'buf;                              <<nsf>>31535000
                                                                 <<nsf>>31540000
    equate entry'length=38,                                      <<nsf>>31545000
             free'entry=0,                                       <<nsf>>31550000
                session=1,                                       <<nsf>>31555000
                    job=2,                                       <<nsf>>31560000
            user'name'b=6,                                       <<nsf>>31565000
            user'name'e=13,                                      <<nsf>>31570000
            acct'name'b=14,                                      <<nsf>>31575000
            acct'name'e=21;                                      <<nsf>>31580000
                                                                 <<nsf>>31585000
    mfds (buffer, jmatdst, addr, entry'length);                <<dougw>>31590000
                                                                 <<nsf>>31595000
    if <> then return;                                           <<nsf>>31600000
                                                                 <<nsf>>31605000
    if jmat'state=free'entry then return;                        <<nsf>>31610000
                                                                 <<nsf>>31615000
    move buf(0):=" "; move buf(1):=buf,(79);                     <<nsf>>31620000
    move buf:="#";                                               <<nsf>>31625000
    if jmat'type=session then move buf(1):="S"                   <<nsf>>31630000
    else move buf(1):="J";                                       <<nsf>>31635000
    ascii(jmat'number,10,buf(2));                                <<nsf>>31640000
    ascii(jmat'main'pin,8,buf'wrk);                              <<nsf>>31645000
    for ii:=0 until 5 do begin                                   <<nsf>>31650000
      if buf'wrk(ii)<>"0" then go digit;                         <<nsf>>31655000
    end;                                                         <<nsf>>31660000
                                                                 <<nsf>>31665000
    digit:  outchar:=6-ii;                                       <<nsf>>31670000
    move buf(5+ii):=buf'wrk(ii),(outchar);                       <<nsf>>31675000
                                                                 <<nsf>>31680000
    numchar:=0; outchar:=19;                                     <<nsf>>31685000
    for ii:=user'name'b until user'name'e do begin               <<nsf>>31690000
      if bufferb(ii)<>" " then numchar:=numchar+1;               <<nsf>>31695000
    end;                                                         <<nsf>>31700000
    if numchar>0 then begin                                      <<nsf>>31705000
      move buf(outchar):=bufferb(user'name'b),(numchar);         <<nsf>>31710000
      outchar:=outchar+numchar+1;                                <<nsf>>31715000
      move buf(outchar-1):=".";                                  <<nsf>>31720000
    end;                                                         <<nsf>>31725000
    numchar:=0;                                                  <<nsf>>31730000
    for ii:=acct'name'b until acct'name'e do begin               <<nsf>>31735000
      if bufferb(ii)<>" " then numchar:=numchar+1;               <<nsf>>31740000
    end;                                                         <<nsf>>31745000
    if numchar>0 then begin                                      <<nsf>>31750000
      move buf(outchar):=bufferb(acct'name'b),(numchar);         <<nsf>>31755000
    end;                                                         <<nsf>>31760000
                                                                 <<nsf>>31765000
    if jmat'main'pin <> 0 then begin                             <<nsf>>31770000
      stk'dst:=getstackdst(jmat'main'pin);                       <<nsf>>31775000
      ascii(stk'dst,8,buf'wrk);                                  <<nsf>>31780000
      for ii:=0 until 5 do begin                                 <<nsf>>31785000
        if buf'wrk(ii)<>"0" then go digit2;                      <<nsf>>31790000
      end;                                                       <<nsf>>31795000
      digit2:  outchar:=6-ii;                                    <<nsf>>31800000
      move buf(11+ii):=buf'wrk(ii),(outchar);                    <<nsf>>31805000
      if vm'inuse and getdstaddr(stk'dst) >= vm'min  then               31810000
        buf(11+ii+outchar) := "V";                                      31815000
                                                                 <<nsf>>31820000
      temp'addr := lfds (stk'dst, 1) + 1;                      <<dougw>>31825000
      numchar:=0;                                              <<dougw>>31830000
      mfds (wrk'buf, stk'dst, temp'addr, 35);                  <<dougw>>31835000
      if <> then                                               <<dougw>>31840000
         move buf(37) := "*** UNAVAILABLE SEGMENT ***"         <<dougw>>31845000
      else                                                     <<dougw>>31850000
        while numchar < 41 do                                  <<dougw>>31855000
          begin                                                <<dougw>>31860000
            if wrk'bufb (numchar) <> %15 then                  <<dougw>>31865000
              begin                                            <<dougw>>31870000
                move buf(37+numchar):=wrk'bufb(numchar),(1);   <<dougw>>31875000
                numchar := numchar + 1;                        <<dougw>>31880000
              end                                              <<dougw>>31885000
            else                                               <<dougw>>31890000
              begin                                            <<dougw>>31895000
                <<force end of loop>>                          <<dougw>>31900000
                numchar := numchar + 41;                       <<dougw>>31905000
              end;                                             <<dougw>>31910000
          end;                                                 <<dougw>>31915000
    end;                                                         <<nsf>>31920000
                                                                 <<nsf>>31925000
    write'rec(prntfile,lbuf,-79,0);                                     31930000
                                                                 <<nsf>>31935000
end;  <<prntci5>>                                                <<nsf>>31940000
$page "                       PROCEDURE FMTCIS "                        31945000
<<***********************************************************>>  <<nsf>>31950000
<<  fmtcis                                                   >>  <<nsf>>31955000
<<----------------------------------------------------------->>  <<nsf>>31960000
<< this procedure will format all 'user main' type processes'>>  <<nsf>>31965000
<< stack areas to show the last command entered.             >>  <<nsf>>31970000
<<***********************************************************>>  <<nsf>>31975000
                                                                 <<nsf>>31980000
procedure fmtcis(prntfile);                                      <<nsf>>31985000
                                                                 <<nsf>>31990000
  value prntfile;                                                <<nsf>>31995000
  integer prntfile;                                              <<nsf>>32000000
                                                                 <<nsf>>32005000
  begin                                                          <<nsf>>32010000
                                                                 <<nsf>>32015000
  double locdst;                                               <<dougw>>32020000
  integer lenjmat,tot'jmat'words,pcbentsize,current,stopindx;  <<dougw>>32025000
                                                                 <<nsf>>32030000
  logical jmat'ent'size;                                         <<nsf>>32035000
                                                                 <<nsf>>32040000
  logical array buf0(0:37);                                      <<nsf>>32045000
  define cc=status.(6:2)#;                                       <<nsf>>32050000
                                                                 <<nsf>>32055000
  define   jmatmax=buf0(0).(0:8)#,                               <<nsf>>32060000
          jcursize=buf0(0).(8:8)#,                               <<nsf>>32065000
        jmat'esize=buf0(1).(8:8)#,                               <<nsf>>32070000
      jmat'ent'ptr=buf0(2)#,                                     <<nsf>>32075000
        jmat'stype=buf0(5).(0:2)#;                               <<nsf>>32080000
                                                                 <<nsf>>32085000
  equate   jmatdst = 25,                                       <<dougw>>32090000
            pcbdst = 3;                                        <<dougw>>32095000
                                                               <<dougw>>32100000
  define   pcb'num'ents=buf0(0)#,                                <<nsf>>32105000
           pcb'ent'size=buf0(1)#;                                <<nsf>>32110000
                                                                 <<nsf>>32115000
  jmat'ent'size:=26+(mpeversion-4)*12;                           <<nsf>>32120000
  locdst:=double(core(2d));                                      <<nsf>>32125000
                                                                 <<nsf>>32130000
  lfds(jmatdst,0); << check if dst available >>                <<dougw>>32135000
  if <> then go pcbmethod;                                       <<nsf>>32140000
                                                                 <<nsf>>32145000
  move buf(0):=" ";                                              <<nsf>>32150000
  move buf(1):=buf,(79);                                         <<nsf>>32155000
  move buf:="JOBNUM UMAIN STACK JOBNAME           LAST COMMAND"; <<nsf>>32160000
  write'rec(prntfile,lbuf,-79,0);                                       32165000
  move buf(0):=" ";                                              <<nsf>>32170000
  move buf(1):=buf,(45);                                         <<nsf>>32175000
  move buf(8):="PIN#  DST#";                                     <<nsf>>32180000
  write'rec(prntfile,lbuf,-20,0);                                       32185000
  move buf(8):="    ";                                           <<nsf>>32190000
                                                                 <<nsf>>32195000
  lenjmat:=4*(core(locdst+double(%31*4)).(3:13));                <<nsf>>32200000
  mfds (buf0, jmatdst, 0, jmat'ent'size);                      <<dougw>>32205000
  if <> then return;                                             <<nsf>>32210000
                                                                 <<nsf>>32215000
  if (jmat'esize <> jmat'ent'size) or                            <<nsf>>32220000
     (jmat'ent'ptr <> jmat'ent'size) or                          <<nsf>>32225000
     (jmat'stype <> 1) then begin                                <<nsf>>32230000
    printerror(48); return; end;                                 <<nsf>>32235000
                                                                 <<nsf>>32240000
  tot'jmat'words:=jcursize*128;                                  <<nsf>>32245000
  stopindx := integer(tot'jmat'words);                         <<dougw>>32250000
  current := integer(jmat'ent'ptr);                            <<dougw>>32255000
                                                                 <<nsf>>32260000
  while current < (stopindx - integer (jmat'ent'size))         <<dougw>>32265000
      and not stop'print  do begin                                      32270000
    if ctrly then begin                                          <<nsf>>32275000
      write'rec(prntfile,lbuf,0,0); <<start a new line>>                32280000
      move buf:=" <CONTROL-Y>";                                  <<nsf>>32285000
      write'rec(prntfile,lbuf,-12,%60);                                 32290000
      return;                                                    <<nsf>>32295000
    end;                                                         <<nsf>>32300000
    if mpeversion = 4 then                                       <<nsf>>32305000
      prntci4(prntfile,current)                                  <<nsf>>32310000
    else                                                         <<nsf>>32315000
      prntci5(prntfile,current);                                 <<nsf>>32320000
    current:=current+integer(jmat'ent'size);                   <<dougw>>32325000
  end;                                                           <<nsf>>32330000
                                                                 <<nsf>>32335000
  move buf(0):=" ";                                              <<nsf>>32340000
  write'rec(prntfile,lbuf,-1,0);                                        32345000
                                                                 <<nsf>>32350000
  return;                                                        <<nsf>>32355000
                                                                 <<nsf>>32360000
  pcbmethod:                                                     <<nsf>>32365000
                                                                 <<nsf>>32370000
  << we get here when the jmat dst is not in memory, so >>       <<nsf>>32375000
  << instead we use the pcb table and rely on what is   >>       <<nsf>>32380000
  << in memory.                                         >>       <<nsf>>32385000
                                                                 <<nsf>>32390000
  lfds (pcbdst,0);  << check if pcb dst is available >>        <<dougw>>32395000
  if <> then                                                   <<dougw>>32400000
    begin                                                      <<dougw>>32405000
      printerror (49);                                         <<dougw>>32410000
      return;                                                  <<dougw>>32415000
    end;                                                       <<dougw>>32420000
                                                               <<dougw>>32425000
  move buf(0):=" ";                                              <<nsf>>32430000
  move buf(1):=buf,(79);                                         <<nsf>>32435000
  move buf:="JOBNUM UMAIN STACK INPUT OUTPUT      LAST COMMAND"; <<nsf>>32440000
  write'rec(prntfile,lbuf,-79,0);                                       32445000
  move buf(0):=" ";                                              <<nsf>>32450000
  move buf(1):=buf,(45);                                         <<nsf>>32455000
  move buf:="        PIN#  DST#  LDEV  LDEV";                    <<nsf>>32460000
  write'rec(prntfile,lbuf,-20,0);                                       32465000
  move buf(8):="    ";                                           <<nsf>>32470000
                                                                 <<nsf>>32475000
  pcbentsize:=%20+(mpeversion-4)*%5;                             <<nsf>>32480000
                                                                 <<nsf>>32485000
  mfds (buf0, pcbdst, 0, pcbentsize); << re-use buf0 >>        <<dougw>>32490000
  stopindx := integer (pcb'num'ents) * pcbentsize;             <<dougw>>32495000
  current := pcbentsize;                                       <<dougw>>32500000
                                                                 <<nsf>>32505000
  while current < (stopindx - pcbentsize)                      <<dougw>>32510000
      and not stop'print  do begin                                      32515000
    if ctrly then begin                                          <<nsf>>32520000
      write'rec(prntfile,lbuf,0,0); <<start a new line>>                32525000
      move buf:=" <CONTROL-Y>";                                  <<nsf>>32530000
      write'rec(prntfile,lbuf,-12,%60);                                 32535000
      return;                                                    <<nsf>>32540000
    end;                                                         <<nsf>>32545000
    if mpeversion = 4 then                                       <<nsf>>32550000
      prntcip4(prntfile,current)                                 <<nsf>>32555000
    else                                                         <<nsf>>32560000
      prntcip5(prntfile,current);                                <<nsf>>32565000
    current := current + pcbentsize;                           <<dougw>>32570000
  end;                                                           <<nsf>>32575000
                                                                 <<nsf>>32580000
  move buf(0):=" ";                                              <<nsf>>32585000
  write'rec(prntfile,lbuf,-1,0);                                        32590000
                                                                 <<nsf>>32595000
  return;                                                        <<nsf>>32600000
                                                                 <<nsf>>32605000
end;  <<fmtcis>>                                                 <<nsf>>32610000
$page "                        PROCEDURE FMTICS"                        32615000
$control segment=format                                                 32620000
<<*****************************************>>                           32625000
<<  fmtics                                 >>                           32630000
<<----------------------------------------->>                           32635000
<<formats the ics global and stack markers >>                           32640000
<<*****************************************>>                           32645000
                                                                        32650000
procedure fmtics;                                                       32655000
                                                                        32660000
                                                                        32665000
begin                                                                   32670000
                                                                        32675000
logical icsbase,icslimit,deltaq;                                        32680000
                                                                        32685000
logical index,b'index,limit;                                            32690000
                                                                        32695000
double addr,pause;                                                      32700000
                                                                        32705000
array ics'global(0:59);                                                 32710000
array buffer(0:39);                                                     32715000
array marker(0:3);        <<array which getcore will return data>>      32720000
byte array b'buffer(*)=buffer;                                          32725000
                                                                        32730000
define clear'buffer=buffer:="  ";move buffer(1):=buffer,(39)#,          32735000
       cst'seg = marker(2).(8:8)#,                            <<851031>>32740000
       phys'mapped = marker(1).(1:1)#;                                  32745000
                                                                        32750000
                                                                        32755000
  <<the subroutine ascify converts data from the ics'global>>           32760000
  <<array and puts it in the output buffer.                >>           32765000
  <<index is the start of data in the array,limit is the   >>           32770000
  <<end of data,and b'index is index into the buffer       >>           32775000
                                                                        32780000
subroutine ascify(index,b'index,limit);                                 32785000
  value index,b'index,limit;                                            32790000
  logical index,b'index,limit;                                          32795000
begin                                                                   32800000
    do                                                                  32805000
      begin                                                             32810000
        ascii(ics'global(index),8,b'buffer(b'index));                   32815000
        index:=index+1;                                                 32820000
        b'index:=b'index+10;                                            32825000
      end                                                               32830000
    until index=limit;                                                  32835000
end;                                                                    32840000
                                                                        32845000
icsbase:=core(5d);                                                      32850000
icslimit:=core(6d);                                                     32855000
                                                                        32860000
                                                                        32865000
                                                                        32870000
addr:=double(icsbase)-49d;   <<usefull ics glob starts here>>           32875000
getcore(addr,46,ics'global);   <<get the ics glob>>                     32880000
clear'buffer;                                                           32885000
if ctrly then go cy'exit;                                     <<850916>>32890000
move buffer:="        ---SCHEDULING INFORMATION---";                    32895000
write'rec(outfile,buffer,18,0);                                         32900000
clear'buffer;                                                           32905000
if ctrly then go cy'exit;                                     <<850916>>32910000
move buffer:="E BCKGRND";                                               32915000
move buffer(5):="D BCKGRND";                                            32920000
move buffer(20):="CURR C";                                              32925000
write'rec(outfile,buffer,-79,%40);                            <<850827>>32930000
clear'buffer;                                                           32935000
if ctrly then go cy'exit;                                     <<850916>>32940000
move buffer:="QUANTUM   QUANTUM   CWNTNUM   CWTDENOM ";                 32945000
move buffer(20):="AST       MAX C     MIN C";                           32950000
write'rec(outfile,buffer,-79,%40);                            <<850827>>32955000
clear'buffer;                                                           32960000
if ctrly then go cy'exit;                                     <<850916>>32965000
                                                                        32970000
index:=5;                                                               32975000
b'index:=0;                                                             32980000
                                                                        32985000
ascify(5,0,12);                                                         32990000
write'rec(outfile,buffer,40,0);                                         32995000
                                                                        33000000
clear'buffer;                                                           33005000
if ctrly then go cy'exit;                                     <<850916>>33010000
move buffer:="E BASE    D BASE    C BASE    E LIMIT   D LIMIT";         33015000
move buffer(25):="C LIMIT";                                             33020000
                                                                        33025000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33030000
clear'buffer;                                                           33035000
if ctrly then go cy'exit;                                     <<850916>>33040000
ascify(12,0,18);                                                        33045000
write'rec(outfile,buffer,40,0);                                         33050000
                                                                        33055000
clear'buffer;                                                           33060000
if ctrly then go cy'exit;                                     <<850916>>33065000
move buffer:="          ---CURRENT STACK INFO---";                      33070000
write'rec(outfile,buffer,18,0);                                         33075000
clear'buffer;                                                           33080000
if ctrly then go cy'exit;                                     <<850916>>33085000
move buffer:="STACK";                                                   33090000
move buffer(15):="TRACE";                                               33095000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33100000
clear'buffer;                                                           33105000
if ctrly then go cy'exit;                                     <<850916>>33110000
move buffer:="DST       PSTA      PADDR     FLAG      PFAILPCB  ";      33115000
move buffer(25):="JCUT      XP";                                        33120000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33125000
clear'buffer;                                                           33130000
if ctrly then go cy'exit;                                     <<850916>>33135000
                                                                        33140000
ascify(33,0,40);                                                        33145000
write'rec(outfile,buffer,40,0);                                         33150000
clear'buffer;                                                           33155000
if ctrly then go cy'exit;                                     <<850916>>33160000
                                                                        33165000
move buffer(5):="STACK     STACK     STACK               STACK";        33170000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33175000
clear'buffer;                                                           33180000
if ctrly then go cy'exit;                                     <<850916>>33185000
move buffer:="PCBX      Z         DL        S         SBANK     DB";    33190000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33195000
clear'buffer;                                                           33200000
if ctrly then go cy'exit;                                     <<850916>>33205000
                                                                        33210000
ascify(40,0,46);                                                        33215000
write'rec(outfile,buffer,40,0);                                         33220000
                                                                        33225000
clear'buffer;                                                           33230000
if ctrly then go cy'exit;                                     <<850916>>33235000
move buffer:="          ---MISCELLANEOUS INFORMATION---";               33240000
write'rec(outfile,buffer,21,0);                                         33245000
move buffer:="CAND      LAST      LIST      MISC      SYS MEM";         33250000
move buffer(25):="XDS UP    DL        PSDB      PAUSE";                 33255000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33260000
move buffer:="PIN       WEIGHT    STATE     BNDS FLG  BOUND";           33265000
move buffer(25):="BOUND     INITIAL   COUNTER   TIME";                  33270000
write'rec(outfile,buffer,-79,%40);                            <<850827>>33275000
clear'buffer;                                                           33280000
if ctrly then go cy'exit;                                     <<850916>>33285000
ascify(0,0,2);                                                          33290000
ascii(ics'global(4),8,b'buffer(20));                                    33295000
ascify(18,30,22);                                                       33300000
ascii(ics'global(31),8,b'buffer(70));                                   33305000
write'rec(outfile,buffer,40,0);                                         33310000
                                                                        33315000
clear'buffer;                                                           33320000
move buffer:="PAUSE TIME";                                              33325000
write'rec(outfile,buffer,5,0);                                          33330000
clear'buffer;                                                           33335000
pause:=dcore(double(icsbase)-47d);                                      33340000
dascii(pause,8,buffer);                                                 33345000
write'rec(outfile,buffer,6,0);                                          33350000
                                                                        33355000
<<do stack markers>>                                                    33360000
                                                                        33365000
if dbbankreg=0 and icsbase<qreg and qreg<icslimit                       33370000
  then addr:=double(qreg)             <<must be on ics>>                33375000
  else goto not'ics;         <<not on ics>>                             33380000
                                                                        33385000
                                                                        33390000
do  <<check by going through the markers>>                              33395000
begin                                                                   33400000
if ctrly then go cy'exit;                                     <<850916>>33405000
getcore(addr,1,marker); <<get deltaq>>                                  33410000
addr:=addr-double(marker.(1:15)); <<calc next deltaq>>                  33415000
if addr < double(icsbase) then                                          33420000
  begin                                                                 33425000
  printerror(44); <<stack bad as q<qi>>                                 33430000
  return;                                                               33435000
  end;                                                                  33440000
end                                                                     33445000
until marker.(1:15) =0; <<qi we hope>>                                  33450000
addr:=double(qreg);  <<reset addr to q as on ics>>                      33455000
                                                                        33460000
goto on'ics;                                                            33465000
not'ics:       <<not on ics, check if qi=0>>                            33470000
addr:=double(icsbase);  <<use qi as not on ics>>                        33475000
getcore(addr,1,marker);       <<getqi>>                                 33480000
if marker.(1:15) <> 0 then     <<qi bad>>                               33485000
  begin                                                                 33490000
    printerror(45);                                                     33495000
    return;                                                             33500000
  end;                                                                  33505000
                                                                        33510000
on'ics:                                                                 33515000
                                                                        33520000
                                                                        33525000
clear'buffer;                                                           33530000
if ctrly then go cy'exit;                                     <<850916>>33535000
move buffer:="          ---STACK MARKERS---";                           33540000
write'rec(outfile,buffer,18,0);                                         33545000
clear'buffer;                                                           33550000
if ctrly then go cy'exit;                                     <<850916>>33555000
move buffer :=                                                          33560000
  "ADDRESS   X-REG     DELTA-P   STATUS    DELTA-Q   SEGMENT";          33565000
write'rec(outfile,buffer,-57,0);                                        33570000
move buffer :=                                                          33575000
  "------    ------    -------   ------    -------   -------";          33580000
write'rec(outfile,buffer,-57,0);                                        33585000
clear'buffer;                                                           33590000
if ctrly then go cy'exit;                                     <<850916>>33595000
                                                                        33600000
addr:=addr-3d;  <<addr of ist word of stack marker>>                    33605000
                                                                        33610000
do                                                                      33615000
  begin                                                                 33620000
if ctrly then go cy'exit;                                     <<850916>>33625000
    buffer:=" ";  move buffer(1):=buffer,(39);                          33630000
    getcore(addr,4,marker);    <<get the 4 wd marker>>                  33635000
    if marker(1).(1:1)=1 then                                           33640000
      begin                                                             33645000
      marker(1).(1:1):=0;      <<reset logical physical bit>>           33650000
      move b'buffer(27):="P";                                           33655000
      end;                                                              33660000
    deltaq:=marker(3);               <<get deltaq>>                     33665000
    ascii(logical(addr),8,b'buffer); <<print address>>                  33670000
    ascii(marker(0),8,b'buffer(10)); <<print marker>>                   33675000
    ascii(marker(1),8,b'buffer(20));                                    33680000
    ascii(marker(2),8,b'buffer(30));                                    33685000
    ascii(marker(3),8,b'buffer(40));                                    33690000
                                                                        33695000
    if deltaq.(1:15) = 0 then                                           33700000
       move buffer(25):="***DISP MARKER***"                             33705000
    else                                                                33710000
      if mpeversion = 5 and new'firmware <> 0 then                      33715000
        begin                                                           33720000
        if b'buffer(27) <> "P" then                                     33725000
          move buffer(25) := "USER SEGMENT"                             33730000
        else                                                            33735000
          name'cst(cst'seg,buffer(25));                                 33740000
        end                                                             33745000
    else                                                                33750000
      begin                                                             33755000
      if cst'seg > %300 then move buffer(25):="USER SEGMENT"            33760000
      else                                                              33765000
        name'cst(cst'seg,buffer(25));                                   33770000
      end;                                                              33775000
    write'rec(outfile,buffer,-79,0);                                    33780000
    addr:=addr-double(marker(3).(1:15));<<calculate address of next x>> 33785000
  end                                                                   33790000
  until deltaq.(1:15) = 0;     <<this should be the dispatcher marker>> 33795000
                               <<if not, the stack must be bad>>        33800000
  go jump'out;                                                <<851113>>33805000
cy'exit:                                                      <<850916>>33810000
  move buffer:=" <CONTROL-Y>";                                <<850916>>33815000
  write'rec(outfile,buffer,0,0);  << blank line >>            <<850916>>33820000
  write'rec(outfile,buffer,-12,%40);                          <<850916>>33825000
                                                              <<850916>>33830000
jump'out:                                                               33835000
return;                                                                 33840000
                                                                        33845000
end;  <<fmtics>>                                                        33850000
$page "                     PROCEDURE FORMATINFO"                       33855000
$control segment=idat4                                                  33860000
<<***********************************************************>>         33865000
<<  formatinfo                                               >>         33870000
<<----------------------------------------------------------->>         33875000
<< parse and execute the "FORMAT" command                    >>         33880000
<<***********************************************************>>         33885000
procedure formatinfo(parmstring);                                       33890000
  byte array parmstring;  <<parameter string>>                          33895000
begin                                                                   33900000
                                                                        33905000
                                                                        33910000
  << this procedure assumes the existence of the >>                     33915000
  << global variables "PCB'GOOD", "DST'GOOD",    >>                     33920000
  << "OUTFILE" & "LISTFILE" as well as these     >>              <<nsf>>33925000
  << procedures:                                 >>                     33930000
  <<        printerror           parseoffset     >>                     33935000
  <<        getnumber            validpin        >>                     33940000
  <<        core                 getstackdst     >>                     33945000
  <<        getdstaddr           getcore         >>                     33950000
  <<        fmtpcbentry4         fmtstack4       >>              <<nsf>>33955000
  <<        fmtpcbentry5         fmtstack5       >>              <<nsf>>33960000
                                                                        33965000
equate  maxparms = 4;                                                   33970000
                                                                        33975000
equate  fmt'pcb    =  1,                                                33980000
        fmt'dst    =  2,                                                33985000
        fmt'cst    =  3,                                                33990000
        fmt'cstx   =  4,                                                33995000
        fmt'stack  =  5,                                                34000000
        fmt'regs   =  6,                                                34005000
        fmt'sir    =  7,                                         <<nsf>>34010000
        fmt'drq    =  8,                                                34015000
        fmt'ioq    =  9,                                                34020000
        fmt'dit    = 10,                                                34025000
        fmt'sbuf   = 11,                                                34030000
        fmt'jobs   = 12,                                         <<nsf>>34035000
        fmt'cis    = 13,                                         <<nsf>>34040000
        fmt'ics    = 14,                                         <<nsf>>34045000
        fmt'mon    = 15,                                                34050000
        fmt'ptree  = 16,                                                34055000
        fmt'pin    = 17;                                                34060000
                                                                        34065000
define  length = infoword.(0:8)#;                                       34070000
                                                                        34075000
logical   infoword;  <<word from mycommand>>                            34080000
integer     dstnum,  <<dst number to format>>                           34085000
           itemnum,  <<requested item to format>>                       34090000
               pin,  <<pin number to format>>                           34095000
              ldev,  <<ldev to be formatted >>                          34100000
              optn,  <<option for drq,ioq>>                             34105000
          numparms;  <<number of parameters>>                           34110000
double     address;  <<address of item to format>>                      34115000
double     pcbaddr, icsbase, icslimit;                           <<nsf>>34120000
logical pcbentsize;                                              <<nsf>>34125000
                                                                        34130000
logical array pcbentry(0:20);                                    <<nsf>>34135000
double array  parms(0:maxparms); <<parms returned>>                     34140000
byte array parmstr2(0:79);                                              34145000
byte array delimiters(0:1);                                             34150000
                                                                        34155000
byte pointer  string;                                                   34160000
                                                                        34165000
own byte array itemlist(0:44):=  <<list for search intrinsic>>          34170000
   5, 3, "PCB",                                                         34175000
   5, 3, "DST",                                                         34180000
   5, 3, "CST",                                                         34185000
   6, 4, "CSTX",                                                        34190000
   7, 5, "STACK",                                                       34195000
   5, 3, "SIR",                                                         34200000
   5, 3, "ICS",                                                         34205000
   5, 3, "MON",                                                         34210000
   0;                                                                   34215000
                                                                        34220000
move parmstr2 := parmstring,(80);                                       34225000
                                                                        34230000
pcbaddr:=getdstaddr(3);                                          <<nsf>>34235000
pcbentsize:=%20+(mpeversion-4)*5;                                <<nsf>>34240000
<<set up to parse the parameters>>                                      34245000
delimiters(0):=",";                                                     34250000
delimiters(1):=cr;                                                      34255000
mycommand(parmstring,delimiters,maxparms,numparms,parms);               34260000
if <> then begin                                                        34265000
  printerror(0);                                                        34270000
  return; end;                                                          34275000
                                                                        34280000
<<determine what is to be formatted>>                                   34285000
if numparms = 0 then return;  <<nothing specified>>                     34290000
if numparms > 2 then begin                                              34295000
  printerror(10);                                                       34300000
  return; end;                                                          34305000
tos:=parms(0);                                                          34310000
infoword:=tos;                                                          34315000
@string:=tos;                                                           34320000
                                                                        34325000
string(length):=cr;  <<required by "EXPREVAL">>                         34330000
                                                                        34335000
address:=parseoffset(parms(0));                                         34340000
if = then begin                                                         34345000
  <<user specified a valid address - determine format>>                 34350000
  if numparms <> 2 then begin                                           34355000
    printerror(10);  <<did not specify any format>>                     34360000
    return; end;                                                        34365000
  tos:=parms(1);                                                        34370000
  infoword:=tos;                                                        34375000
  @string:=tos;                                                         34380000
                                                                        34385000
  itemnum:=search(string,length,itemlist);                              34390000
  if itemnum = 1 then begin                                      <<nsf>>34395000
    if mpeversion = 5 then begin                                 <<nsf>>34400000
      pin:=logical(address)/pcbentsize;                          <<nsf>>34405000
      address:=pcbaddr+address;                                  <<nsf>>34410000
      end                                                        <<nsf>>34415000
    else                                                         <<nsf>>34420000
      pin:=logical(address-pcbaddr)/pcbentsize;                  <<nsf>>34425000
  end;                                                           <<nsf>>34430000
  if itemnum = 0 then begin                                             34435000
    printerror(11);  <<invalid format specified>>                       34440000
    return; end; end                                                    34445000
else begin                                                              34450000
  <<first parameter is not a valid address - determine>>                34455000
  <<what entity was specified>>                                         34460000
  if string = "PCB" then begin                                          34465000
    pin:=getnumber(string(3),length-3);                                 34470000
    if <> then begin                                                    34475000
      printerror(12);                                                   34480000
      return; end;                                                      34485000
                                                                        34490000
    if not validpin(pin) then begin                                     34495000
      printerror(15);                                                   34500000
      return; end;                                                      34505000
                                                                        34510000
    <<now determine if to format pcb entry or stack>>                   34515000
    if numparms = 1 then begin                                          34520000
      <<format the pcb entry>>                                          34525000
      itemnum:=fmt'pcb;                                                 34530000
      if pcb'good then                                                  34535000
        address:=pcbaddr+double(logical(pin)*pcbentsize)         <<nsf>>34540000
      else begin                                                        34545000
        printerror(14);                                                 34550000
        return; end; end                                                34555000
    else begin                                                          34560000
      <<examine the second parameter>>                                  34565000
      tos:=parms(1);                                                    34570000
      infoword:=tos;                                                    34575000
      @string:=tos;                                                     34580000
                                                                        34585000
      itemnum:=search(string,length,itemlist);                          34590000
      if itemnum <> fmt'stack then begin                                34595000
        printerror(11);                                                 34600000
        return; end;                                                    34605000
                                                                        34610000
      if not assigned'pin(pin) then                                     34615000
        begin                                                           34620000
        printerror(85);                                                 34625000
        return;                                                         34630000
        end;                                                            34635000
                                                                        34640000
      <<get address of the stack>>                                      34645000
      dstnum:=getstackdst(pin);                                         34650000
      if > then begin                                                   34655000
        printerror(9);                                                  34660000
        return; end                                                     34665000
      else if < then return;                                            34670000
      address:=getdstaddr(dstnum);                                      34675000
      if <> then return; end; end                                       34680000
  else                                                                  34685000
  if string = "DST" then begin                                          34690000
    dstnum:=getnumber(string(3),length-3);                              34695000
    if <> then begin                                                    34700000
      printerror(12);                                                   34705000
      return; end;                                                      34710000
                                                                        34715000
    <<determine if dst entry or a stack to be formatted>>               34720000
    if numparms = 1 then begin                                          34725000
      itemnum:=fmt'dst;                                                 34730000
      if dst'good then                                                  34735000
        address:=double(core(2d)+logical(dstnum)*4)                     34740000
      else begin                                                        34745000
        printerror(13);                                                 34750000
        return; end; end                                                34755000
    else begin                                                          34760000
      <<examine the 2nd parameter>>                                     34765000
      tos:=parms(1);                                                    34770000
      infoword:=tos;                                                    34775000
      @string:=tos;                                                     34780000
                                                                        34785000
      itemnum:=search(string,length,itemlist);                          34790000
      if itemnum <> fmt'stack then begin                                34795000
        printerror(11);                                                 34800000
        return; end;                                                    34805000
                                                                        34810000
      <<get address of the stack>>                                      34815000
      address:=getdstaddr(dstnum);                                      34820000
      if > then begin                                                   34825000
        printerror(9);                                                  34830000
        return; end                                                     34835000
      else if < then return; end; end                                   34840000
  else                                                                  34845000
    if string = "REG" then itemnum:= fmt'regs                           34850000
  else                                                                  34855000
    if string = "SIR" then itemnum:= fmt'sir                            34860000
  else                                                                  34865000
    if string = "DRQ" then itemnum:= fmt'drq                            34870000
  else                                                                  34875000
    if string = "IOQ" then itemnum:= fmt'ioq                            34880000
  else                                                                  34885000
    if string = "DIT" then itemnum:= fmt'dit                            34890000
  else                                                                  34895000
    if string = "SBUF" then itemnum:= fmt'sbuf                          34900000
  else                                                                  34905000
    if string = "JOB" then itemnum:= fmt'jobs                    <<nsf>>34910000
  else                                                           <<nsf>>34915000
    if string = "CI" then itemnum:= fmt'cis                      <<nsf>>34920000
  else                                                                  34925000
    if string = "ICS" then itemnum:= fmt'ics                            34930000
  else                                                                  34935000
    if string = "MON" then itemnum:= fmt'mon                            34940000
  else                                                                  34945000
    if string = "PIN" then itemnum:= fmt'pin                            34950000
  else                                                                  34955000
    if string = "PTREE" then                                            34960000
      begin                                                             34965000
      itemnum := fmt'ptree;                                             34970000
      if pcb'good then address := double(core(%1003d))                  34975000
      else                                                              34980000
        begin                                                           34985000
        printerror(14);                                                 34990000
        return;                                                         34995000
        end;                                                            35000000
      end                                                               35005000
  else                                                           <<nsf>>35010000
    printerror(11); end;                                                35015000
                                                                        35020000
<<now call the appropriate routine to format the item>>                 35025000
  case itemnum-1 of begin                                               35030000
    <<pcb>> begin                                                       35035000
            getcore(address,pcbentsize,pcbentry);                <<nsf>>35040000
            if = then                                                   35045000
              if mpeversion = 4 then begin                       <<nsf>>35050000
                fmtpcbentry4(outfile,pin,pcbentry);              <<nsf>>35055000
                end                                              <<nsf>>35060000
              else begin                                         <<nsf>>35065000
                fmtpcbentry5(outfile,pin,pcbentry);              <<nsf>>35070000
                end;                                             <<nsf>>35075000
            end;                                                        35080000
    <<dst>> ;                                                           35085000
    <<cst>> ;                                                           35090000
   <<cstx>> ;                                                           35095000
  <<stack>> begin                                                       35100000
            if mpeversion = 4 then begin                         <<nsf>>35105000
              fmtstack4(outfile,address,dstnum);                        35110000
            end else begin                                       <<nsf>>35115000
              fmtstack5(outfile,address,dstnum);                        35120000
            end;                                                 <<nsf>>35125000
            end;                                                        35130000
   <<regs>> begin                                                       35135000
            fmtregs(outfile);                                    <<nsf>>35140000
            end;                                                        35145000
    <<sir>> begin                                                       35150000
            move buf := "FORMATTING...";                                35155000
            write'rec(outfile,lbuf,-13,0);                              35160000
            fmtsir(outfile); end;                                <<nsf>>35165000
    <<drq>> begin                                                       35170000
            parse'dioq(parmstr2(3),optn,ldev);                          35175000
            fmtdrq(optn,ldev);                                          35180000
            end;                                                        35185000
    <<ioq>> begin                                                       35190000
            parse'dioq(parmstr2(3),optn,ldev);                          35195000
            fmtioq(optn,ldev);                                          35200000
            end;                                                        35205000
    <<dit>> begin                                                       35210000
            if numparms=1 then fmtdit  << ordinary call >>              35215000
            else                                                        35220000
              begin << 2 parms, must be specific ldev >>                35225000
              tos:=parms(1);                                            35230000
              infoword:=tos;                                            35235000
              @string:=tos;                                             35240000
              ldev:=binary(string,length);                              35245000
              if <> then                                                35250000
                begin                                                   35255000
                printerror(12);                                         35260000
                return;                                                 35265000
                end;                                                    35270000
              fmtdit(ldev);                                             35275000
              end;                                                      35280000
            end;                                                        35285000
   <<sbuf>> fmtsbuf;                                                    35290000
    <<job>> begin                                                <<nsf>>35295000
            if mpeversion = 4 then begin                         <<nsf>>35300000
              fmtjobs4(outfile);                                 <<nsf>>35305000
              end                                                <<nsf>>35310000
            else begin                                           <<nsf>>35315000
              fmtjobs5(outfile);                                 <<nsf>>35320000
              end;                                               <<nsf>>35325000
            end;                                                 <<nsf>>35330000
     <<ci>> begin                                                <<nsf>>35335000
              fmtcis(outfile);                                   <<nsf>>35340000
            end;                                                 <<nsf>>35345000
    <<ics>> fmtics;                                                     35350000
    <<mon>> fmtmon(outfile);                                            35355000
  <<ptree>> proc'tree(address,outfile);                                 35360000
    <<pin>> begin                                                       35365000
              if mpeversion = 5 then fmtpins5(outfile)                  35370000
              else fmtpins4(outfile);                                   35375000
            end;                                                        35380000
                                                                 <<nsf>>35385000
  end;  <<case>>                                                        35390000
                                                                        35395000
end;  <<formatinfo>>                                                    35400000
$page   "                     PROCEDURE DEADLK'ERR"                     35405000
<<***********************************************************>>         35410000
<<  deadlk'err                                               >>         35415000
<<----------------------------------------------------------->>         35420000
<<  this procedure is responsible for printing the message   >>         35425000
<<  indicating a sir deadlock situation was found and what   >>         35430000
<<  pins are deadlocked.                                     >>         35435000
<<    input:  an array of pins that were found in the dead-  >>         35440000
<<            lock situation.                                >>         35445000
<<                                                           >>         35450000
<<            the number of pins in the array                >>         35455000
<<                                                           >>         35460000
<<            the output file number                         >>         35465000
<<***********************************************************>>         35470000
                                                                        35475000
procedure deadlk'err(hldrs'impd,marker,chain,prntfile);                 35480000
   value marker,chain,prntfile;                                         35485000
   integer marker,chain,prntfile;                                       35490000
   integer array hldrs'impd;                                            35495000
                                                                        35500000
   begin                                                                35505000
      integer index,char'len,repeat,pcbsize;                            35510000
                                                                        35515000
      index:= marker;                                                   35520000
      repeat:= chain;                                                   35525000
      pcbsize:= %20+(mpeversion-4)*5;                                   35530000
      buf := " ";   move buf(1) := buf, (79);                  <<84301>>35535000
      write'rec(prntfile,lbuf,-79,0);                                   35540000
      move buf:="************************************************";     35545000
      write'rec(prntfile,lbuf,-79,0);                                   35550000
      move buf:="THE FOLLOWING PINS ARE IN A SIR DEADLOCK...     ";     35555000
      write'rec(prntfile,lbuf,-48,0);                                   35560000
      buf := " ";   move buf(1) := buf, (79);                           35565000
      write'rec(prntfile,lbuf,-79,0);                                   35570000
      while repeat > 0 do begin                                         35575000
         move buf(3):="PIN";                                            35580000
         @pbuf:=@buf+7;                                                 35585000
         putnump(hldrs'impd(index)/pcbsize);                            35590000
         write'rec(prntfile,lbuf,-79,0);                                35595000
         index:=index+1;                                                35600000
         repeat:= repeat -1;                                            35605000
         buf := " ";   move buf(1) := buf, (79);               <<84301>>35610000
         end;                                                           35615000
      end;                                                              35620000
                                                                        35625000
                                                                        35630000
$page   "                     PROCEDURE FIND'DEADLOCK"                  35635000
<<***********************************************************>>         35640000
<<  find'deadlock                                            >>         35645000
<<----------------------------------------------------------->>         35650000
<<  this procedure finds sir deadlock situations that exist  >>         35655000
<<  between pins that are both holding sirs and waiting for  >>         35660000
<<  other sirs.  input:  *an array of pins that are both     >>         35665000
<<                        waiting for sirs and holding sirs  >>         35670000
<<                                                           >>         35675000
<<                       *an array of pins that are holding  >>         35680000
<<                        the sirs that the pins in the first>>         35685000
<<                        array are waiting for.             >>         35690000
<<***********************************************************>>         35695000
procedure find'deadlock(hldrs'impd,impdrs);                             35700000
   integer array hldrs'impd,impdrs;                                     35705000
                                                                        35710000
   begin                                                                35715000
      integer index:=0;                                                 35720000
      integer search'pin,start'pin;                                     35725000
      integer marker,chain;                                             35730000
      logical found;                                                    35735000
      logical nodeadlocks := true;                             <<dougw>>35740000
                                                                        35745000
      start'pin:=hldrs'impd(index);                                     35750000
      search'pin:= impdrs(index);                                       35755000
      marker:=index;                                                    35760000
                                                                        35765000
      while hldrs'impd(marker)<>0 do begin                              35770000
         chain:= 1;                                                     35775000
         while search'pin <> start'pin and hldrs'impd(index)<>0 do begin35780000
            found:=false;                                               35785000
            while not found and hldrs'impd(index)<>0 do begin           35790000
               if hldrs'impd(index) = search'pin                        35795000
                  then found:= true                                     35800000
                  else index:=index + 1; end;                           35805000
            if found = true then begin                                  35810000
               search'pin:= impdrs(index);                              35815000
               chain:= chain + 1;                                       35820000
               index:= 0; end; end;                                     35825000
         if search'pin = start'pin then begin                           35830000
            deadlk'err(hldrs'impd,marker,chain,outfile);                35835000
            nodeadlocks := false;                              <<dougw>>35840000
            marker:= marker + chain;                                    35845000
            start'pin:=hldrs'impd(marker);                              35850000
            search'pin:=impdrs(marker); end                             35855000
         else marker:= marker + 1;                                      35860000
         index:= marker;                                       <<dougw>>35865000
      end;                                                     <<dougw>>35870000
      if nodeadlocks then                                      <<dougw>>35875000
         begin                                                 <<dougw>>35880000
            buf := " ";  move buf(1) := buf, (79);             <<dougw>>35885000
            write'rec(outfile,lbuf,-79,0);                     <<dougw>>35890000
            move buf :="NO DEADLOCKS FOUND";                   <<dougw>>35895000
            write'rec(outfile,lbuf,-79,0);                     <<dougw>>35900000
         end;                                                  <<dougw>>35905000
end;                                                           <<dougw>>35910000
                                                                        35915000
$page   "                     PROCEDURE CHK'DEADLOCKS4"                 35920000
<<***********************************************************>>         35925000
<<  chk'deadlocks4                                           >>         35930000
<<----------------------------------------------------------->>         35935000
<<  this procedure is responsible for building two lists ;   >>         35940000
<<       1)  array hldrs'impd: a list of pins that are both  >>         35945000
<<           holding sirs and waiting for them.              >>         35950000
<<       2)  array impdrs:  a list of the pins that are      >>         35955000
<<           holding the sirs the pins in array hldrs'impd   >>         35960000
<<           are waiting for.                                >>         35965000
<<***********************************************************>>         35970000
                                                                        35975000
procedure chk'deadlocks4(hldrs'impd,impdrs);                            35980000
   integer array hldrs'impd,impdrs;                                     35985000
                                                                        35990000
   begin                                                                35995000
      logical found;                                                    36000000
      double locpcb,locsir,locdst;                                      36005000
      integer current'q'item,q'length,next,indx,current'q,q'set;        36010000
      integer holder'impeded,nxt'impd,lsir;                             36015000
                                                                        36020000
                                                                        36025000
      locdst:=double(core(2d));<< define dst base>>                     36030000
      locpcb:=double(core(3d));<< define pcb base>>                     36035000
      locsir:=getdstaddr(%53);                                          36040000
      lsir:=4*(core(locdst+double(4*%53)).(3:13)); <<length sir dst>>   36045000
                                                                        36050000
      next:=0;                                                          36055000
      indx:=0;                                                          36060000
      q'set:=lsir/2;                                                    36065000
      while (indx:=indx+2) < lsir do begin                              36070000
         holder'impeded:= core(locsir + double(indx)).(0:8);            36075000
         if holder'impeded <> 0 then begin                              36080000
            found:=false;                                               36085000
            current'q:= 1;                                              36090000
            while current'q < q'set and not found do begin              36095000
               current'q'item:= 1;                                      36100000
               q'length:= core(double(current'q*2) + locsir).(8:8);     36105000
               nxt'impd:= core(double(current'q*2+1) + locsir).(8:8);   36110000
               while current'q'item <= q'length and not found do begin  36115000
                  if nxt'impd = holder'impeded then begin               36120000
                     found:= true;                                      36125000
                     impdrs(next):=core(double(current'q*2)+locsir).    36130000
                                                             (0:8);     36135000
                     hldrs'impd(next):=holder'impeded;                  36140000
                     next:=next + 1; end                                36145000
                  else if q'length > 1 then                             36150000
                     nxt'impd:=core(double(nxt'impd*16+8)+locpcb).      36155000
                                                             (8:8);     36160000
                  current'q'item:= current'q'item + 1; end;             36165000
               current'q:=current'q + 1; end; end; end;                 36170000
                                                                        36175000
      find'deadlock(hldrs'impd,impdrs);                                 36180000
                                                                        36185000
  end;  <<chk'deadlocks4>>                                              36190000
$page "                       PROCEDURE CHK'DEADLOCKS5"                 36195000
$control segment=idat5                                                  36200000
<<***********************************************************>>         36205000
<<  chk'deadlocks5                                           >>         36210000
<<----------------------------------------------------------->>         36215000
<<  this procedure is responsible for building two lists ;   >>         36220000
<<       1)  array hldrs'impd: a list of pins that are both  >>         36225000
<<           holding sirs and waiting for them.              >>         36230000
<<       2)  array impdrs:  a list of the pins that are      >>         36235000
<<           holding the sirs the pins in array hldrs'impd   >>         36240000
<<           are waiting for.                                >>         36245000
<<***********************************************************>>         36250000
                                                                        36255000
procedure chk'deadlocks5(hldrs'impd,impdrs);                            36260000
   integer array hldrs'impd,impdrs;                                     36265000
                                                                        36270000
   begin                                                                36275000
      logical found;                                                    36280000
      double locpcb,locsir,locdst;                                      36285000
      integer current'q'item,q'length,next,indx,current'q,q'set;        36290000
      integer holder'impeded,nxt'impd,lsir;                             36295000
                                                                        36300000
                                                                        36305000
      locdst:=double(core(2d));<< define dst base>>                     36310000
      locpcb:=getdstaddr(3);                                            36315000
      locsir:=getdstaddr(%53);                                          36320000
      lsir:=4*(core(locdst+double(4*%53)).(3:13)); <<length sir dst>>   36325000
                                                                        36330000
      next:=0;                                                          36335000
      indx:=0;                                                          36340000
      q'set:=lsir/4;                                                    36345000
      while (indx:=indx+4) < lsir do begin                              36350000
         holder'impeded:= core(locsir + double(indx));                  36355000
         if holder'impeded <> 0 then begin                              36360000
            found:=false;                                               36365000
            current'q:= 1;                                              36370000
            while current'q < q'set and not found do begin              36375000
               current'q'item:= 1;                                      36380000
               q'length:= core(double(current'q*4) + locsir);           36385000
               nxt'impd:= core(double(current'q*4+2) + locsir);         36390000
               while current'q'item <= q'length and not found do begin  36395000
                  if nxt'impd = holder'impeded then begin               36400000
                     found:= true;                                      36405000
                     impdrs(next):=core(double(current'q*4)+locsir);    36410000
                     hldrs'impd(next):=holder'impeded;                  36415000
                     next:=next + 1; end                                36420000
                  else if q'length > 1 then                             36425000
                     nxt'impd:=core(double(nxt'impd+17)+locpcb);        36430000
                  current'q'item:= current'q'item + 1; end;             36435000
               current'q:=current'q + 1; end; end; end;                 36440000
                                                                        36445000
      find'deadlock(hldrs'impd,impdrs);                                 36450000
                                                                        36455000
  end;  <<chk'deadlocks5>>                                              36460000
$page   "                     PROCEDURE PRNTJOB5 "               <<nsf>>36465000
                                                                 <<nsf>>36470000
<<***********************************************************>>  <<nsf>>36475000
<<  prntjob5                                                 >>  <<nsf>>36480000
<<----------------------------------------------------------->>  <<nsf>>36485000
<<  this procedure takes the contents of a 38 word buffer    >>  <<nsf>>36490000
<<  and formats one line of output as a :showjob emulator    >>  <<nsf>>36495000
<<***********************************************************>>  <<nsf>>36500000
                                                                 <<nsf>>36505000
                                                                 <<nsf>>36510000
procedure prntjob5(prntfile,addr,dcl'addr);                      <<nsf>>36515000
                                                                 <<nsf>>36520000
value prntfile,addr,dcl'addr;                                    <<nsf>>36525000
integer prntfile;                                                <<nsf>>36530000
double addr,dcl'addr;                                            <<nsf>>36535000
                                                                 <<nsf>>36540000
begin                                                            <<nsf>>36545000
                                                                 <<nsf>>36550000
  define  jmat'state=buffer(0).(0:6)#,                           <<nsf>>36555000
         jmat'duplic=buffer(0).(6:1)#,                           <<nsf>>36560000
          jmat'inter=buffer(0).(7:1)#,                           <<nsf>>36565000
          jmat'quiet=buffer(0).(8:1)#,                           <<nsf>>36570000
       jmat'stdl'del=buffer(0).(9:1)#,                           <<nsf>>36575000
       jmat'usr'pswd=buffer(0).(10:1)#,                          <<nsf>>36580000
      jmat'devcl'idx=buffer(0).(11:1)#,                          <<nsf>>36585000
          jmat'inpri=buffer(0).(12:4)#,                          <<nsf>>36590000
           jmat'type=buffer(1).(0:2)#,                           <<nsf>>36595000
         jmat'number=buffer(1).(2:14)#,                          <<nsf>>36600000
       jmat'cont'num=buffer(2)#,                                 <<nsf>>36605000
        jmat'usernam=buffer(3)#,                                 <<nsf>>36610000
        jmat'acctnam=buffer(7)#,                                 <<nsf>>36615000
         jmat'jobnam=buffer(11)#,                                <<nsf>>36620000
        jmat'logonam=buffer(15)#,                                <<nsf>>36625000
        jmat'jin'dev=buffer(19)#,                                <<nsf>>36630000
       jmat'jlst'dev=buffer(20)#,                                <<nsf>>36635000
         jmat'juldat=buffer(21)#,                                <<nsf>>36640000
     jmat'clk'tim'hi=buffer(22)#,                                <<nsf>>36645000
     jmat'clk'tim'lo=buffer(23)#,                                <<nsf>>36650000
       jmat'language=buffer(24).(0:8)#,                          <<nsf>>36655000
           jmat'xpri=buffer(24).(8:8)#,                          <<nsf>>36660000
       jmat'main'pin=buffer(25)#,                                <<nsf>>36665000
        jmat'cpu'lim=buffer(26)#,                                <<nsf>>36670000
     jmat'orig'spool=buffer(27).(0:1)#,                          <<nsf>>36675000
     jmat'job'restrt=buffer(27).(1:1)#,                          <<nsf>>36680000
     jmat'job'seqncd=buffer(27).(2:1)#,                          <<nsf>>36685000
     jmat'funny'term=buffer(27).(3:2)#,                          <<nsf>>36690000
         jmat'outpri=buffer(27).(5:4)#,                          <<nsf>>36695000
       jmat'num'copy=buffer(27).(9:7)#,                          <<nsf>>36700000
        jmat'origjin=buffer(28)#,                                <<nsf>>36705000
      jmat'origjlist=buffer(29)#;                                <<nsf>>36710000
                                                                 <<nsf>>36715000
  define  dc'cyclic=ldevbuf(4).(1:7)#,                           <<nsf>>36720000
         dc'spool'q=ldevbuf(4).(8:1)#,                           <<nsf>>36725000
        dc'term'acc=ldevbuf(4).(9:1)#,                           <<nsf>>36730000
        dc'acc'type=ldevbuf(4).(10:6)#,                          <<nsf>>36735000
       dc'num'in'cl=ldevbuf(5)#;                                 <<nsf>>36740000
                                                                 <<nsf>>36745000
  integer n,ii,numchar,outchar;                                  <<nsf>>36750000
  logical array buffer(0:37);                                    <<nsf>>36755000
  byte array bufferb(*)=buffer;                                  <<nsf>>36760000
  logical array ldevbuf(0:39);                                   <<nsf>>36765000
  byte array devbuf(*)=ldevbuf;                                  <<nsf>>36770000
  logical array buf'wrk'l(0:2);                                  <<nsf>>36775000
  byte array buf'wrk(*)=buf'wrk'l;                               <<nsf>>36780000
                                                                 <<nsf>>36785000
  double time,temp'addr;                                         <<nsf>>36790000
                                                                 <<nsf>>36795000
  logical pointer clas'nam'ptr;                                  <<nsf>>36800000
  byte pointer b'clas'nam'ptr;                                   <<nsf>>36805000
                                                                 <<nsf>>36810000
  equate entry'length=38,                                        <<nsf>>36815000
           free'entry=0,                                         <<nsf>>36820000
                intro=1,                                         <<nsf>>36825000
                sched=%70,                                     <<dougw>>36830000
                 wait=%40,                                       <<nsf>>36835000
                 init=%60,                                       <<nsf>>36840000
                 exec=2,                                         <<nsf>>36845000
          terminating=3,                                         <<nsf>>36850000
            suspended=4,                                         <<nsf>>36855000
              session=1,                                         <<nsf>>36860000
                  job=2,                                         <<nsf>>36865000
          user'name'b=6,                                         <<nsf>>36870000
          user'name'e=13,                                        <<nsf>>36875000
          acct'name'b=14,                                        <<nsf>>36880000
          acct'name'e=21,                                        <<nsf>>36885000
           grp'name'b=30,                                        <<nsf>>36890000
           grp'name'e=37,                                        <<nsf>>36895000
           job'name'b=22,                                        <<nsf>>36900000
           job'name'e=29;                                        <<nsf>>36905000
                                                                 <<nsf>>36910000
  @clas'nam'ptr:=@ldevbuf;                                       <<nsf>>36915000
  @b'clas'nam'ptr:=@devbuf;                                      <<nsf>>36920000
                                                                 <<nsf>>36925000
  getcore(addr,entry'length,buffer);                             <<nsf>>36930000
  if jmat'state=free'entry then return;                          <<nsf>>36935000
  move buf(0):=" ";  move buf(1):=buf,(79);                      <<nsf>>36940000
  move buf:="#";                                                 <<nsf>>36945000
  if jmat'type=session then begin                                <<nsf>>36950000
    move buf(1):="S"; end                                        <<nsf>>36955000
  else begin                                                     <<nsf>>36960000
    move buf(1):="J";                                            <<nsf>>36965000
  end;                                                           <<nsf>>36970000
  ascii(jmat'number,10,buf(2));                                  <<nsf>>36975000
  if jmat'state=wait then begin                                  <<nsf>>36980000
    move buf(8):="WAIT"; end                                     <<nsf>>36985000
  else if jmat'state=init then begin                             <<nsf>>36990000
      move buf(8):="INIT"; end                                   <<nsf>>36995000
  else if jmat'state=sched then begin                          <<dougw>>37000000
      move buf(7):="SCHED"; end                                <<dougw>>37005000
    else begin                                                   <<nsf>>37010000
      case jmat'state of begin                                   <<nsf>>37015000
        <<free entry>> ;                                         <<nsf>>37020000
        <<intro>> begin                                          <<nsf>>37025000
                  move buf(7):="INTRO";                          <<nsf>>37030000
                  end;                                           <<nsf>>37035000
        <<exec>>  begin                                          <<nsf>>37040000
                  move buf(8):="EXEC";                           <<nsf>>37045000
                  end;                                           <<nsf>>37050000
        <<term.>> begin                                          <<nsf>>37055000
                  move buf(8):="TERM";                           <<nsf>>37060000
                  end;                                           <<nsf>>37065000
        <<susp>>  begin                                          <<nsf>>37070000
                  move buf(8):="SUSP";                           <<nsf>>37075000
                  end;                                           <<nsf>>37080000
      end;  <<case>>                                             <<nsf>>37085000
    end;                                                         <<nsf>>37090000
                                                                 <<nsf>>37095000
  if jmat'type=job then begin                                    <<nsf>>37100000
    if jmat'devcl'idx then begin                                 <<nsf>>37105000
      if jmat'state=wait or jmat'state=sched then              <<dougw>>37110000
         ascii(jmat'jin'dev,10,buf(20))                        <<dougw>>37115000
      else ascii(jmat'origjin,10,buf(20));                       <<nsf>>37120000
      if jmat'orig'spool then move buf(22):="S";                 <<nsf>>37125000
    end;                                                         <<nsf>>37130000
  end                                                            <<nsf>>37135000
  else begin                                                     <<nsf>>37140000
    if jmat'jin'dev<100 then                                     <<nsf>>37145000
      ascii(jmat'jin'dev,10,buf(20))                             <<nsf>>37150000
    else                                                         <<nsf>>37155000
      ascii(jmat'jin'dev,10,buf(19));                            <<nsf>>37160000
  end;                                                           <<nsf>>37165000
  if jmat'type=session then                                      <<nsf>>37170000
    ascii(jmat'jlst'dev,10,buf(24))                              <<nsf>>37175000
  else begin                                                     <<nsf>>37180000
    if jmat'state=wait or jmat'state=sched then                <<dougw>>37185000
       n := jmat'jlst'dev                                      <<dougw>>37190000
    else n:=jmat'origjlist;                                      <<nsf>>37195000
    for ii:=1 until n-1 do begin                                 <<nsf>>37200000
      getcore(dcl'addr,6,ldevbuf);                               <<nsf>>37205000
      temp'addr:=double(dc'num'in'cl);                           <<nsf>>37210000
      dcl'addr:=dcl'addr+temp'addr+6d;                           <<nsf>>37215000
    end;                                                         <<nsf>>37220000
    getcore(dcl'addr,6,ldevbuf);                                 <<nsf>>37225000
    move buf(24):=devbuf(0),(8);                                 <<nsf>>37230000
  end;                                                           <<nsf>>37235000
  fmtcalendar(jmat'juldat,buf(33));                              <<nsf>>37240000
  move buf(36):=" ";                                             <<nsf>>37245000
  tos:=jmat'clk'tim'hi;                                          <<nsf>>37250000
  tos:=jmat'clk'tim'lo;                                          <<nsf>>37255000
  time:=tos;                                                     <<nsf>>37260000
  fmtclock(time,buf(37));                                        <<nsf>>37265000
  move buf(42):=buf(43),(1); move buf(43):=" ";                  <<nsf>>37270000
  outchar:=44;                                                   <<nsf>>37275000
  numchar:=0;                                                    <<nsf>>37280000
  for ii:=job'name'b until job'name'e do begin                   <<nsf>>37285000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>37290000
  end;                                                           <<nsf>>37295000
  if numchar>0 then begin                                        <<nsf>>37300000
    move buf(outchar):=bufferb(job'name'b),(numchar);            <<nsf>>37305000
    outchar:=outchar+numchar+1;                                  <<nsf>>37310000
    move buf(outchar-1):=",";                                    <<nsf>>37315000
  end;                                                           <<nsf>>37320000
  numchar:=0;                                                    <<nsf>>37325000
  for ii:=user'name'b until user'name'e do begin                 <<nsf>>37330000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>37335000
  end;                                                           <<nsf>>37340000
  if numchar>0 then begin                                        <<nsf>>37345000
    move buf(outchar):=bufferb(user'name'b),(numchar);           <<nsf>>37350000
    outchar:=outchar+numchar+1;                                  <<nsf>>37355000
    move buf(outchar-1):=".";                                    <<nsf>>37360000
  end;                                                           <<nsf>>37365000
  numchar:=0;                                                    <<nsf>>37370000
  for ii:=acct'name'b until acct'name'e do begin                 <<nsf>>37375000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>37380000
  end;                                                           <<nsf>>37385000
  if numchar>0 then begin                                        <<nsf>>37390000
    move buf(outchar):=bufferb(acct'name'b),(numchar);           <<nsf>>37395000
    outchar:=outchar+numchar+1;                                  <<nsf>>37400000
    move buf(outchar-1):=",";                                    <<nsf>>37405000
  end;                                                           <<nsf>>37410000
  numchar:=0;                                                    <<nsf>>37415000
  for ii:=grp'name'b until grp'name'e do begin                   <<nsf>>37420000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>37425000
  end;                                                           <<nsf>>37430000
  if numchar>0 then begin                                        <<nsf>>37435000
    move buf(outchar):=bufferb(grp'name'b),(numchar);            <<nsf>>37440000
  end;                                                           <<nsf>>37445000
                                                                 <<nsf>>37450000
  if jmat'main'pin <> 0 then begin                               <<nsf>>37455000
    ascii(jmat'main'pin,8,buf'wrk);                              <<nsf>>37460000
    for ii:=0 until 5 do begin                                   <<nsf>>37465000
      if buf'wrk(ii)<>"0" then go digit;                         <<nsf>>37470000
    end;                                                         <<nsf>>37475000
  digit:                                                         <<nsf>>37480000
    outchar:=6-ii;                                               <<nsf>>37485000
    move buf(11+ii):=buf'wrk(ii),(outchar);                      <<nsf>>37490000
  end else begin                                                 <<nsf>>37495000
    ascii(jmat'inpri,10,buf(15));                                <<nsf>>37500000
    move buf(13):="D"; end;                                      <<nsf>>37505000
  write'rec(prntfile,lbuf,-79,0);                                       37510000
                                                                 <<nsf>>37515000
  return;                                                        <<nsf>>37520000
                                                                 <<nsf>>37525000
end;  <<prntjob5>>                                               <<nsf>>37530000
$page   "                     PROCEDURE FMTJOBS5 "               <<nsf>>37535000
                                                                 <<nsf>>37540000
<<***********************************************************>>  <<nsf>>37545000
<<  fmtjobs5                                                 >>  <<nsf>>37550000
<<----------------------------------------------------------->>  <<nsf>>37555000
<<  this procedure will format the jmat table in much the    >>  <<nsf>>37560000
<<  same way that the mpe command 'showjob' does.            >>  <<nsf>>37565000
<<***********************************************************>>  <<nsf>>37570000
                                                                 <<nsf>>37575000
procedure fmtjobs5(prntfile);                                    <<nsf>>37580000
                                                                 <<nsf>>37585000
  value prntfile;                                                <<nsf>>37590000
  integer prntfile;                                              <<nsf>>37595000
                                                                 <<nsf>>37600000
  begin                                                          <<nsf>>37605000
  double locdst,locjmat,loc'dev'class,current,stopaddr,          <<nsf>>37610000
         ld'current,ld'stopaddr;                                 <<nsf>>37615000
  integer lenjmat,tot'jmat'words;                                <<nsf>>37620000
  equate jmat'ent'size=38,                                       <<nsf>>37625000
         dclas'ent'siz=1;                                        <<nsf>>37630000
  logical array buffer0(0:37);  << space for jmat vitals >>      <<nsf>>37635000
                                                                 <<nsf>>37640000
  logical array ldevbuf0(0:5);  << space for ldt vitals >>       <<nsf>>37645000
                                                                 <<nsf>>37650000
  define cc=status.(6:2)#;                                       <<nsf>>37655000
  define  jmatmax=buffer0(0).(0:8)#,                             <<nsf>>37660000
         jcursize=buffer0(0).(8:8)#,                             <<nsf>>37665000
        jvmntinfo=buffer0(1).(0:8)#,                             <<nsf>>37670000
       jmat'esize=buffer0(1).(8:8)#,                             <<nsf>>37675000
     jmat'ent'ptr=buffer0(2)#,                                   <<nsf>>37680000
     jmat'schhead=buffer0(3)#,                                   <<nsf>>37685000
     jmat'schtail=buffer0(4)#,                                   <<nsf>>37690000
       jmat'stype=buffer0(5).(0:2)#,                             <<nsf>>37695000
  jmat'nxt'ses'hi=buffer0(5).(2:14)#,                            <<nsf>>37700000
  jmat'nxt'ses'lo=buffer(6)#,                                    <<nsf>>37705000
       jmat'jtype=buffer0(7).(0:2)#,                             <<nsf>>37710000
  jmat'nxt'job'hi=buffer0(7).(2:14)#,                            <<nsf>>37715000
  jmat'nxt'job'lo=buffer0(8)#,                                   <<nsf>>37720000
      jmat'logoff=buffer0(9).(0:1)#,                             <<nsf>>37725000
     jmat'securty=buffer0(9).(1:2)#,                             <<nsf>>37730000
     jmat'sesfnce=buffer0(9).(8:4)#,                             <<nsf>>37735000
     jmat'jobfnce=buffer0(9).(12:4)#,                            <<nsf>>37740000
      jmat'slimit=buffer0(10)#,                                  <<nsf>>37745000
    jmat'cur'scnt=buffer0(11)#,                                  <<nsf>>37750000
      jmat'jlimit=buffer0(12)#,                                  <<nsf>>37755000
    jmat'cur'jcnt=buffer0(13)#;                                  <<nsf>>37760000
                                                                 <<nsf>>37765000
  define  dc'hiest'ent=ldevbuf0(0)#,                             <<nsf>>37770000
           dc'ent'size=ldevbuf0(1)#,                             <<nsf>>37775000
           dc'num'ents=ldevbuf0(2)#,                             <<nsf>>37780000
            dc'pointer=ldevbuf0(3)#,                             <<nsf>>37785000
          dc'num'tdt's=ldevbuf0(4)#,                             <<nsf>>37790000
            dc'tdt'ptr=ldevbuf0(5)#;                             <<nsf>>37795000
                                                                 <<nsf>>37800000
  locdst:=double(core(2d));                                      <<nsf>>37805000
  locjmat:=getdstaddr(25);                                       <<nsf>>37810000
  if <> then begin                                               <<nsf>>37815000
    printerror(49); return;                                      <<nsf>>37820000
  end;                                                           <<nsf>>37825000
  loc'dev'class:=getdstaddr(40);                                 <<nsf>>37830000
  if <> then begin                                               <<nsf>>37835000
    printerror(50); return;                                      <<nsf>>37840000
  end;                                                           <<nsf>>37845000
                                                                 <<nsf>>37850000
  lenjmat:=4*(core(locdst+double(%31*4)).(3:13));                <<nsf>>37855000
                                                                 <<nsf>>37860000
  getcore(locjmat,jmat'ent'size,buffer0);                        <<nsf>>37865000
  if <> then return;                                             <<nsf>>37870000
  if (jmat'esize <> jmat'ent'size) or                            <<nsf>>37875000
     (jmat'ent'ptr <> jmat'ent'size) or                          <<nsf>>37880000
     (jmat'stype <> 1) or                                        <<nsf>>37885000
     (jmat'jtype <> 2) then begin                                <<nsf>>37890000
       printerror(48);                                           <<nsf>>37895000
       return;                                                   <<nsf>>37900000
  end;                                                           <<nsf>>37905000
                                                                 <<nsf>>37910000
  getcore(loc'dev'class,6,ldevbuf0);                             <<nsf>>37915000
  if <> then return;                                             <<nsf>>37920000
  if dc'ent'size <> dclas'ent'siz then begin                     <<nsf>>37925000
    printerror(51);                                              <<nsf>>37930000
    return;                                                      <<nsf>>37935000
  end;                                                           <<nsf>>37940000
                                                                 <<nsf>>37945000
  move buf(0):=" ";                                              <<nsf>>37950000
  move buf(1):=buf,(79);                                         <<nsf>>37955000
  move buf:=                                                     <<nsf>>37960000
    "JOBNUM STATE UMAIN JIN  JLIST    INTRODUCED JOB NAME";      <<nsf>>37965000
  write'rec(prntfile,lbuf,-79,0);                                       37970000
  move buf(0):=" ";                                              <<nsf>>37975000
  move buf(1):=buf,(79);                                         <<nsf>>37980000
  move buf(14):="PIN#";                                          <<nsf>>37985000
  write'rec(prntfile,lbuf,-20,0);                                       37990000
  move buf(14):="    ";                                          <<nsf>>37995000
                                                                 <<nsf>>38000000
  tot'jmat'words:=jcursize*128;                                  <<nsf>>38005000
  stopaddr:=locjmat+double(tot'jmat'words);                      <<nsf>>38010000
  current:=locjmat+double(jmat'ent'size);                        <<nsf>>38015000
  ld'current:=loc'dev'class+double(dc'pointer);                  <<nsf>>38020000
                                                                 <<nsf>>38025000
  while current < (stopaddr - double (jmat'ent'size))          <<dougw>>38030000
        and not stop'print  do begin                                    38035000
    if ctrly then begin                                          <<nsf>>38040000
      write'rec(prntfile,lbuf,0,0); <<start a new line>>                38045000
      move buf:=" <CONTROL-Y>";                                  <<nsf>>38050000
      write'rec(prntfile,lbuf,-12,%60);                                 38055000
      return;                                                    <<nsf>>38060000
    end;                                                         <<nsf>>38065000
    prntjob5(prntfile,current,ld'current);                       <<nsf>>38070000
    current:=current+double(jmat'ent'size);                      <<nsf>>38075000
  end;                                                           <<nsf>>38080000
                                                                 <<nsf>>38085000
  move buf(0):=" ";                                              <<nsf>>38090000
  move buf(1):=buf,(79);                                         <<nsf>>38095000
  write'rec(prntfile,lbuf,-1,0);                                        38100000
                                                                 <<nsf>>38105000
  ascii(jmat'cur'scnt,10,buf(2));                                <<nsf>>38110000
  move buf(6):="SESSIONS,";                                      <<nsf>>38115000
  ascii(jmat'cur'jcnt,10,buf(16));                               <<nsf>>38120000
  move buf(20):="JOBS";                                          <<nsf>>38125000
  write'rec(prntfile,lbuf,-30,0);                                       38130000
                                                                 <<nsf>>38135000
  move buf(0):=" "; move buf(1):=buf,(30);                       <<nsf>>38140000
  move buf:=" JOB LIMIT =     SESSION LIMIT = ";                 <<nsf>>38145000
  ascii(jmat'jlimit,10,buf(13));                                 <<nsf>>38150000
  ascii(jmat'slimit,10,buf(33));                                 <<nsf>>38155000
  write'rec(prntfile,lbuf,-40,0);                                       38160000
                                                                 <<nsf>>38165000
  move buf(0):=" "; move buf(1):=buf,(40);                       <<nsf>>38170000
  move buf:=" JOBFENCE = ";                                      <<nsf>>38175000
  ascii(jmat'jobfnce,10,buf(12));                                <<nsf>>38180000
  write'rec(prntfile,lbuf,-20,0);                                       38185000
                                                                 <<nsf>>38190000
  move buf(0):=" "; move buf(1):=buf,(20);                       <<nsf>>38195000
  move buf:=" JOBSECURITY = ";                                   <<nsf>>38200000
  if jmat'securty=0 then                                         <<nsf>>38205000
    move buf(15):="HIGH"                                         <<nsf>>38210000
  else                                                           <<nsf>>38215000
    move buf(15):="LOW ";                                        <<nsf>>38220000
  write'rec(prntfile,lbuf,-20,0);                                       38225000
                                                                 <<nsf>>38230000
  return;                                                        <<nsf>>38235000
end;  <<fmtjobs5>>                                               <<nsf>>38240000
$page"                        PROCEDURE PRNTJOB4"                       38245000
<<***********************************************************>>  <<nsf>>38250000
<<  prntjob4                                                 >>  <<nsf>>38255000
<<----------------------------------------------------------->>  <<nsf>>38260000
<<  this procedure takes the contents of a 26 word buffer    >>  <<nsf>>38265000
<<  and formats one line of output as a :showjob emulator    >>  <<nsf>>38270000
<<***********************************************************>>  <<nsf>>38275000
                                                                 <<nsf>>38280000
procedure prntjob4(prntfile,addr,dcl'addr);                      <<nsf>>38285000
                                                                 <<nsf>>38290000
value prntfile,addr,dcl'addr;                                    <<nsf>>38295000
integer prntfile;                                                <<nsf>>38300000
double addr,dcl'addr;                                            <<nsf>>38305000
                                                                 <<nsf>>38310000
begin                                                            <<nsf>>38315000
                                                                 <<nsf>>38320000
  define  jmat'state=buffer(0).(0:6)#,                           <<nsf>>38325000
         jmat'duplic=buffer(0).(6:1)#,                           <<nsf>>38330000
          jmat'inter=buffer(0).(7:1)#,                           <<nsf>>38335000
          jmat'quiet=buffer(0).(8:1)#,                           <<nsf>>38340000
       jmat'stdl'del=buffer(0).(9:1)#,                           <<nsf>>38345000
       jmat'usr'pswd=buffer(0).(10:1)#,                          <<nsf>>38350000
      jmat'devcl'idx=buffer(0).(11:1)#,                          <<nsf>>38355000
          jmat'inpri=buffer(0).(12:4)#,                          <<nsf>>38360000
           jmat'type=buffer(1).(0:2)#,                           <<nsf>>38365000
         jmat'number=buffer(1).(2:14)#,                          <<nsf>>38370000
        jmat'usernam=buffer(2)#,                                 <<nsf>>38375000
        jmat'acctnam=buffer(6)#,                                 <<nsf>>38380000
         jmat'jobnam=buffer(10)#,                                <<nsf>>38385000
        jmat'logonam=buffer(14)#,                                <<nsf>>38390000
        jmat'jin'dev=buffer(18).(0:8)#,                          <<nsf>>38395000
       jmat'jlst'dev=buffer(18).(8:8)#,                          <<nsf>>38400000
         jmat'juldat=buffer(19)#,                                <<nsf>>38405000
     jmat'clk'tim'hi=buffer(20)#,                                <<nsf>>38410000
     jmat'clk'tim'lo=buffer(21)#,                                <<nsf>>38415000
       jmat'main'pin=buffer(22).(0:8)#,                          <<nsf>>38420000
           jmat'xpri=buffer(22).(8:8)#,                          <<nsf>>38425000
        jmat'cpu'lim=buffer(23)#,                                <<nsf>>38430000
     jmat'orig'spool=buffer(24).(0:1)#,                          <<nsf>>38435000
     jmat'job'restrt=buffer(24).(1:1)#,                          <<nsf>>38440000
     jmat'job'seqncd=buffer(24).(2:1)#,                          <<nsf>>38445000
     jmat'funny'term=buffer(24).(3:2)#,                          <<nsf>>38450000
         jmat'outpri=buffer(24).(5:4)#,                          <<nsf>>38455000
       jmat'num'copy=buffer(24).(9:7)#,                          <<nsf>>38460000
        jmat'origjin=buffer(25).(0:8)#,                          <<nsf>>38465000
      jmat'origjlist=buffer(25).(8:8)#;                          <<nsf>>38470000
                                                                 <<nsf>>38475000
  define  dc'cyclic=ldevbuf(4).(1:7)#,                           <<nsf>>38480000
         dc'spool'q=ldevbuf(4).(8:1)#,                           <<nsf>>38485000
        dc'term'acc=ldevbuf(4).(9:1)#,                           <<nsf>>38490000
        dc'acc'type=ldevbuf(4).(10:6)#,                          <<nsf>>38495000
       dc'num'in'cl=ldevbuf(5).(0:8)#;                           <<nsf>>38500000
                                                                 <<nsf>>38505000
  integer n,ii,numchar,outchar;                                  <<nsf>>38510000
  logical array buffer(0:25);                                    <<nsf>>38515000
  byte array bufferb(*)=buffer;                                  <<nsf>>38520000
  logical array ldevbuf(0:39);                                   <<nsf>>38525000
  byte array devbuf(*)=ldevbuf;                                  <<nsf>>38530000
  logical array buf'wrk'l(0:2);                                  <<nsf>>38535000
  byte array buf'wrk(*)=buf'wrk'l;                               <<nsf>>38540000
                                                                 <<nsf>>38545000
  double time,temp'addr;                                         <<nsf>>38550000
                                                                 <<nsf>>38555000
  logical pointer clas'nam'ptr;                                  <<nsf>>38560000
  byte pointer b'clas'nam'ptr;                                   <<nsf>>38565000
                                                                 <<nsf>>38570000
  equate entry'length = 26,                                      <<nsf>>38575000
         free'entry=0,                                           <<nsf>>38580000
              intro=1,                                           <<nsf>>38585000
               wait=%40,                                         <<nsf>>38590000
               init=%60,                                         <<nsf>>38595000
               exec=2,                                           <<nsf>>38600000
        terminating=3,                                           <<nsf>>38605000
          suspended=4,                                           <<nsf>>38610000
            session=1,                                           <<nsf>>38615000
                job=2,                                           <<nsf>>38620000
        user'name'b=4,                                           <<nsf>>38625000
        user'name'e=11,                                          <<nsf>>38630000
        acct'name'b=12,                                          <<nsf>>38635000
        acct'name'e=19,                                          <<nsf>>38640000
         grp'name'b=28,                                          <<nsf>>38645000
         grp'name'e=35,                                          <<nsf>>38650000
         job'name'b=20,                                          <<nsf>>38655000
         job'name'e=27;                                          <<nsf>>38660000
                                                                 <<nsf>>38665000
  @clas'nam'ptr:=@ldevbuf;                                       <<nsf>>38670000
  @b'clas'nam'ptr:=@devbuf;                                      <<nsf>>38675000
                                                                 <<nsf>>38680000
  getcore(addr,entry'length,buffer);                             <<nsf>>38685000
  if jmat'state=free'entry then return;                          <<nsf>>38690000
  move buf(0):=" ";  move buf(1):=buf,(79);                      <<nsf>>38695000
  move buf:="#";                                                 <<nsf>>38700000
  if jmat'type=session then begin                                <<nsf>>38705000
    move buf(1):="S"; end                                        <<nsf>>38710000
  else begin                                                     <<nsf>>38715000
    move buf(1):="J";                                            <<nsf>>38720000
  end;                                                           <<nsf>>38725000
  ascii(jmat'number,10,buf(2));                                  <<nsf>>38730000
  if jmat'state=wait then begin                                  <<nsf>>38735000
    move buf(8):="WAIT"; end                                     <<nsf>>38740000
  else if jmat'state=init then begin                             <<nsf>>38745000
      move buf(8):="INIT"; end                                   <<nsf>>38750000
    else begin                                                   <<nsf>>38755000
      case jmat'state of begin                                   <<nsf>>38760000
        <<free entry>> ;                                         <<nsf>>38765000
        <<intro>> begin                                          <<nsf>>38770000
                  move buf(7):="INTRO";                          <<nsf>>38775000
                  end;                                           <<nsf>>38780000
        <<exec>>  begin                                          <<nsf>>38785000
                  move buf(8):="EXEC";                           <<nsf>>38790000
                  end;                                           <<nsf>>38795000
        <<term.>> begin                                          <<nsf>>38800000
                  move buf(8):="TERM";                           <<nsf>>38805000
                  end;                                           <<nsf>>38810000
        <<susp>>  begin                                          <<nsf>>38815000
                  move buf(8):="SUSP";                           <<nsf>>38820000
                  end;                                           <<nsf>>38825000
      end;  <<case>>                                             <<nsf>>38830000
    end;                                                         <<nsf>>38835000
                                                                 <<nsf>>38840000
  if jmat'type=job then begin                                    <<nsf>>38845000
    if jmat'devcl'idx then begin                                 <<nsf>>38850000
      if jmat'state=wait then ascii(jmat'jin'dev,10,buf(20))     <<nsf>>38855000
      else ascii(jmat'origjin,10,buf(20));                       <<nsf>>38860000
      if jmat'orig'spool then move buf(22):="S";                 <<nsf>>38865000
    end;                                                         <<nsf>>38870000
  end                                                            <<nsf>>38875000
  else begin                                                     <<nsf>>38880000
    if jmat'jin'dev<100 then                                     <<nsf>>38885000
      ascii(jmat'jin'dev,10,buf(20))                             <<nsf>>38890000
    else                                                         <<nsf>>38895000
      ascii(jmat'jin'dev,10,buf(19));                            <<nsf>>38900000
  end;                                                           <<nsf>>38905000
  if jmat'type=session then                                      <<nsf>>38910000
    ascii(jmat'jlst'dev,10,buf(24))                              <<nsf>>38915000
  else begin                                                     <<nsf>>38920000
    if jmat'state=wait then n:=jmat'jlst'dev                     <<nsf>>38925000
    else n:=jmat'origjlist;                                      <<nsf>>38930000
    for ii:=1 until n-1 do begin                                 <<nsf>>38935000
      getcore(dcl'addr,6,ldevbuf);                               <<nsf>>38940000
      temp'addr:=double(dc'num'in'cl);                           <<nsf>>38945000
      temp'addr:=temp'addr/2d+6d;                                <<nsf>>38950000
      dcl'addr:=dcl'addr+temp'addr;                              <<nsf>>38955000
    end;                                                         <<nsf>>38960000
    getcore(dcl'addr,6,ldevbuf);                                 <<nsf>>38965000
    move buf(24):=devbuf(0),(8);                                 <<nsf>>38970000
  end;                                                           <<nsf>>38975000
  fmtcalendar(jmat'juldat,buf(33));                              <<nsf>>38980000
  move buf(36):=" ";                                             <<nsf>>38985000
  tos:=jmat'clk'tim'hi;                                          <<nsf>>38990000
  tos:=jmat'clk'tim'lo;                                          <<nsf>>38995000
  time:=tos;                                                     <<nsf>>39000000
  fmtclock(time,buf(37));                                        <<nsf>>39005000
  move buf(42):=buf(43),(1); move buf(43):=" ";                  <<nsf>>39010000
  outchar:=44;                                                   <<nsf>>39015000
  numchar:=0;                                                    <<nsf>>39020000
  for ii:=job'name'b until job'name'e do begin                   <<nsf>>39025000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>39030000
  end;                                                           <<nsf>>39035000
  if numchar>0 then begin                                        <<nsf>>39040000
    move buf(outchar):=bufferb(job'name'b),(numchar);            <<nsf>>39045000
    outchar:=outchar+numchar+1;                                  <<nsf>>39050000
    move buf(outchar-1):=",";                                    <<nsf>>39055000
  end;                                                           <<nsf>>39060000
  numchar:=0;                                                    <<nsf>>39065000
  for ii:=user'name'b until user'name'e do begin                 <<nsf>>39070000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>39075000
  end;                                                           <<nsf>>39080000
  if numchar>0 then begin                                        <<nsf>>39085000
    move buf(outchar):=bufferb(user'name'b),(numchar);           <<nsf>>39090000
    outchar:=outchar+numchar+1;                                  <<nsf>>39095000
    move buf(outchar-1):=".";                                    <<nsf>>39100000
  end;                                                           <<nsf>>39105000
  numchar:=0;                                                    <<nsf>>39110000
  for ii:=acct'name'b until acct'name'e do begin                 <<nsf>>39115000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>39120000
  end;                                                           <<nsf>>39125000
  if numchar>0 then begin                                        <<nsf>>39130000
    move buf(outchar):=bufferb(acct'name'b),(numchar);           <<nsf>>39135000
    outchar:=outchar+numchar+1;                                  <<nsf>>39140000
    move buf(outchar-1):=",";                                    <<nsf>>39145000
  end;                                                           <<nsf>>39150000
  numchar:=0;                                                    <<nsf>>39155000
  for ii:=grp'name'b until grp'name'e do begin                   <<nsf>>39160000
    if bufferb(ii)<>" " then numchar:=numchar+1;                 <<nsf>>39165000
  end;                                                           <<nsf>>39170000
  if numchar>0 then begin                                        <<nsf>>39175000
    move buf(outchar):=bufferb(grp'name'b),(numchar);            <<nsf>>39180000
  end;                                                           <<nsf>>39185000
  if jmat'main'pin <> 0 then begin                               <<nsf>>39190000
    ascii(jmat'main'pin,8,buf'wrk);                              <<nsf>>39195000
    for ii:=0 until 5 do begin                                   <<nsf>>39200000
      if buf'wrk(ii)<>"0" then go digit;                         <<nsf>>39205000
    end;                                                         <<nsf>>39210000
  digit:                                                         <<nsf>>39215000
    outchar:=6-ii;                                               <<nsf>>39220000
    move buf(11+ii):=buf'wrk(ii),(outchar);                      <<nsf>>39225000
  end else begin                                                 <<nsf>>39230000
    ascii(jmat'inpri,10,buf(15));                                <<nsf>>39235000
    move buf(13):="D"; end;                                      <<nsf>>39240000
  write'rec(prntfile,lbuf,-79,0);                                       39245000
  return;                                                        <<nsf>>39250000
                                                                 <<nsf>>39255000
end;  <<prntjob4>>                                               <<nsf>>39260000
$page   "                     PROCEDURE FMTJOBS4 "               <<nsf>>39265000
<<***********************************************************>>  <<nsf>>39270000
<<  fmtjobs4                                                 >>  <<nsf>>39275000
<<----------------------------------------------------------->>  <<nsf>>39280000
<<  this procedure will format the jmat table in much the    >>  <<nsf>>39285000
<<  same way that the mpe command 'showjob' does.            >>  <<nsf>>39290000
<<***********************************************************>>  <<nsf>>39295000
                                                                 <<nsf>>39300000
procedure fmtjobs4(prntfile);                                    <<nsf>>39305000
                                                                 <<nsf>>39310000
  value prntfile;                                                <<nsf>>39315000
  integer prntfile;                                              <<nsf>>39320000
                                                                 <<nsf>>39325000
  begin                                                          <<nsf>>39330000
  double locdst,locjmat,loc'dev'class,current,stopaddr,          <<nsf>>39335000
         ld'current,ld'stopaddr;                                 <<nsf>>39340000
  integer lenjmat,tot'jmat'words;                                <<nsf>>39345000
  equate jmat'ent'size=26,                                       <<nsf>>39350000
         dclas'ent'siz=5;                                        <<nsf>>39355000
  logical array buffer0(0:25);  << space for jmat vitals >>      <<nsf>>39360000
                                                                 <<nsf>>39365000
  logical array ldevbuf0(0:4);  << space for ldt vitals >>       <<nsf>>39370000
                                                                 <<nsf>>39375000
  define cc=status.(6:2)#;                                       <<nsf>>39380000
  define  jmatmax=buffer0(0).(0:8)#,                             <<nsf>>39385000
         jcursize=buffer0(0).(8:8)#,                             <<nsf>>39390000
        jvmntinfo=buffer0(1).(0:8)#,                             <<nsf>>39395000
       jmat'esize=buffer0(1).(8:8)#,                             <<nsf>>39400000
     jmat'ent'ptr=buffer0(2)#,                                   <<nsf>>39405000
     jmat'schhead=buffer0(3)#,                                   <<nsf>>39410000
     jmat'schtail=buffer0(4)#,                                   <<nsf>>39415000
       jmat'stype=buffer0(5).(0:2)#,                             <<nsf>>39420000
     jmat'nxt'ses=buffer0(5).(2:14)#,                            <<nsf>>39425000
       jmat'jtype=buffer0(6).(0:2)#,                             <<nsf>>39430000
     jmat'nxt'job=buffer0(6).(2:14)#,                            <<nsf>>39435000
      jmat'logoff=buffer0(7).(0:1)#,                             <<nsf>>39440000
     jmat'securty=buffer0(7).(1:2)#,                             <<nsf>>39445000
     jmat'jobfnce=buffer0(7).(12:4)#,                            <<nsf>>39450000
      jmat'slimit=buffer0(8)#,                                   <<nsf>>39455000
    jmat'cur'scnt=buffer0(9)#,                                   <<nsf>>39460000
      jmat'jlimit=buffer0(10)#,                                  <<nsf>>39465000
    jmat'cur'jcnt=buffer0(11)#;                                  <<nsf>>39470000
                                                                 <<nsf>>39475000
  define  dc'hiest'ent=ldevbuf0(0).(0:8)#,                       <<nsf>>39480000
           dc'ent'size=ldevbuf0(0).(8:8)#,                       <<nsf>>39485000
            dc'pointer=ldevbuf0(1)#,                             <<nsf>>39490000
           dc'num'ents=ldevbuf0(2)#,                             <<nsf>>39495000
          dc'table'siz=ldevbuf0(3)#,                             <<nsf>>39500000
           dc'strm'dev=ldevbuf0(4)#;                             <<nsf>>39505000
                                                                 <<nsf>>39510000
  locdst:=double(core(2d));                                      <<nsf>>39515000
  locjmat:=getdstaddr(25);                                       <<nsf>>39520000
  if <> then begin                                               <<nsf>>39525000
    printerror(49); return;                                      <<nsf>>39530000
  end;                                                           <<nsf>>39535000
  loc'dev'class:=getdstaddr(14);                                 <<nsf>>39540000
  if <> then begin                                               <<nsf>>39545000
    printerror(50); return;                                      <<nsf>>39550000
  end;                                                           <<nsf>>39555000
                                                                 <<nsf>>39560000
  lenjmat:=4*(core(locdst+double(%31*4)).(3:13));                <<nsf>>39565000
                                                                 <<nsf>>39570000
  getcore(locjmat,jmat'ent'size,buffer0);                        <<nsf>>39575000
  if <> then return;                                             <<nsf>>39580000
  if (jmat'esize <> jmat'ent'size) or                            <<nsf>>39585000
     (jmat'ent'ptr <> jmat'ent'size) or                          <<nsf>>39590000
     (jmat'stype <> 1) or                                        <<nsf>>39595000
     (jmat'jtype <> 2) then begin                                <<nsf>>39600000
       printerror(48);                                           <<nsf>>39605000
       return;                                                   <<nsf>>39610000
  end;                                                           <<nsf>>39615000
                                                                 <<nsf>>39620000
  getcore(loc'dev'class,5,ldevbuf0);                             <<nsf>>39625000
  if <> then return;                                             <<nsf>>39630000
  if dc'ent'size <> dclas'ent'siz then begin                     <<nsf>>39635000
    printerror(51);                                              <<nsf>>39640000
    return;                                                      <<nsf>>39645000
  end;                                                           <<nsf>>39650000
                                                                 <<nsf>>39655000
  move buf(0):=" ";                                              <<nsf>>39660000
  move buf(1):=buf,(79);                                         <<nsf>>39665000
  move buf:=                                                     <<nsf>>39670000
    "JOBNUM STATE UMAIN JIN  JLIST    INTRODUCED JOB NAME";      <<nsf>>39675000
  write'rec(prntfile,lbuf,-79,0);                                       39680000
  move buf(0):=" ";                                              <<nsf>>39685000
  move buf(1):=buf,(79);                                         <<nsf>>39690000
  move buf(14):="PIN#";                                          <<nsf>>39695000
  write'rec(prntfile,lbuf,-20,0);                                       39700000
  move buf(14):="    ";                                          <<nsf>>39705000
                                                                 <<nsf>>39710000
  tot'jmat'words:=jcursize*128;                                  <<nsf>>39715000
  stopaddr:=locjmat+double(tot'jmat'words);                      <<nsf>>39720000
  current:=locjmat+double(jmat'ent'size);                        <<nsf>>39725000
  ld'current:=loc'dev'class+double(dc'pointer);                  <<nsf>>39730000
                                                                 <<nsf>>39735000
  while current < (stopaddr - double (jmat'ent'size))            <<nsf>>39740000
        and not stop'print  do begin                                    39745000
    if ctrly then begin                                          <<nsf>>39750000
      write'rec(prntfile,lbuf,0,0); <<start a new line>>                39755000
      move buf:=" <CONTROL-Y>";                                  <<nsf>>39760000
      write'rec(prntfile,lbuf,-12,%60);                                 39765000
      return;                                                    <<nsf>>39770000
    end;                                                         <<nsf>>39775000
    prntjob4(prntfile,current,ld'current);                       <<nsf>>39780000
    current:=current+double(jmat'ent'size);                      <<nsf>>39785000
  end;                                                           <<nsf>>39790000
                                                                 <<nsf>>39795000
  move buf(0):=" ";                                              <<nsf>>39800000
  move buf(1):=buf,(79);                                         <<nsf>>39805000
  write'rec(prntfile,lbuf,-1,0);                                        39810000
                                                                 <<nsf>>39815000
  ascii(jmat'cur'scnt,10,buf(2));                                <<nsf>>39820000
  move buf(6):="SESSIONS,";                                      <<nsf>>39825000
  ascii(jmat'cur'jcnt,10,buf(16));                               <<nsf>>39830000
  move buf(20):="JOBS";                                          <<nsf>>39835000
  write'rec(prntfile,lbuf,-30,0);                                       39840000
                                                                 <<nsf>>39845000
  move buf(0):=" "; move buf(1):=buf,(30);                       <<nsf>>39850000
  move buf:=" JOB LIMIT =     SESSION LIMIT = ";                 <<nsf>>39855000
  ascii(jmat'jlimit,10,buf(13));                                 <<nsf>>39860000
  ascii(jmat'slimit,10,buf(33));                                 <<nsf>>39865000
  write'rec(prntfile,lbuf,-40,0);                                       39870000
                                                                 <<nsf>>39875000
  move buf(0):=" "; move buf(1):=buf,(40);                       <<nsf>>39880000
  move buf:=" JOBFENCE = ";                                      <<nsf>>39885000
  ascii(jmat'jobfnce,10,buf(12));                                <<nsf>>39890000
  write'rec(prntfile,lbuf,-20,0);                                       39895000
                                                                 <<nsf>>39900000
  move buf(0):=" "; move buf(1):=buf,(20);                       <<nsf>>39905000
  move buf:=" JOBSECURITY = ";                                   <<nsf>>39910000
  if jmat'securty=0 then                                         <<nsf>>39915000
    move buf(15):="HIGH"                                         <<nsf>>39920000
  else                                                           <<nsf>>39925000
    move buf(15):="LOW ";                                        <<nsf>>39930000
  write'rec(prntfile,lbuf,-20,0);                                       39935000
                                                                 <<nsf>>39940000
  return;                                                        <<nsf>>39945000
                                                                 <<nsf>>39950000
end;  <<fmtjobs4>>                                               <<nsf>>39955000
$page   "                     PROCEDURE FMTSIR    "                     39960000
$control segment=idat4                                                  39965000
<<***********************************************************>>         39970000
<<  fmtsir                                                   >>         39975000
<<----------------------------------------------------------->>         39980000
<<  this procedure will format locked sirs and the impeded   >>         39985000
<<  list if any. if no sirs are locked then "NO LOCKED SIRS" >>         39990000
<<  will be formated;                                        >>         39995000
<<***********************************************************>>         40000000
                                                                        40005000
procedure fmtsir(prntfile);                                             40010000
                                                                        40015000
   value prntfile;                                                      40020000
   integer prntfile;                                                    40025000
                                                                        40030000
   begin                                                                40035000
                                                                        40040000
   integer count,cnt2,indx,lsir,pcbsize,pcb'entries,pcbcount;           40045000
   integer array impdrs(0:1023);                                        40050000
   integer array hldrs'impd(0:1023);                                    40055000
   own byte array pcbname(0:9):="PCB TABLE";                            40060000
   double locsir,locdst,locpcb;                                         40065000
   logical work1,work2,work3,work4,work5;                               40070000
   logical array sirpin(0:1023);                                        40075000
   logical pcbentsize,nimppin;                                          40080000
   double pcbaddr;                                                      40085000
   integer sir'ent'size;                                                40090000
   pcbaddr:=getdstaddr(3);                                              40095000
   sir'ent'size:=2+(mpeversion-4)*2;                                    40100000
   nimppin:=8+(mpeversion-4)*9;                                         40105000
   pcbsize:=%20+(mpeversion-4)*5;  << used in a define later >>         40110000
                                                                        40115000
   if mpeversion = 4 then                                               40120000
     begin                                                              40125000
     tos:=0;                                                            40130000
     tos:=core(3d);                                                     40135000
     locpcb:=tos;                                                       40140000
     end                                                                40145000
   else                                                                 40150000
     locpcb:=getdstaddr(3);                                             40155000
   locdst:=double(core(2d));<< define dst base>>                        40160000
   locsir := getdstaddr(%53);                                           40165000
   impdrs := 0;                                                         40170000
   move impdrs(1) := impdrs, (1023);                                    40175000
   move hldrs'impd := impdrs, (1024);                                   40180000
   lsir:=4*(core(locdst+double(4*%53)).(3:13));<<length sir dst>>       40185000
                                                                        40190000
   << initialize table of impeded/valid/active pins >>                  40195000
   << this table prevents looping when printing sirs>>                  40200000
   << the table is accessed indexed by pin:         >>                  40205000
   <<    value        meaning                       >>                  40210000
   <<      0      pin is not impeded                >>                  40215000
   <<      1      pin is waiting for current sir    >>                  40220000
   <<      2      pin cannot be waiting for sir     >>                  40225000
   <<      3      pin is <1 or >nentries            >>                  40230000
   <<      4      pin is waiting for another sir    >>                  40235000
                                                                        40240000
   pcb'entries:=integer(core(locpcb));                                  40245000
   indx:=-1;                                                            40250000
   while (indx:=indx+1) <= 1023 do                                      40255000
     begin                                                              40260000
     sirpin(indx):=0;                                                   40265000
     if((indx<1) or (indx>pcb'entries))then sirpin(indx):=3;            40270000
     if isfree(indx) or (pcb13.(0:1)=1) or (pcb04.(13:1)=0)             40275000
        then sirpin(indx):=2;                                           40280000
     end;                                                               40285000
                                                                        40290000
   indx:=0; count:=0;                                                   40295000
   while (indx:=indx+sir'ent'size) < lsir do                            40300000
      begin                                                             40305000
      work1:=core(locsir+double(indx))/        <<get sir entry>>        40310000
          logical(pcbsize);                                             40315000
      work2:=core(locsir+double(indx+1));<<if mpev, sir que len>>       40320000
      if mpeversion = 5 then                                            40325000
        begin                                                           40330000
        work4:=core(locsir+double(indx+2))/       <<pin # head>>        40335000
            logical(pcbsize);                                           40340000
        work5:=core(locsir+double(indx+3))/       <<pin # tail>>        40345000
            logical(pcbsize);                                           40350000
        end                                                             40355000
      else                                                              40360000
        begin                                                           40365000
        work4:=work2.(8:8);  <<pin # head>>                             40370000
        work5:=work2.(0:8);  <<pin # of tail>>                          40375000
        end;                                                            40380000
      if work1=0 then go aend; <<free sir>>                             40385000
      count:=count+1;   <<count locked sirs>>                           40390000
      buf:=" ";  move buf(1):=buf, (79);                                40395000
      write'rec(prntfile,lbuf,-79,0);                                   40400000
      move buf:="SIR #    LOCKED BY PIN # ";                            40405000
      @pbuf:=@buf+2;                                                    40410000
      if mpeversion=4 then work3:=work1.(0:8)                           40415000
      else work3:=work1;                                                40420000
      putnump(indx/sir'ent'size);            <<sir#>>                   40425000
      @pbuf:=@buf+21;                                                   40430000
      putnump(work3);    <<pin#>>                                       40435000
      if (indx/sir'ent'size)>%47+(mpeversion-4)*3                       40440000
      then go cout;                                                     40445000
      case * (indx/sir'ent'size) of begin  <<cases>>                    40450000
        begin  <<0>>                                                    40455000
        end;                                                            40460000
        begin  <<1>>                                                    40465000
          move buf(40):="LOAD PROCESS SIR";                             40470000
        end;                                                            40475000
        begin  <<2>>                                                    40480000
          if mpeversion=4 then move buf(40):="LOCK SEGMENT SIR"         40485000
          else move buf(40):="CACHE CONTROL";                           40490000
        end;                                                            40495000
        begin  <<3>>                                                    40500000
          move buf(40):="IDD";                                          40505000
        end;                                                            40510000
        begin  <<4>>                                                    40515000
          move buf(40):="ODD";                                          40520000
        end;                                                            40525000
        begin  <<5>>                                                    40530000
          move buf(40):="PROCESS TREE STRUCTURE";                       40535000
        end;                                                            40540000
        begin  <<6>>                                                    40545000
          move buf(40):="SCHEDULING QUEUE";                             40550000
        end;                                                            40555000
        begin  <<7>>                                                    40560000
          move buf(40):="CST ENTRIES";                                  40565000
        end;                                                            40570000
        begin  <<10>>                                                   40575000
          move buf(40):="SYSTEM DIRECTORY";                             40580000
        end;                                                            40585000
        begin  <<11>>                                                   40590000
          move buf(40):="LPDT";                                         40595000
        end;                                                            40600000
        begin  <<12>>                                                   40605000
          move buf(40):="LDT";                                          40610000
        end;                                                            40615000
        begin  <<13>>                                                   40620000
          move buf(40):="STORAGE IN OVERLAY AREA";                      40625000
        end;                                                            40630000
        begin  <<14>>                                                   40635000
          move buf(40):="DISC FREE SPACE TABLE";                        40640000
        end;                                                            40645000
        begin  <<15>>                                                   40650000
          move buf(40):="JPCNT";                                        40655000
        end;                                                            40660000
        begin  <<16>>                                                   40665000
          move buf(40):="JCUT";                                         40670000
        end;                                                            40675000
        begin  <<17>>                                                   40680000
          move buf(40):="JMAT";                                         40685000
        end;                                                            40690000
        begin  <<20>>                                                   40695000
          move buf(40):="FMAVT";                                        40700000
        end;                                                            40705000
        begin  <<21>>                                                   40710000
          move buf(40):="LOADER SEGMENT TABLE";                         40715000
        end;                                                            40720000
        begin  <<22>>                                                   40725000
          move buf(40):="VDD";                                          40730000
        end;                                                            40735000
        begin <<23>>                                                    40740000
          move buf(40):="SPOOL";                                        40745000
        end;                                                            40750000
        begin  <<24>>                                                   40755000
          move buf(40):="MESSAGE CATALOGUE";                            40760000
        end;                                                            40765000
        begin  <<25>>                                                   40770000
          move buf(40):="RIT";                                          40775000
        end;                                                            40780000
        begin  <<26>>                                                   40785000
          move buf(40):="VOLUME TABLE";                                 40790000
        end;                                                            40795000
        begin  <<27>>                                                   40800000
          move buf(40):="WELCOME MESSAGE SIR";                          40805000
        end;                                                            40810000
        begin  <<30>>                                                   40815000
          move buf(40):="ASSOCIATION TABLE SIR";                        40820000
        end;                                                            40825000
        begin  <<31>>                                                   40830000
          move buf(40):="CS ALLOCATE SIR";                              40835000
        end;                                                            40840000
        begin  <<32>>                                                   40845000
          move buf(40):="LOGGING BUFFER";                               40850000
        end;                                                            40855000
        begin  <<33>>                                                   40860000
          move buf(40):="PRIVATE VOL. MVTAB";                           40865000
        end;                                                            40870000
        begin  <<34>>                                                   40875000
           move buf(40):="MEAS. SIR";                                   40880000
        end;                                                            40885000
        begin  <<35>>                                                   40890000
          move buf(40):="PRIVATE VOL. USER TABLE";                      40895000
        end;                                                            40900000
        begin  <<36>>                                                   40905000
          move buf(40):="IMAGE";                                        40910000
        end;                                                            40915000
        begin  <<37>>                                                   40920000
          move buf(40):="KSAM";                                         40925000
        end;                                                            40930000
        begin  <<40>>                                                   40935000
          move buf(40):="USER LOGGING";                                 40940000
        end;                                                            40945000
        begin  <<41>>                                                   40950000
          move buf(40):="DEBUG BREAK PT. TABLE";                        40955000
        end;                                                            40960000
        begin  <<42>>                                                   40965000
          move buf(40):="PCB SIR";                                      40970000
        end;                                                            40975000
        begin  <<43>>                                                   40980000
          move buf(40):="SUB-QUEUE MAPPING TABLE";                      40985000
        end;                                                            40990000
        begin  <<44>>                                                   40995000
          move buf(40):="CILOG";                                        41000000
        end;                                                            41005000
        begin  <<45>>                                                   41010000
          move buf(40):="FILE INTEGRITY";                               41015000
        end;                                                            41020000
        begin  <<46>>                                                   41025000
          move buf(40):="RIN";                                          41030000
        end;                                                            41035000
        begin <<47>>                                                    41040000
          move buf(40):="MAG. TAPE LABELS";                             41045000
        end;                                                            41050000
        begin <<50>>                                                    41055000
          move buf(40):="DEVICE CLASS TABLE";                           41060000
        end;                                                            41065000
        begin <<51>>                                                    41070000
          move buf(40):="HORIZON";                                      41075000
        end;                                                            41080000
        begin <<52>>                                                    41085000
          move buf(40):="COLD LOAD SIR";                                41090000
        end;                                                            41095000
cout:                                                                   41100000
      end;   <<cases>>                                                  41105000
      write'rec(prntfile,lbuf,-79,0);                                   41110000
      buf := " ";  move buf(1) := buf, (79);                            41115000
      move buf:="NO IMPEDED PROCESSES";                                 41120000
      if work2=0 then write'rec(prntfile,lbuf,-79,0)                    41125000
      else                                                              41130000
      begin                                                             41135000
        move buf:="   ";                                                41140000
        write'rec(prntfile,lbuf,-79,0);                                 41145000
        buf:=" ";   move buf(1) := buf, (79);                           41150000
        pcbcount := -1;                                                 41155000
        do                                                              41160000
          begin                                                         41165000
          pcbcount := pcbcount + 1;                                     41170000
          if pcbcount > pcb'entries then                                41175000
            begin                                                       41180000
            move buf(15):=                                              41185000
            "ERROR: NUMBER OF IMPEDED PINS EXCEEDS TABLE SIZE";         41190000
            write'rec(prntfile,lbuf,-79,0);                             41195000
            go to aend;                                                 41200000
            end;                                                        41205000
          buf := " ";  move buf(1) := buf, (79);                        41210000
          move buf(3):="PIN";                                           41215000
          @pbuf:=@buf+7;                                                41220000
          putnump(work4);                                               41225000
          << check status of link >>                                    41230000
          case sirpin(work4) of                                         41235000
            begin                      <<link states>>                  41240000
             begin  <<0>>                                               41245000
              sirpin(work4):=1;                                         41250000
             end;                                                       41255000
             begin  <<1>>              <<already impeded>>              41260000
              move buf(15):=                                            41265000
                "ERROR: LOOPING IMPEDED QUEUE POINTER";                 41270000
              write'rec(prntfile,lbuf,-79,0);                           41275000
              go aend;                                                  41280000
             end;                                                       41285000
             begin  <<2>>              <<inactive pin>>                 41290000
              move buf(15):=                                            41295000
                "ERROR: IMPEDED PIN IS INACTIVE, ",2;                   41300000
                move*:="NOT WAITING FOR SIR, OR ON DISP QUEUE";         41305000
              write'rec(prntfile,lbuf,-79,0);                           41310000
              go aend;                                                  41315000
             end;                                                       41320000
             begin  <<3>>              <<invalid pcb>>                  41325000
              move buf(15):=                                            41330000
                "ERROR: IMPEDED PIN IS INVALID";                        41335000
              write'rec(prntfile,lbuf,-79,0);                           41340000
              go aend;                                                  41345000
             end;                                                       41350000
             begin  <<4>>              <<already impeded>>              41355000
              move buf(15):=                                            41360000
                "WARNING: PIN IS IMPEDED BY ANOTHER SIR";               41365000
              sirpin(work4):=1;        <<call it impeded>>              41370000
             end;                                                       41375000
            end;     <<case ** state checking>>                         41380000
          write'rec(prntfile,lbuf,-79,0);                               41385000
          work4:=core(locpcb+double(logical(pcbsize)*work4              41390000
                 +nimppin));                                            41395000
          if mpeversion=4 then      <<get next pin>>           <<dougw>>41400000
             work4 := work4.(8:8)                              <<dougw>>41405000
          else                                                 <<dougw>>41410000
             work4 := work4 / logical(pcbsize);                <<dougw>>41415000
          end                                                           41420000
        until work4 = 0;                                                41425000
      end;                                                              41430000
aend:                                                                   41435000
      <<correct sirpin table for pins impeded>>                         41440000
      work1:=-1;                     <<scan whole table>>               41445000
      while (work1:=work1+1) < 1023 do                                  41450000
        if sirpin(work1)=1  then sirpin(work1):=4;                      41455000
      end; <<while (indx:=indx+sir'int'size)...>>                       41460000
                                                                        41465000
   if count =0 then                                            <<dougw>>41470000
     begin                                                     <<dougw>>41475000
       buf := " ";  move buf(1) := buf, (79);                  <<dougw>>41480000
       move buf :="NO LOCKED SIRS";                            <<dougw>>41485000
       write'rec(prntfile,lbuf,-79,0);                         <<dougw>>41490000
     end                                                       <<dougw>>41495000
   else                                                        <<dougw>>41500000
     if mpeversion = 4 then                                    <<dougw>>41505000
       chk'deadlocks4(hldrs'impd,impdrs)                       <<dougw>>41510000
     else                                                      <<dougw>>41515000
       chk'deadlocks5(hldrs'impd,impdrs);                      <<dougw>>41520000
                                                                        41525000
bailout:                                                                41530000
   end;  <<fmtsir>>                                                     41535000
$page"                        PROCEDURE PARSE'DIOQ"                     41540000
$control segment=format                                                 41545000
<<**********************************************************>>          41550000
<< parse'dioq                                               >>          41555000
<<---------------------------------------------------------->>          41560000
<< parse the format ioq and drq commands                    >>          41565000
<<**********************************************************>>          41570000
procedure parse'dioq(parmstring,optn,ldev);                             41575000
  byte array parmstring;                                                41580000
  integer optn, ldev;  << these will be returned >>                     41585000
    << optn  0 = all lists                                              41590000
               1 = active list                                          41595000
               2 = available list                                       41600000
    >>                                                                  41605000
                                                                        41610000
begin                                                                   41615000
  byte delim;                                                           41620000
  byte array delimiters(0:31), str2(0:79), tknbuf(0:79);                41625000
  logical good;                                                         41630000
  integer len;                                                          41635000
                                                                        41640000
                                                                        41645000
<< m a i n >>                                                           41650000
good := true;                                                           41655000
move delimiters := ("A,",cr);                                           41660000
len := get'token(parmstring,delimiters,tknbuf,delim);                   41665000
if delim = cr then                                                      41670000
  begin                                                                 41675000
  optn := 0;  << all lists >>                                           41680000
  if len <> 0 then                                                      41685000
    begin                                                               41690000
    ldev := binary(tknbuf,len);                                         41695000
    if <> then good := false;                                           41700000
    end                                                                 41705000
  else ldev := -1;  << all ldevs >>                                     41710000
  end                                                                   41715000
else                                                                    41720000
  begin                                                                 41725000
  if delim <> "A" then good := false                                    41730000
  else                                                                  41735000
    begin  << delim is "A" >>                                           41740000
    ldev := -1;  << all ldevs >>                                        41745000
    move delimiters := (",",cr);                                        41750000
    len := get'token(parmstring,delimiters,tknbuf,delim);               41755000
    if tknbuf = "C" then optn := 1  << active list >>                   41760000
    else if tknbuf = "V" then optn := 2  << available list >>           41765000
    else optn := 0;  << all lists >>                                    41770000
    if delim = "," then                                                 41775000
      begin                                                             41780000
      len := get'token(parmstring,delimiters,tknbuf,delim);             41785000
      if len <> 0 then                                                  41790000
        begin                                                           41795000
        ldev := binary(tknbuf,len);                                     41800000
        if <> then good := false;                                       41805000
        end                                                             41810000
      else ldev := -1;                                                  41815000
      end;                                                              41820000
    end;                                                                41825000
  end;                                                                  41830000
if not good then                                                        41835000
  begin                                                                 41840000
  optn := 0;                                                            41845000
  ldev := -1;                                                           41850000
  end;                                                                  41855000
end;                                                                    41860000
$page "                   PROCEDURE PRINTDRQMSG"                        41865000
$control segment=formatb                                                41870000
<<************************************************************>>        41875000
<< procedure printdrqmsg                                      >>        41880000
<<************************************************************>>        41885000
<< prints messages for printdrq                               >>        41890000
<<************************************************************>>        41895000
procedure printdrqmsg(msgnum);                                          41900000
value msgnum;                                                           41905000
integer msgnum;  << which message to print >>                           41910000
begin                                                                   41915000
                                                                        41920000
<<************************************************************>>        41925000
<< this procedure is used by both drq and ioq                 >>        41930000
<< formatting procedures, drq calls it direct, ioq uses the   >>        41935000
<< entry point printioqmsg.                                   >>        41940000
<< the messages unique to the ioq start at message number 20  >>        41945000
<< and the summary info messages are used by both drq and ioq.>>        41950000
<<************************************************************>>        41955000
                                                                        41960000
                                                                        41965000
                                                                        41970000
array lbuf(0:39);                                                       41975000
byte array buf(*)=lbuf;                                                 41980000
                                                                        41985000
entry printioqmsg;   << entry point for ioq messages >>                 41990000
                                                                        41995000
                                                                        42000000
printioqmsg:  << just to keep pcals meaningful >>                       42005000
                                                                        42010000
lbuf:="  ";                                                             42015000
move lbuf(1):=lbuf,(39);                                                42020000
                                                                        42025000
case msgnum of begin                                                    42030000
<< 0 >> move buf:="**** DISC REQUEST TABLE **** (ACTIVE LIST)";         42035000
<< 1 >> move buf:="**** DISC REQUEST TABLE **** (DISABLED LIST)";       42040000
<< 2 >> move buf:="**** DISC REQUEST TABLE **** (AVAILABLE LIST)";      42045000
<< 3 >> move buf:=" THERE ARE NO ACTIVE REQUESTS ";                     42050000
<< 4 >> move buf:=" NO DISABLED QUEUE ELEMENTS ";                       42055000
<< 5 >> move buf:="**** DISC REQUEST TABLE **** (SUMMARY INFO)";        42060000
<< 6 >> move buf:="TOTAL ENTRIES IN TABLE              ";               42065000
<< 7 >> move buf:="ENTRY SIZE                          ";               42070000
<< 8 >> move buf:="ENTRIES IN PRIMARY AREA             ";               42075000
<< 9 >> move buf:="IMPEDED PROCESS PCB                 ";               42080000
<<10 >> move buf:="TABLE INDEX OF FIRST AVAIL ENTRY    ";               42085000
<<11 >> move buf:="TABLE INDEX OF LAST AVAIL ENTRY     ";               42090000
<<12 >> move buf:="MAXIMUM NUMBER OF ENTRIES IN USE    ";               42095000
<<13 >> move buf:="CURRENT NUMBER OF ENTRIES IN USE    ";               42100000
<<14 >> move buf:="OVERFLOWS                           ";               42105000
<<15 >> move buf:="TOTAL REQUESTS                      ";               42110000
<<16 >> move buf:="SYSBASE INDEX OF DISABLED Q HEAD    ";               42115000
<<17 >> move buf:="SYSBASE INDEX OF DISABLED Q TAIL    ";               42120000
<<18 >> move buf:="SERIAL WRITE FLAG                   ";               42125000
<<19 >> move buf:="  SERIAL WRITE Q HEAD               ";               42130000
<<20 >> move buf:="  MAX. SERIAL WRITE Q               ";               42135000
<<21 >> move buf:="**** DISC REQUEST TABLE **** (SERIAL WRITE Q)";      42140000
<<22 >> move buf:=" THERE ARE NO SERIAL WRITE Q REQUESTS";              42145000
<<23 >> move buf:="**** DISC REQUEST TABLE **** (LOGICAL DRQ'S)";       42150000
<<24 >> move buf:=" THERE ARE NO LOGICAL DISC REQUEST ELEMENTS";        42155000
<<25 >> move buf:="**** DISC REQUEST TABLE **** (OTHERS)";              42160000
<<26 >> ;                                                               42165000
<<27 >> ;                                                               42170000
<<28 >> ;                                                               42175000
<<29 >> ;                                                               42180000
<<30 >> move buf:="**** I/O QUEUE  (SUMMARY INFO) ****";                42185000
<<31 >> move buf:="**** I/O QUEUE  (ACTIVE LIST) ****";                 42190000
<<32 >> move buf:="**** I/O QUEUE  (AVAIL LIST) ****";                  42195000
                                                                        42200000
       end;   << case >>                                                42205000
                                                                        42210000
if 6 <= msgnum <= 20 then write'rec(outfile,lbuf,-36,%320)              42215000
    else                                                                42220000
       write'rec(outfile,lbuf,-50,0);                                   42225000
                                                                        42230000
                                                                        42235000
end;   <<printdrqmsg>>                                                  42240000
$page "                   PROCEDURE PRINTDRQSUMMARY"                    42245000
<<************************************************************>>        42250000
<< procedure printdrqsummary/printioqsummary                  >>        42255000
<<************************************************************>>        42260000
<< prints drq/ioq summary info.                               >>        42265000
<<************************************************************>>        42270000
logical procedure printdrqsummary;                                      42275000
begin                                                                   42280000
                                                                        42285000
<< cond code returns                       >>                           42290000
<< ccg - getcore or getdstaddr threw up    >>                           42295000
<< cce - successful                        >>                           42300000
<< ccl - stop'print went true. ccl will stop caller. >>       <<860429>>42305000
<<************************************************************>>        42310000
<< input variables:     none                                  >>        42315000
<< output variable:   this procedure returns one word, of     >>        42320000
<<                    two bits are used by the caller.        >>        42325000
<<                    bit 15 - if set then there are disabled >>        42330000
<<                             drq elements in existence.     >>        42335000
<<                    bit 14 - if set then there are some drq >>        42340000
<<                             entries in use.                >>        42345000
<<************************************************************>>        42350000
<< this procedure assumes the existence of the following      >>        42355000
<< procedures - getcore,getdstaddr,printdrqmsg,printerror     >>        42360000
<< and the global variable  -  stop'print                     >>        42365000
<<************************************************************>>        42370000
<< it is called by - fmtdrq                                   >>        42375000
<<************************************************************>>        42380000
<< there is an entry point, printioqsummary, which is used to >>        42385000
<< print the ioq summary information.                         >>        42390000
<< it is called by fmtioq, although the returned word is not  >>        42395000
<< used by fmtioq.                                            >>        42400000
<<************************************************************>>        42405000
                                                                        42410000
                                                                        42415000
                                                                        42420000
byte array temp(0:11);                                                  42425000
array   qbuffer(0:16),    << holds drq entry 0 >>                       42430000
              lf(0:1),    << for linefeeds >>                           42435000
            pbuf(0:5);    << print buffer >>                            42440000
                                                                        42445000
double array qbufferd(*)=qbuffer;                                       42450000
byte array pbufb(*)=pbuf;                                               42455000
                                                                        42460000
double qbase;    << holds base of drq >>                                42465000
array tot'requ(0:1); << holds num of total requ in mpeve >>             42470000
double array tot'requd (*)=tot'requ;                                    42475000
                                                                        42480000
logical status=q-1,       << for cond code return >>                    42485000
           drq:=true,  << true if drq, false if ioq >>                  42490000
            s0=s-0;                                                     42495000
                                                                        42500000
equate drqdst = %70,  << drq dst number >>                              42505000
       ioqdst = %13;                                                    42510000
                                                                        42515000
integer len,              << for ascii return     >>                    42520000
        entrylen,   << 16 for drq,11 for ioq      >>                    42525000
        errorsgnum,                                                     42530000
        titlemsgnum,                                                    42535000
        qdst;       << %70 for drq, %13 for ioq   >>                    42540000
                                                                        42545000
entry printioqsummary;                                                  42550000
define                                                                  42555000
                 cc = status.(6:2)#,                                    42560000
       s'write'flag = qbuffer(14).(0:1)#,                               42565000
           linefeed = write'rec(outfile,lf,1,0)#,                       42570000
         move'print = if stop'print then go jumpout;                    42575000
                      move pbufb:=temp(6-len),(len);                    42580000
                      write'rec(outfile,pbuf,-len,0)#;                  42585000
                                                                        42590000
<< the move'print define is neccessary because when you convert >>      42595000
<< a number to octal using ascii you get leading zeros.         >>      42600000
                                                                        42605000
                                                                        42610000
                                                                        42615000
<< must find what sort of table we are dealing with.            >>      42620000
<< the normal entry will set up for a drq summary, if the       >>      42625000
<< entry printioqsummary is used it will set up for ioq summary >>      42630000
                                                                        42635000
<< set up for drq >>                                                    42640000
errorsgnum:=40;  << "UNABLE TO FORMAT DRQ etc" >>                       42645000
qdst:=drqdst;         << set table dst >>                               42650000
if mpeve then                                                           42655000
entrylen:=17                                                            42660000
else                                                                    42665000
entrylen:=16;         << set drq entry length >>                        42670000
titlemsgnum:=5;       << "DRQ SUMMARY INFO" >>                          42675000
                                                                        42680000
if false then begin   << dont want to go inside if drq >>               42685000
   << set up for ioq >>                                                 42690000
 printioqsummary:       << for ioqs >>                                  42695000
   errorsgnum:=43; << "UNABLE TO FORMAT IOQ...." >>                     42700000
   qdst:=ioqdst;        << set ioq dst >>                               42705000
   if mpeve then                                                        42710000
   entrylen:=12                                                         42715000
   else                                                                 42720000
   entrylen:=11;        << set ioq entry length >>                      42725000
   titlemsgnum:=30;     << "IOQ SUMMARY INFO..." >>                     42730000
   drq:=false;          << to tell later code what we're doing >>       42735000
   end;                                                                 42740000
                                                                        42745000
                                                                        42750000
lf:=%20040;    << for linefeeds >>                                      42755000
                                                                        42760000
printdrqmsg(titlemsgnum);   << title >>                                 42765000
linefeed;                                                               42770000
qbase:=getdstaddr(qdst);   << find base of table  >>                    42775000
if <> then go err'drq;                                                  42780000
getcore(qbase,16,qbuffer); << get entry 0 of drq >>                     42785000
if <> then go err'drq;                                                  42790000
if mpeve then begin                                                     42795000
printdrqmsg(6);         << total entries >>                             42800000
len:=ascii(qbuffer,8,temp);                                             42805000
move'print;                                                             42810000
printdrqmsg(7);         << entry size >>                                42815000
len:=ascii(qbuffer(1),8,temp);                                          42820000
move'print;                                                             42825000
printdrqmsg(8);         << entries in primary area >>                   42830000
len:=ascii(qbuffer(2),8,temp);                                          42835000
move'print;                                                             42840000
printdrqmsg(9);         << impeded process pcb >>                       42845000
len:=ascii(qbuffer(3),8,temp);                                          42850000
move'print;                                                             42855000
printdrqmsg(10);        << table index first avail entry >>             42860000
len:=ascii(qbuffer(4),8,temp);                                          42865000
move'print;                                                             42870000
printdrqmsg(11);        << table index last  avail entry >>             42875000
len:=ascii(qbuffer(5),8,temp);                                          42880000
move'print;                                                             42885000
printdrqmsg(12);        << max num entries in use >>                    42890000
len:=ascii(qbuffer(6),8,temp);                                          42895000
move'print;                                                             42900000
printdrqmsg(13);        << current in use >>                            42905000
len:=ascii(qbuffer(7),8,temp);                                          42910000
move'print;                                                             42915000
printdrqmsg(14);        << overflows >>                                 42920000
len:=ascii(qbuffer(8),8,temp);                                          42925000
move'print;                                                             42930000
printdrqmsg(15);        << total requests >>                            42935000
move tot'requ := qbuffer(9),(2);                                        42940000
len:=dascii(tot'requd,8,temp);                                          42945000
move pbufb:=temp(11-len),(len);                                         42950000
write'rec(outfile,pbuf,-len,0);                                         42955000
end           << end for mpeve (ioq part) >>                            42960000
else                                                                    42965000
begin                                                                   42970000
                                                                        42975000
printdrqmsg(6);        << total entries >>                              42980000
len:=ascii(qbuffer.(0:8),8,temp);                                       42985000
move'print;                                                             42990000
printdrqmsg(7);        << entry size >>                                 42995000
len:=ascii(qbuffer(1).(8:8),8,temp);                                    43000000
move'print;                                                             43005000
printdrqmsg(8);        << entries in pri area >>                        43010000
len:=ascii(qbuffer.(8:8),8,temp);                                       43015000
move'print;                                                             43020000
printdrqmsg(9);        << impeded process pcb >>                        43025000
len:=ascii(qbuffer(1).(0:8),8,temp);                                    43030000
move'print;                                                             43035000
printdrqmsg(10);       << table index first avail entry >>              43040000
len:=ascii(qbuffer(2),8,temp);                                          43045000
move'print;                                                             43050000
printdrqmsg(11);       << table index last avail entry  >>              43055000
len:=ascii(qbuffer(3),8,temp);                                          43060000
move'print;                                                             43065000
printdrqmsg(12);       << max num entries in use >>                     43070000
len:=ascii(qbuffer(4).(0:8),8,temp);                                    43075000
move'print;                                                             43080000
printdrqmsg(13);       << current in use >>                             43085000
len:=ascii(qbuffer(4).(8:8),8,temp);                                    43090000
move'print;                                                             43095000
printdrqmsg(14);       << overflows >>                                  43100000
len:=ascii(qbuffer(5),8,temp);                                          43105000
move'print;                                                             43110000
printdrqmsg(15);       << total requests >>                             43115000
len:=dascii(qbufferd(3),8,temp);                                        43120000
move pbufb:=temp(11-len),(len);                                         43125000
write'rec(outfile,pbuf,-len,0);                                         43130000
end;                                                                    43135000
if drq then begin                                                       43140000
   printdrqmsg(16);       << sysbase index head of disab q >>           43145000
 if mpeve then begin                                                    43150000
   if qbuffer(11) > 0 then begin                                        43155000
   len:=ascii(qbuffer(11),8,temp);                                      43160000
   move'print;                                                          43165000
   printdrqmsg(17);   << sysbase index tail of disab q >>               43170000
   len := ascii(qbuffer(12),8,temp);                                    43175000
   move'print;                                                          43180000
 end else begin                                                         43185000
   linefeed;                                                            43190000
   printdrqmsg(17);                                                     43195000
   linefeed;                                                            43200000
   end;                                                                 43205000
 end else begin                                                         43210000
   if qbuffer(8) > 0 then begin    << dont want to put 0 if no head>>   43215000
       len:=ascii(qbuffer(8),8,temp);                                   43220000
       move'print;                                                      43225000
       printdrqmsg(17);   << sysbase index tail of disab q >>           43230000
       len:=ascii(qbuffer(9),8,temp);                                   43235000
       move'print;                                                      43240000
       end                                                              43245000
     else                                                               43250000
       begin    << just print blanks if pointers are zero >>            43255000
       linefeed;                                                        43260000
       printdrqmsg(17);                                                 43265000
       linefeed;                                                        43270000
       end;                                                             43275000
    end;                                                                43280000
                                                                        43285000
   if mpevp or mpeve then begin                                         43290000
       printdrqmsg(18);  << serial write flag >>                        43295000
       if s'write'flag then move pbufb:="TRUE " else                    43300000
            move pbufb:="FALSE";                                        43305000
       write'rec(outfile,pbuf,-5,0);                                    43310000
       printdrqmsg(19);  << serial write queue head >>                  43315000
       if qbuffer(13) > 0 then begin << dont print 0 >>                 43320000
           len:=ascii(qbuffer(13),8,temp);                              43325000
           move'print;                                                  43330000
           printdrqmsg(20);   << max serial write q >>                  43335000
           len:=ascii(qbuffer(14).(8:8),8,temp);                        43340000
           move'print;                                                  43345000
           end                                                          43350000
         else                                                           43355000
           begin                                                        43360000
           linefeed;                                                    43365000
           printdrqmsg(20);                                             43370000
           linefeed;                                                    43375000
           end;                                                         43380000
   end;                                                                 43385000
                                                                        43390000
   << sort out the procedure return >>                                  43395000
                                                                        43400000
if mpeve then begin                                                     43405000
   if qbuffer(11)>0 then tos:=1 else tos:=0;<<got disab q ? >>          43410000
   if qbuffer(7)>0 then s0.(14:1):=1;  << set for inuse >>              43415000
   if s'write'flag then s0.(13:1):=1;  << s. w. q. >>                   43420000
  end else begin                                                        43425000
   if qbuffer(8)>0 then tos:=1 else tos:=0; << got disab q ? >>         43430000
   if qbuffer(4).(8:8) > 0 then s0.(14:1):=1; << set for inuse >>       43435000
   if mpevp then if s'write'flag then s0.(13:1):=1; << s. w. q. >>      43440000
  end;                                                                  43445000
                                                                        43450000
   printdrqsummary:=tos;                                                43455000
   end                                                                  43460000
 else                                                                   43465000
   printdrqsummary:=0;                                                  43470000
                                                                        43475000
cc := cce;     << nice return. >>                             <<860429>>43480000
return;                                                       <<860429>>43485000
                                                                        43490000
                                                                        43495000
jumpout:   << escape route for stop'print >>                            43500000
cc:=ccl;                                                      <<860429>>43505000
return;                                                                 43510000
                                                                        43515000
err'drq:                                                                43520000
cc:=ccg;    << getcore error >>                                         43525000
printerror(errorsgnum);  << unable to format drq/ioq >>                 43530000
                                                                        43535000
                                                                        43540000
end; <<printdrqsummary>>                                                43545000
$page "                   PROCEDURE PRINTDRQ"                           43550000
<<************************************************************>>        43555000
<< procedure printdrq                                         >>        43560000
<<************************************************************>>        43565000
<< handles bulk of the formatting of the drq/ioq              >>        43570000
<<************************************************************>>        43575000
procedure printdrq(type,headp,tailp,ldev);                              43580000
value type,headp,tailp,ldev;                                            43585000
logical type,           << type of drq entry >>                         43590000
        headp,          << head pointer of chain >>                     43595000
        tailp;          << tail pointer of chain >>                     43600000
integer ldev;           << which ldev(s) to print >>                    43605000
                                                                        43610000
<<************************************************************>>        43615000
<< this procedure contains entry point: printioq.             >>        43620000
<< common code is used for printing drq/ioq.                  >>        43625000
<<************************************************************>>        43630000
<< input variables.                                           >>        43635000
<< type    0 = active element,  headp=sysdb rel pntr, tailp=0 >>        43640000
<<         1 = disab request q. headp & tailp sysdb rel pntrs >>        43645000
<<         2 = avail request q. headp & tailp drqdst rel pntrs>>        43650000
<<         3 = queued request q.headp & tailp sysdb rel pntrs >>        43655000
<<(for ioq)4 = in-use ioq.      headp=sysdb rel pntr, tailp=0 >>        43660000
<<(for ioq)5 = avail  ioq.      headp & tailp ioqdst rel pntrs>>        43665000
<<         6 = serial write q.  headp drqdst rel. tailp = 0   >>        43670000
<< ldev   -1 = print all ldevs                                >>        43675000
<<       >=0 = particular ldev                                >>        43680000
<< output variables:    none                                  >>        43685000
<< condition code returns                                     >>        43690000
<<        cce   -   ok                                        >>        43695000
<<        ccl   -   'memory reference' failed, getcore etc    >>        43700000
<<        ccg   -   format of drq/ioq questionable            >>        43705000
<<************************************************************>>        43710000
<< assumes the existence of the following procedures          >>        43715000
<<        printerror     core      dcore     getcore          >>        43720000
<<        getdstaddr                                          >>        43725000
<< and the following global variables                         >>        43730000
<<        stop'print     outfile                              >>        43735000
<<************************************************************>>        43740000
                                                                        43745000
                                                                        43750000
                                                                        43755000
begin                                                                   43760000
                                                                        43765000
                                                                        43770000
                                                                        43775000
array   ioqcol'l1(0:39),  << has column headings >>                     43780000
        ioqcol'l2(0:39),  << for the ioq.        >>                     43785000
        drqcol'l1(0:39),  << has column headings >>                     43790000
        drqcol'l2(0:39),  << for the drq.        >>                     43795000
        ldrcol1(0:39),    << has column headinds >>                     43800000
        ldrcol2(0:39),    << for the logical drq >>                     43805000
                                                                        43810000
                                                                        43815000
             lbuf(0:39),  << has drq element ready to print >>          43820000
               lf(0:1),   << just for linefeeds >>                      43825000
        indexlist(0:1300), << saves index pointers in avail list >>     43830000
        drqbuffer(0:23); << holds current drq element       >>          43835000
                                                                        43840000
array ioqbuffer(*)=drqbuffer;  << holds current ioq element >>          43845000
                                                                        43850000
integer array ioqbuffer'i(*)=ioqbuffer;  << need integer later >>       43855000
                                                                        43860000
                                                                        43865000
byte array temp'b(0:11),  << buffer for ascii return >>                 43870000
      bioqcol'l1(*)=ioqcol'l1,                                          43875000
      bioqcol'l2(*)=ioqcol'l2,                                          43880000
      bdrqcol'l1(*)=drqcol'l1,                                          43885000
      bdrqcol'l2(*)=drqcol'l2,                                          43890000
      bldrcol1(*)=  ldrcol1,                                            43895000
      bldrcol2(*)=  ldrcol2,                                            43900000
             buf(*)=lbuf;                                               43905000
                                                                        43910000
                                                                        43915000
integer len;    << ascii char count return >>                           43920000
entry printioq; << same procedure for ioqs >>                           43925000
                                                                        43930000
                                                                        43935000
logical loopstop,  << for bad drq >>                                    43940000
             drq:=true,  << true: drq, fase: ioq >>                     43945000
           index,  << drq table relative element index >>               43950000
         drqbank,  << bank of drq table >>                              43955000
         drqaddr,  << address of drq table >>                           43960000
         ioqbank,  << bank of ioq >>                                    43965000
         ioqaddr,  << address of ioq dst >>                             43970000
           count,  << number of entries in avail list >>                43975000
          maxnum,  << like count >>                                     43980000
          status = q-1;  << for status return >>                        43985000
                                                                        43990000
double drqbase = drqbank,  << bank and base of drq table >>             43995000
       ioqbase = ioqbank;  << bank and base of ioq dst >>               44000000
                                                                        44005000
define     stack  =  (0:1)#, << drq word 4, seg or proc i/o >>          44010000
            sbuf  =  (3:1)#, << qflag bit in ioq for sbuf i/o >>        44015000
           mmreq  =  (1:1)#, << drq qflag, set if mm request >>         44020000
   mapped'domain  =  drqbuffer(segident).(2:1)#, << set if yes >>       44025000
   mapped'domve   =  drqbuffer(segidve).(2:1)#,                         44030000
         drqword  =  len:=ascii(drqbuffer#,                             44035000
        linefeed  =  lf:=%20040;                                        44040000
                     write'rec(outfile,lf,1,0)#,                        44045000
     colhead'ldr  =                                                     44050000
                     write'rec(outfile,ldrcol1,-79,0);                  44055000
                     write'rec(outfile,ldrcol2,-79,0)#,                 44060000
                                                                        44065000
     colheadings  =  if drq then begin                                  44070000
                        write'rec(outfile,drqcol'l1,-79,0);             44075000
                        write'rec(outfile,drqcol'l2,-79,0);             44080000
                        end                                             44085000
                       else                                             44090000
                        begin                                           44095000
                        write'rec(outfile,ioqcol'l1,-79,0);             44100000
                        write'rec(outfile,ioqcol'l2,-79,0);             44105000
                        end#,                                           44110000
              cc  =  status.(6:2)#;                                     44115000
                                                                        44120000
                                                                        44125000
equate    drqdst  =  %70, << dstnumber of drq >>                        44130000
          ioqdst  =  %13, << dst number of ioq >>                       44135000
         ioqlink  =  1,   << ioqs linked by word 1 >>                   44140000
      avail'link  =  1,   << drq wd1 is link on avail element >>        44145000
        nextreqp  =  12,  << drq word 12, linked list >>                44150000
           flags  =  0,   << drq word 0 >>                              44155000
           ldevn  =  2,   << drq word 2 >>                              44160000
            dstn  =  4,   << drq word 4 >>                              44165000
            addr  =  5,   << drq word 5 >>                              44170000
            func  =  6,   << drq word 6 >>                              44175000
         xfercnt  =  7,   << drq word 7 >>                              44180000
            par1  =  8,   << drq word 8 >>                              44185000
            par2  =  9,   << drq word 9 >>                              44190000
            stat  =  10,  << drq word 10 >>                             44195000
            pcbn  =  11,  << drq word 11 >>                             44200000
        segident  =  13,  << drq word 13 >>                             44205000
         segidve  =  14,                                                44210000
         segdisp  =  14,  << drq word 14 >>                             44215000
        auxflags  =  15,  << drq word 15 >>                             44220000
      segdisp've  =  16;  << drq word 16, mpeve only >>                 44225000
                                                                        44230000
                                                                        44235000
                                                                        44240000
                                                                        44245000
                                                                        44250000
subroutine fill'print;                                                  44255000
begin                                                                   44260000
                                                                        44265000
<< most code can be used for ioq and drq since locations are same >>    44270000
<< this subroutine fills in the holes in the output buffer.       >>    44275000
<< it assumes the element to format is currently in drqbuffer.    >>    44280000
                                                                        44285000
if stop'print then go jump'out;                                         44290000
                                                                        44295000
if ldev = -1 or mpeve and drqbuffer(ldevn) = logical(ldev)              44300000
        or not mpeve and drqbuffer(ldevn).(8:8) = logical(ldev) then    44305000
  begin                                                                 44310000
  move lbuf:="  ";                                                      44315000
  move lbuf(1):=lbuf,(39);                                              44320000
                                                                        44325000
  len:=ascii(index,8,temp'b); << drq rel element index >>               44330000
  move buf:=temp'b(6-len),(len);                                        44335000
  if mpeve then                                                         44340000
  drqword(ldevn),10,temp'b)   << mpeve only >>                          44345000
  else                                                                  44350000
  drqword(ldevn).(8:8),10,temp'b); << ldev number >>                    44355000
  move buf(10-len):=temp'b,(len);                                       44360000
  drqword(func).(8:8),8,temp'b);   << function >>                       44365000
  move buf(16-len):=temp'b(6-len),(len);                                44370000
  drqword(par1),8,temp'b);         << p1 >>                             44375000
  if drq then  << format different from drq to ioq >>                   44380000
     move buf(23-len):=temp'b(6-len),(len)                              44385000
    else      << want leading 0's on ioq, not on drq >>                 44390000
     move buf(20):=temp'b,(6);                                          44395000
  drqword(par2),8,temp'b);         << p2 >>                             44400000
  move buf(29):=temp'b,(6);                                             44405000
  if drq then begin << want different format ioq, words/bytes >>        44410000
     drqword(xfercnt),8,temp'b);      << word count >>                  44415000
     move buf(43-len):=temp'b(6-len),(len);                             44420000
     end                                                                44425000
   else                                                                 44430000
     begin                                                              44435000
     if ioqbuffer'i(xfercnt) < 0 then begin  << byte count ? >>         44440000
        ioqbuffer'i(xfercnt):=0-ioqbuffer'i(xfercnt);<< convert >>      44445000
        drqword(xfercnt),8,temp'b);   << byte count  >>                 44450000
        buf(42):="B";                                                   44455000
        move buf(42-len):=temp'b(6-len),(len);                          44460000
        end                                                             44465000
       else                                                             44470000
        begin  << must be a word count >>                               44475000
        drqword(xfercnt),8,temp'b);   << word count >>                  44480000
        buf(42):="W";                                                   44485000
        move buf(42-len):=temp'b(6-len),(len);                          44490000
        end;                                                            44495000
     end;                                                               44500000
  if mpeve then                                                         44505000
  drqword(pcbn).(2:14),8,temp'b)   << pcb number,mpeve only >>          44510000
  else                                                                  44515000
  drqword(stat).(0:8),8,temp'b);   << pcb number >>                     44520000
  move buf(49-len):=temp'b(6-len),(len);                                44525000
  if not drq then begin    << addr rel for ioq >>                       44530000
     if ioqbuffer.sbuf then move buf(52):="SBUF"  << i/o to sbuf >>     44535000
       else if ioqbuffer(dstn).stack then  << db rel buffer >>          44540000
          move buf(53):="+DB" else                                      44545000
             move buf(53):="SEG"; << must be dst rel buffer >>          44550000
     end                                                                44555000
   else                                                                 44560000
     << sort out if mm i/o or user proc i/o on disc requests >>         44565000
     if drqbuffer(flags).mmreq then << if cache i/o >>                  44570000
          if mpeve then                                                 44575000
          if mapped'domve then move buf(52):="CACH"                     44580000
          else move buf(52):="MMIO"                                     44585000
          else                                                          44590000
          if mapped'domain then move buf(52):="CACH"                    44595000
             else move buf(52):="MMIO"                                  44600000
         else move buf(52):="PROC";                                     44605000
  drqword(dstn).(4:12),8,temp'b);   << dst/bank >>                      44610000
  move buf(63-len):=temp'b(6-len),(len);                                44615000
  drqword(addr),8,temp'b);          << address >>                       44620000
  move buf(71-len):=temp'b(6-len),(len);                                44625000
  drqword(stat).(9:7),8,temp'b);  << completion status >>               44630000
  move buf(77-len):=temp'b(6-len),(len);                                44635000
                                                                        44640000
  if type = 0 then move buf(5):="*";  << current request marker >>      44645000
                                                                        44650000
  write'rec(outfile,lbuf,-79,0);                                        44655000
  end;                                                                  44660000
                                                                        44665000
end;   << subroutine fill'print >>                                      44670000
                                                                        44675000
                                                                        44680000
subroutine fill'print'ldr;                                              44685000
       << works like fill'print >>                                      44690000
       << but only for logical disc requests >>                         44695000
begin                                                                   44700000
                                                                        44705000
if stop'print then go jump'out;                                         44710000
                                                                        44715000
                                                                        44720000
                                                                        44725000
                                                                        44730000
                                                                        44735000
                                                                        44740000
end;  << subroutine fill'print'ldr  >>                                  44745000
                                                                        44750000
                                                                        44755000
if false then begin  << ioq only >>                                     44760000
    printioq:   << entry point for printing ioqs >>                     44765000
    drq:=false;                                                         44770000
    end;                                                                44775000
                                                                        44780000
                                                                        44785000
<< flush out col heading buffers >>                                     44790000
ioqcol'l1:=ioqcol'l2:=drqcol'l1:=drqcol'l2:=%20040;                     44795000
move ioqcol'l1(1):=ioqcol'l1,(39);                                      44800000
move ioqcol'l2(1):=ioqcol'l2,(39);                                      44805000
move drqcol'l1(1):=drqcol'l1,(39);                                      44810000
move drqcol'l2(1):=drqcol'l2,(39);                                      44815000
                                                                        44820000
                                                                        44825000
move bioqcol'l1(52):="ADDR   DST/";                                     44830000
move bioqcol'l2:=                                                       44835000
"INDEX  LDEV  FUNC    PAR1     PAR2     XLOG   PCB    REL   BANK";      44840000
move bioqcol'l2(66):="ADDR   STATUS";                                   44845000
move bdrqcol'l1(52):="I/O    DST/";                                     44850000
move bdrqcol'l2:=                                                       44855000
"INDEX  LDEV  FUNC    PAR1     PAR2     XLOG   PCB   TYPE   BANK";      44860000
move bdrqcol'l2(66):="ADDR   STATUS";                                   44865000
                                                                        44870000
drqbase:=getdstaddr(drqdst);  << get table base >>                      44875000
if <> then go drq'err;                                                  44880000
                                                                        44885000
ioqbase:=getdstaddr(ioqdst);  << get table base for later >>            44890000
if <> then go ioq'err;                                                  44895000
                                                                        44900000
                                                                        44905000
case type of begin                                                      44910000
    begin      << type 0, current request, headp sysdb rel >>           44915000
    index:=headp;  << sysdb rel index >>                                44920000
    if mpeve then begin                                                 44925000
    getcore(drqbase+double(headp),17,drqbuffer);                        44930000
    if <> then go drq'err;                                              44935000
    end else begin                                                      44940000
    getcore(%1000d+double(headp),16,drqbuffer); << get element>>        44945000
    if <> then go drq'err;                                              44950000
    end;                                                                44955000
    colheadings;  << column headings >>                                 44960000
    fill'print;   << fill in and print >>                               44965000
    end;                                                                44970000
                                                                        44975000
    begin     << type 1, disabled list, sysdb rel head & tail >>        44980000
shortcut:    << come here for type 3 as well. link chasing same>>       44985000
    index:=headp;  << sysdb rel index >>                                44990000
    if mpeve then begin                                                 44995000
    getcore(drqbase+double(headp),17,drqbuffer);                        45000000
    if <> then go drq'err;                                              45005000
    end else begin                                                      45010000
    getcore(%1000d+double(headp),16,drqbuffer); << get 1st req >>       45015000
    if <> then go drq'err;                                              45020000
    end;                                                                45025000
    colheadings;     << column headings >>                              45030000
    fill'print;      << print 1st request >>                            45035000
    loopstop:=%400;  << in case bad >>                                  45040000
    while drqbuffer(nextreqp) <> 0 do begin  << traverse >>             45045000
        if ctrly then begin                                   <<850823>>45050000
          write'rec(outfile,lbuf,0,0); <<start a new line>>   <<850823>>45055000
          move buf:=" <CONTROL-Y>";                           <<850823>>45060000
          write'rec(outfile,lbuf,-12,%60);                    <<850823>>45065000
          return; end;                                        <<850823>>45070000
        index:=drqbuffer(nextreqp);  << sysdb rel index >>              45075000
      if mpeve then begin                                               45080000
        getcore(drqbase+double(index),17,drqbuffer);                    45085000
        if <> then go drq'err;                                          45090000
      end else begin                                                    45095000
        getcore(%1000d+double(index),16,drqbuffer);                     45100000
        if <> then go drq'err;                                          45105000
      end;                                                              45110000
        fill'print;                                                     45115000
        loopstop:=loopstop-1;                                           45120000
        if = then go drq'fishy; << can't have %400 entries >>           45125000
        end;                                                            45130000
    end;                                                                45135000
                                                                        45140000
    begin    << type 2, avail list, head/tailp drq dst rel >>           45145000
             << link via word 1 of drq element, (urgclass) >>           45150000
             << because most recent avail entry at tail of table >>     45155000
             << means the table has to be printed backwards >>          45160000
                                                                        45165000
if mpeve then begin                                                     45170000
    loopstop:= 900;                                                     45175000
    count:= 900;                                                        45180000
  end else begin                                                        45185000
    loopstop:=256;  << just in case >>                                  45190000
    count := 255;   << max drq entries + 1 >>                           45195000
  end;                                                                  45200000
    index:=headp;   << save first pointer to head of avail list >>      45205000
    maxnum := count;<< save count for printing >>                       45210000
    do begin  << go down list and saving pointers >>                    45215000
       indexlist(count:=count-1):=index;                                45220000
       index:=core(drqbase+double(index+1)); << get next one >>         45225000
       if <> then go drq'err;                                           45230000
       loopstop:=loopstop-1;                                            45235000
       if = then go drq'fishy;  << found it >>                          45240000
       end                                                              45245000
     until index = 0;   << end of avail list >>                         45250000
                                                                        45255000
<< now we have the pointers, can go back down the list         >>       45260000
<< of saved index pointers and print the list in chronological >>       45265000
<< order.                                                      >>       45270000
                                                                        45275000
    colheadings;                                                        45280000
                                                                        45285000
    while count < maxnum do begin   << print the list >>                45290000
        if ctrly then begin                                   <<850823>>45295000
          write'rec(outfile,lbuf,0,0); <<start a new line>>   <<850823>>45300000
          move buf:=" <CONTROL-Y>";                           <<850823>>45305000
          write'rec(outfile,lbuf,-12,%60);                    <<850823>>45310000
          return; end;                                        <<850823>>45315000
        getcore(drqbase+double(index:=indexlist(count)),17,drqbuffer);  45320000
        if <> then go drq'err;                                          45325000
        fill'print;                                                     45330000
        count:=count+1;                                                 45335000
        end;                                                            45340000
                                                                        45345000
    end;                                                                45350000
                                                                        45355000
    begin   << type 3, queued reqs, head/tailp sysdb rel >>             45360000
    go shortcut; << link chasing same as type 1        >>               45365000
    end;         << use the same code.                 >>               45370000
                                                                        45375000
    begin  << type 4, ioq in-use entries, headp sysdb rel tail=0 >>     45380000
    if tailp = -1 then                                                  45385000
        begin                                                           45390000
        colheadings;                                                    45395000
        go jump'out;                                                    45400000
        end;                                                            45405000
    index:=headp;                                                       45410000
    if mpeve then begin                                                 45415000
    getcore (ioqbase+double(headp),12,ioqbuffer);                       45420000
    if <> then go ioq'err;                                              45425000
    end else begin                                                      45430000
    getcore(%1000d+double(headp),12,ioqbuffer); << get 1st in queue >>  45435000
    if <> then go ioq'err;                                              45440000
    end;                                                                45445000
    fill'print;                                                         45450000
  if mpeve then loopstop:= 1300 else                                    45455000
    loopstop:=256;  << just in case >>                                  45460000
    while ioqbuffer(ioqlink) <> 0 do begin  << traverse >>              45465000
       if ctrly then begin                                    <<850823>>45470000
         write'rec(outfile,lbuf,0,0); <<start a new line>>    <<850823>>45475000
         move buf:=" <CONTROL-Y>";                            <<850823>>45480000
         write'rec(outfile,lbuf,-12,%60);                     <<850823>>45485000
         return; end;                                         <<850823>>45490000
       getcore(%1000d+double(index:=ioqbuffer(ioqlink)),12,ioqbuffer);  45495000
       if <> then go ioq'err;                                           45500000
       fill'print;                                                      45505000
       loopstop:=loopstop-1;                                            45510000
       if = then go ioq'fishy;                                          45515000
       end;                                                             45520000
    end;                                                                45525000
                                                                        45530000
    begin  << type 5, ioq avail list. same as with drq avail    >>      45535000
           << list, must reverse the list first.                >>      45540000
           << link is via word1 of ioq element and ioq dst rel. >>      45545000
                                                                        45550000
  if mpeve then begin                                                   45555000
    loopstop:=1300;                                                     45560000
    count := 1300;                                                      45565000
  end else begin                                                        45570000
    loopstop:=256;  << just in case                                     45575000
    count:=255;     << max drq entries + 1 >>                           45580000
  end;                                                                  45585000
    index := headp; << save first pointer to head of avail list >>      45590000
    maxnum := count;                                                    45595000
    do begin  << go down list >>                                        45600000
       indexlist(count:=count-1):=index; << keep pointer >>             45605000
       index:=core(ioqbase+double(index+1)); << get next one >>         45610000
       if <> then go ioq'err;                                           45615000
       loopstop:=loopstop-1;                                            45620000
       if = then go ioq'fishy;  << found >>                             45625000
       end                                                              45630000
     until index = 0;   << end of avail list >>                         45635000
                                                                        45640000
<< now have the pointers and can go down the list              >>       45645000
<< of saved index pointers and print the list in chronological >>       45650000
<< order.                                                      >>       45655000
                                                                        45660000
    colheadings;                                                        45665000
                                                                        45670000
    while count < maxnum do begin   << print the list >>                45675000
        if ctrly then begin                                   <<850823>>45680000
          write'rec(outfile,lbuf,0,0); <<start a new line>>   <<850823>>45685000
          move buf:=" <CONTROL-Y>";                           <<850823>>45690000
          write'rec(outfile,lbuf,-12,%60);                    <<850823>>45695000
          return; end;                                        <<850823>>45700000
        getcore(ioqbase+double(index:=indexlist(count)),16,ioqbuffer);  45705000
        if <> then go ioq'err;                                          45710000
        fill'print;                                                     45715000
        count:=count+1;                                                 45720000
        end;                                                            45725000
                                                                        45730000
    end;                                                                45735000
                                                                        45740000
                                                                        45745000
    begin  << type 6, serial write q requests. headp is drq dst >>      45750000
           << relative as are all the links in word the next    >>      45755000
           << request pointer.                                  >>      45760000
    index:=headp;  << for fill'print >>                                 45765000
    getcore((drqbase+double(headp)),17,drqbuffer); << get 1st req>>     45770000
    if <> then go drq'err;                                              45775000
    colheadings;                                                        45780000
    fill'print;                                                         45785000
  if mpeve then loopstop :=900 else                                     45790000
    loopstop:=256;  << just in case >>                                  45795000
    while (index:=drqbuffer(nextreqp)) <> 0 do begin                    45800000
       if ctrly then begin                                    <<850823>>45805000
         write'rec(outfile,lbuf,0,0); <<start a new line>>    <<850823>>45810000
         move buf:=" <CONTROL-Y>";                            <<850823>>45815000
         write'rec(outfile,lbuf,-12,%60);                     <<850823>>45820000
         return; end;                                         <<850823>>45825000
       getcore((drqbase+double(index)),17,drqbuffer);                   45830000
       if <> then go drq'err;                                           45835000
       fill'print;                                                      45840000
       loopstop:=loopstop-1;                                            45845000
       if = then go drq'fishy;                                          45850000
       end;                                                             45855000
    end;    << type 6, serial write q >>                                45860000
                                                                        45865000
  begin    << type 7, logical disc requests >>                          45870000
           << headp is word %16 of cached domain >>                     45875000
           << table relative to drqdst >>                               45880000
  index := headp;  <<save head >>                                       45885000
  if mpeve then begin                                                   45890000
  loopstop := 900;  << maximum >>                                       45895000
  count:= 900;                                                          45900000
  end else begin                                                        45905000
  loopstop:=256;                                                        45910000
  count:=255;                                                           45915000
  end;                                                                  45920000
  maxnum:=count;  << need it later >>                                   45925000
  do begin << traverse list saving pointers >>                          45930000
     indexlist(count:=count-1):=index;                                  45935000
     index :=core(drqbase+double(index+12)); << linked by 12 >>         45940000
     if <> then go drq'err;                                             45945000
     loopstop:= loopstop-1;                                             45950000
     if = then go drq'fishy;                                            45955000
     end                                                                45960000
  until index = 0;  << end for ldr's of this domain  >>                 45965000
                                                                        45970000
  << found all pointers, print out the list >>                          45975000
                                                                        45980000
  colhead'ldr;  << column headings >>                                   45985000
                                                                        45990000
  while count < maxnum do begin                                         45995000
    if ctrly then begin                                       <<850823>>46000000
      write'rec(outfile,lbuf,0,0); <<start a new line>>       <<850823>>46005000
      move buf:=" <CONTROL-Y>";                               <<850823>>46010000
      write'rec(outfile,lbuf,-12,%60);                        <<850823>>46015000
      return; end;                                            <<850823>>46020000
    getcore (drqbase+double(index:=indexlist(count)),24,drqbuffer);     46025000
    if <> then go drq'err;                                              46030000
    fill'print'ldr;   << print it >>                                    46035000
    count := count + 1;                                                 46040000
    end;                                                                46045000
                                                                        46050000
                                                                        46055000
end;  << type 7    logical drq's >>                                     46060000
                                                                        46065000
  end;                                                                  46070000
                                                                        46075000
                                                                        46080000
jump'out:     << stop'print escape route >>                             46085000
cc:=cce;                                                                46090000
return;                                                                 46095000
                                                                        46100000
ioq'err:  << 'memory ref' pcal failed, getcore etc >>                   46105000
cc:=ccl;   << set bad cond code return >>                               46110000
printerror(68);  << "UNABLE TO FORMAT IOQ" >>                           46115000
return;  << bail out >>                                                 46120000
                                                                        46125000
ioq'fishy: << problem >>                                                46130000
cc:=ccg;                                                                46135000
printerror(69);                                                         46140000
return;                                                                 46145000
                                                                        46150000
drq'err:    << 'memory reference' call failed (getcore etc) >>          46155000
cc:=ccl;                                                                46160000
printerror(65);  << "UNABLE TO FORMAT DRQ" >>                           46165000
return;                                                                 46170000
                                                                        46175000
drq'fishy:                                                              46180000
cc:=ccg;                                                                46185000
printerror(66);                                                         46190000
                                                                        46195000
                                                                        46200000
end; <<printdrq>>                                                       46205000
$page "                         PROCEDURE FMTDRQ"                       46210000
<<************************************************************>>        46215000
<< fmtdrq                                                     >>        46220000
<<************************************************************>>        46225000
<< finds chain heads and passes info to formatting procedures >>        46230000
<<************************************************************>>        46235000
procedure fmtdrq(optn,pldev);                                           46240000
  value optn,pldev;                                                     46245000
  integer optn,pldev;                                                   46250000
                                                                        46255000
begin                                                                   46260000
                                                                        46265000
                                                                        46270000
<< locates disc ldevs and finds current and queued requests    >>       46275000
<< for that ldev. passes chain info to formatting procedure    >>       46280000
<< printdrq which does all the link chasing and formatting     >>       46285000
<< of the drq element(s). it also calls printdrqsummary which  >>       46290000
<< prints the summary of the drq table and returs a word       >>       46295000
<< which tells if any entries in use and if we have a disab    >>       46300000
<< queue. it also checks the sysglob pointer and the dst table >>       46305000
<< pointer to make sure everything looks kosher.               >>       46310000
<< it assumes the dst table is correct.                        >>       46315000
<<*************************************************************>>       46320000
<< this procedure assumes the exsistence of the following     >>        46325000
<< procedures:-    printdrqsummary        printerror          >>        46330000
<<                 printdrq               printdrqmsg         >>        46335000
<<                 getcore                getdstaddr          >>        46340000
<<                 dcore                                      >>        46345000
<<                                                            >>        46350000
<< and assumes the existence of the following global variables>>        46355000
<<   stop'print         outfile                               >>        46360000
<<                                                            >>        46365000
<< input variables:                                           >>        46370000
<< optn              0  =  all lists                          >>        46375000
<<                   1  =  active list                        >>        46380000
<<                   2  =  available list                     >>        46385000
<< pldev            -1  =  all ldevs                          >>        46390000
<<                 >=0  =  particular ldev                    >>        46395000
<< output variables:        none                              >>        46400000
<< condition code returns:  none                              >>        46405000
<<************************************************************>>        46410000
                                                                        46415000
logical inuseinfo,   << return from printdrqsummary >>                  46420000
          curreqp,   << current req pntr, word2 of dit >>               46425000
         ditflags,   << word 0 of dit               >>                  46430000
           cdtdst,   << holds dstnum of cache directory >>              46435000
          de'ldev,   << holds ldev of mapped domain >>                  46440000
          de'head,   << holds headp mapped domain >>                    46445000
          de'tail,   << holds tailp mapped domain >>                    46450000
           de'num,                                                      46455000
            count,                                                      46460000
         cdt'next,   << holds index of device entry >>                  46465000
         loopstop,                                                      46470000
            index,                                                      46475000
             ditp;   << current ldev dit pointer    >>                  46480000
                                                                        46485000
                                                                        46490000
double   lpdtbase,   << memory addres of lpdt >>                        46495000
          drqbase,   << memory address of drq >>                        46500000
          cdtbase,   << memory address of cdt >>                        46505000
           dqreqp;   << queued req head/tail pntrs, dit wd 8/9 >>       46510000
                                                                        46515000
integer   ldev:=0,   << current ldev number >>                          46520000
          maxldev,   << for maxldev from lpdt >>                        46525000
              len;   << for ascii returns >>                            46530000
                                                                        46535000
equate     active  =  0, << request type for printdrq >>                46540000
         disabled  =  1, << as above                  >>                46545000
            avail  =  2, << as above                  >>                46550000
        queuedreq  =  3, << as above                  >>                46555000
       cur'offset  =  2, << dit word with cur req pntr >>               46560000
      qreq'offset  =  8, << dit word with q head pntr  >>               46565000
       no'cur'req  =  3, << msgnum for printdrqmsg    >>                46570000
         nodisabq  =  4, << msgnum for printdrqmsg    >>                46575000
         serialwq  =  6, << request type for printdrq >>                46580000
             ldrq  =  7, << as above                  >>                46585000
           drqdst  =  %70,                                              46590000
          lpdtdst  =  %15,                                              46595000
          cdtaddr  =  %1274,                                            46600000
            l'drq  =  %16;                                              46605000
                                                                        46610000
                                                                        46615000
array lbuf(0:19);                                                       46620000
byte array buf(*)=lbuf;                                                 46625000
byte array temp'b(0:11); << for ascii returns >>                        46630000
array lf(0:1);           << for linefeeds >>                            46635000
array lpdtve(0:3);       << holds lpdt for mpeve (4 word entry) >>      46640000
array cdtbuf(0:23);      << holds cdt entry >>                          46645000
array indexlist(0:100);<< holds mapped domain entries >>                46650000
                                                                        46655000
define       disc  =  (1:1)#, << bit in ditflags, says if disc >>       46660000
         terminal  =  (0:1)#, << ditflag bit, set if terminal  >>       46665000
       virtualdev  =  (0:1)#, << lpdt word 0, real dev ?       >>       46670000
          current  =  (14:1)#,<< inuseinfo bit, set if cur req >>       46675000
        s'write'q  =  inuseinfo.(13:1)#, <<set if we have one  >>       46680000
        disabledq  =  (15:1)#,<< inuseinfo bit, set if disabq  >>       46685000
         linefeed  =  lf:=%20040;                                       46690000
                      write'rec(outfile,lf,1,0)#;                       46695000
                                                                        46700000
subroutine check'continue;                                              46705000
begin                                                                   46710000
if stop'print then begin                                                46715000
  stop'print := false;                                                  46720000
  go jump'out;  << clear flag and go back to ci >>                      46725000
  end;                                                                  46730000
end;  << check'continue >>                                              46735000
                                                                        46740000
                                                                        46745000
<< a quick check on sysglob and dst pointers. if they don't >>          46750000
<< agree then printerror and continue.  in case of          >>          46755000
<< disagreement, use the dst pointer.                       >>          46760000
                                                                        46765000
tos:=getdstaddr(drqdst);  << get dst table pointer >>                   46770000
assemble(delb);   << delete bank number >>                              46775000
if mpeversion = 4 then                                        <<850823>>46780000
  tos:=core(%1031d)+%1000   << get sysglob pointer mpe 4 >>   <<850823>>46785000
else tos:=(core(%1017d)land%177740)+%1000; << mpev >>         <<850823>>46790000
assemble(cmp);    << are they the same ? >>                             46795000
if <> then printerror(67);                                              46800000
                                                                        46805000
                                                                        46810000
! i removed the calls to disable'autostop, enable'autostop    <<860429>>46815000
! and prompt'stop because they were screwing up the autostop  <<860429>>46820000
! on/off command operation.                                   <<860429>>46825000
                                                                        46830000
if optn = 0 then                                                        46835000
  begin                                                                 46840000
  inuseinfo:=printdrqsummary;  << print summary, get active info >>     46845000
  if <> then return;                                                    46850000
  end;                                                                  46855000
                                                                        46860000
if optn = 0 or optn = 1 then                                            46865000
  begin                                                                 46870000
  linefeed;linefeed;    << make it nice >>                              46875000
                                                                        46880000
  printdrqmsg(active);  << print active list header >>                  46885000
                                                                        46890000
  linefeed;                                                             46895000
                                                                        46900000
  if not inuseinfo.current then printdrqmsg(no'cur'req)                 46905000
    else begin                                                          46910000
      lpdtbase:=getdstaddr(lpdtdst);  << get lpdtbase address >>        46915000
      if <> then go err;                                                46920000
      if mpeve then                                                     46925000
      maxldev:=core(lpdtbase)                                           46930000
      else                                                              46935000
      maxldev:=core(lpdtbase).(0:8); << get max # ldevs on system >>    46940000
      while (ldev:=ldev+1) < (maxldev+1) do begin << go through ldevs >>46945000
      if ctrly then begin                                     <<850823>>46950000
        write'rec(outfile,lbuf,0,0); <<start a new line>>     <<850823>>46955000
        move buf:=" <CONTROL-Y>";                             <<850823>>46960000
        write'rec(outfile,lbuf,-12,%60);                      <<850823>>46965000
        return; end;                                          <<850823>>46970000
      if mpeve then begin                                               46975000
      getcore(lpdtbase+double(ldev*4),4,lpdtve);                        46980000
      if <> then go err;                                                46985000
      ditp := lpdtve(2) + %1000  << ditp in word 3 ,mpeve only >>       46990000
      end else                                                          46995000
        ditp:=(core(lpdtbase+double(ldev*2)))+%1000;                    47000000
      if mpeve then begin                                               47005000
        if not lpdtve(0).virtualdev then begin                          47010000
          ditflags:=core(double(ditp));  << get flags >>                47015000
          if ditflags.disc and not ditflags.terminal then begin         47020000
            << not interested in terminals >>                           47025000
            if (curreqp:=core(double(ditp+cur'offset))) <> 0            47030000
            then begin  << have an active request >>                    47035000
              linefeed;linefeed;                                        47040000
              move buf:=" ";                                            47045000
              move buf(1):=buf,(39);                                    47050000
              move buf:="CURRENT REQUEST FOR LDEV ";                    47055000
              ascii(ldev,10,buf(25));                                   47060000
              write'rec(outfile,lbuf,-27,0);                            47065000
              linefeed;                                                 47070000
              printdrq(active,curreqp,0,pldev); << print it >>          47075000
              if <> then return; << error will already have been >>     47080000
                                 << handled so just return.      >>     47085000
              check'continue;                                           47090000
              if (dqreqp:=dcore(double(ditp+qreq'offset))) <> 0d        47095000
              then begin  << also have queued requests >>               47100000
                linefeed;                                               47105000
                check'continue;                                         47110000
                tos:=queuedreq;  << parm for printdrq >>                47115000
                tos:=dqreqp; << put parms on stack ready for pcal >>    47120000
                printdrq(*,*,*,pldev); << print queued requests >>      47125000
                if <> then return; << error, return to ci >>            47130000
                check'continue;                                         47135000
                end;                                                    47140000
              end                                                       47145000
            else                                                        47150000
              begin << this ldev has no current request >>              47155000
              linefeed;                                                 47160000
              move buf:=" ";                                            47165000
              move buf(1):=buf,(39);                                    47170000
              move buf:=" LDEV    NO CURRENT REQUEST";                  47175000
              ascii(ldev,10,buf(6));                                    47180000
              write'rec(outfile,lbuf,20,0);                             47185000
              end;                                                      47190000
            end;                                                        47195000
          end;                                                          47200000
        end else begin                                                  47205000
        if not ditp.virtualdev then begin                               47210000
          ditflags:=core(double(ditp));  << get flags >>                47215000
          if ditflags.disc and not ditflags.terminal then begin         47220000
            << not interested in terminals >>                           47225000
            if (curreqp:=core(double(ditp+cur'offset))) <> 0            47230000
            then begin  << have an active request >>                    47235000
              linefeed;linefeed;                                        47240000
              move buf:=" ";                                            47245000
              move buf(1):=buf,(39);                                    47250000
              move buf:="CURRENT REQUEST FOR LDEV ";                    47255000
              ascii(ldev,10,buf(25));                                   47260000
              write'rec(outfile,lbuf,-27,0);                            47265000
              linefeed;                                                 47270000
              printdrq(active,curreqp,0,pldev); << print it >>          47275000
              if <> then return; << error will already have been >>     47280000
                                 << handled so just return.      >>     47285000
              check'continue;                                           47290000
              if (dqreqp:=dcore(double(ditp+qreq'offset))) <> 0d        47295000
              then begin  << also have queued requests >>               47300000
                linefeed;                                               47305000
                check'continue;                                         47310000
                tos:=queuedreq;  << parm for printdrq >>                47315000
                tos:=dqreqp; << put parms on stack ready for pcal >>    47320000
                printdrq(*,*,*,pldev); << print queued requests >>      47325000
                if <> then return; << error, return to ci >>            47330000
                check'continue;                                         47335000
                end;                                                    47340000
              end                                                       47345000
            else                                                        47350000
              begin << this ldev has no current request >>              47355000
              linefeed;                                                 47360000
              move buf:=" ";                                            47365000
              move buf(1):=buf,(39);                                    47370000
              move buf:=" LDEV    NO CURRENT REQUEST";                  47375000
              ascii(ldev,10,buf(6));                                    47380000
              write'rec(outfile,lbuf,20,0);                             47385000
              end;                                                      47390000
            end;                                                        47395000
          end;                                                          47400000
        end;                                                            47405000
      end;                                                              47410000
    end;                                                                47415000
  end;                                                                  47420000
                                                                        47425000
if optn = 0 then                                                        47430000
  begin                                                                 47435000
  linefeed;linefeed;   << keep format nice >>                           47440000
  printdrqmsg(disabled);   << print disabled list header >>             47445000
  linefeed;                                                             47450000
                                                                        47455000
  if not inuseinfo.disabledq then printdrqmsg(nodisabq)                 47460000
    else begin                                                          47465000
      drqbase:=getdstaddr(drqdst);  << get table base >>                47470000
      if <> then go err;                                                47475000
      if mpeve then begin                                               47480000
      tos:=avail;                                                       47485000
      tos:=dcore(drqbase+11d);                                          47490000
      printdrq(*,*,*,pldev);                                            47495000
      end else begin                                                    47500000
      tos:=avail;                                                       47505000
      tos:=dcore(drqbase+8d); << disabled offset in drq>>               47510000
      printdrq(*,*,*,pldev);   << print disabled list >>                47515000
      end;                                                              47520000
      if <> then return; << error already handled, just return >>       47525000
      check'continue;                                                   47530000
      end;                                                              47535000
                                                                        47540000
  if mpevp or mpeve then begin                                          47545000
      linefeed;linefeed;  << keep it nice >>                            47550000
      printdrqmsg(21);   << s write q header >>                         47555000
      linefeed;                                                         47560000
      if not s'write'q then printdrqmsg(22)                             47565000
        else                                                            47570000
          begin                                                         47575000
          tos:=serialwq;                                                47580000
          tos:=dcore(drqbase+13d);                                      47585000
          printdrq(*,*,*,pldev);                                        47590000
          if <> then return;                                            47595000
          end;                                                          47600000
      check'continue;                                                   47605000
      end;                                                              47610000
    end;                                                                47615000
                                                                        47620000
if optn = 0 or optn = 2 then                                            47625000
  begin                                                                 47630000
  << now start on the available list >>                                 47635000
                                                                        47640000
  linefeed;linefeed;                                                    47645000
  printdrqmsg(avail);    << print the heading >>                        47650000
  linefeed;                                                             47655000
                                                                        47660000
  drqbase:=getdstaddr(drqdst);                                          47665000
  if <> then go err;                                                    47670000
  if mpeve then begin                                                   47675000
  tos := avail;                                                         47680000
  tos := dcore(drqbase+4d);                                             47685000
  printdrq(*,*,*,pldev);                                                47690000
  if <> then return;                                                    47695000
  end else begin                                                        47700000
  tos:=avail;                                                           47705000
  tos:=dcore(drqbase+2d);  << get avail head/tail from drq >>           47710000
  printdrq(*,*,*,pldev);  << print the available list >>                47715000
  if <> then return; << error already handled, just return >>           47720000
  end;                                                                  47725000
  check'continue;                                                       47730000
end;                                                                    47735000
                                                                        47740000
if (mpevp or mpeve) and optn = 0 then begin                             47745000
                                                                        47750000
<< but only if disc caching was enabled           >>                    47755000
cdtdst:=core(double(%1273));  << dstnum in sysglob>>                    47760000
if <> then go err;                                                      47765000
if cdtdst=0 then go cache'dis; << don't have any >>                     47770000
tos:=getdstaddr(cdtdst);                                                47775000
if <> then go err;                                                      47780000
assemble (ddup);              << duplicate bank & base >>               47785000
cdtbase := tos;               << save it >>                             47790000
tos:=dcore(double(cdtaddr));  << get bank & base from sysglob >>        47795000
assemble(dcmp);                                                         47800000
if <> then printerror(67);                                              47805000
                              << continue with cdtbase >>               47810000
getcore(cdtbase,24,cdtbuf);   << get cdt header >>                      47815000
if <> then go err;                                                      47820000
cdt'next:= cdtbuf(7);         << save entry # to first entry >>         47825000
maxldev := cdtbuf(6);         << number of cached ldev's >>             47830000
ldev:= 1;                     << begin with the first entry >>          47835000
printdrqmsg(23);      << *** logical disc requests *** >>               47840000
                                                                        47845000
while ldev <= maxldev do begin                                          47850000
                      << loop trough the cdt device entries >>          47855000
if ctrly then begin                                           <<850823>>47860000
  write'rec(outfile,lbuf,0,0); <<start a new line>>           <<850823>>47865000
  move buf:=" <CONTROL-Y>";                                   <<850823>>47870000
  write'rec(outfile,lbuf,-12,%60);                            <<850823>>47875000
  return; end;                                                <<850823>>47880000
getcore (cdtbase+double(cdt'next*24),24,cdtbuf);                        47885000
if <> then go err;                                                      47890000
cdt'next:= cdtbuf;  <<save next, link by word 0 >>                      47895000
de'ldev:=cdtbuf(2);  << save ldev for this disc >>                      47900000
move buf:="*** LOGICAL DISC REQUESTS  LDEV      ***";                   47905000
len:=ascii(de'ldev,8,temp'b);   << log disc req ldev # >>               47910000
move buf(35-len):=temp'b(6-len),(len);                                  47915000
write'rec(outfile,lbuf,-40,0);                                          47920000
linefeed;                                                               47925000
                                                                        47930000
de'head:=cdtbuf(5);  << save headp of mapped domain >>                  47935000
de'tail:=cdtbuf(6);  << save tailp of mapped domain >>                  47940000
de'num :=cdtbuf(4);  << save total numbers of mapped dom entr >>        47945000
index := de'head;                                                       47950000
loopstop:=de'num;                                                       47955000
count:=de'num;                                                          47960000
do begin  << save all domain entry index >>                             47965000
   indexlist (count:=count-1):=index; <<save pointer>>                  47970000
   index := core(cdtbase+double(index+1)); << take next >>              47975000
   if <> then go err;                                                   47980000
   loopstop:=loopstop-1;                                                47985000
   if = then go bot;                                                    47990000
   end                                                                  47995000
until index = de'tail;                                                  48000000
                                                                        48005000
<< now we have to check if there is a logical disc request >>           48010000
<< in the mapped domain entry >>                                        48015000
                                                                        48020000
while count < de'num do begin                                           48025000
getcore (cdtbase + double(index:=indexlist(count)),24,cdtbuf);          48030000
if <> then go err;                                                      48035000
                                                                        48040000
   if cdtbuf(l'drq) <> 0 then                                           48045000
      printdrq(ldrq,cdtbuf(l'drq),0,pldev); << print this domain >>     48050000
end;                                                                    48055000
ldev:=ldev+1;                                                           48060000
end;                                                                    48065000
                                                                        48070000
return;                                                                 48075000
                                                                        48080000
bot:                                                                    48085000
printerror(66);                                                         48090000
return;                                                                 48095000
                                                                        48100000
cache'dis:                                                              48105000
                                                                        48110000
                                                                        48115000
                                                                        48120000
                                                                        48125000
end;                                                                    48130000
                                                                        48135000
jump'out:         << stop'print escape route >>                         48140000
return;           << back to ci >>                                      48145000
                                                                        48150000
err:   << come here on error, getcore, etc >>                           48155000
printerror(65); << unable to format drq because of error >>             48160000
                                                                        48165000
end; <<fmtdrq>>                                                         48170000
                                                                        48175000
$page"                 PROCEDURE FMTIOQ"                                48180000
<<************************************************************>>        48185000
<< fmtioq                                                     >>        48190000
<<************************************************************>>        48195000
<< finds chain heads and passes info to formatting procedures >>        48200000
<<************************************************************>>        48205000
procedure fmtioq(optn,pldev);                                           48210000
  value optn,pldev;                                                     48215000
  integer optn,pldev;                                                   48220000
                                                                        48225000
begin                                                                   48230000
                                                                        48235000
comment                                                                 48240000
                                                                        48245000
procedure printioqsummary is called to print the summary info of        48250000
the ioq. in the case of system halt4 the ics seems to overflow          48255000
a fair way into the ioq before the ucode detects problem.               48260000
so if the summary is garbage this is probably why. code                 48265000
goes through all the ldevs spotting which ones aren't                   48270000
discs. it goes to the dit for qualifying devices and looks              48275000
for an ioq pointer, if there is one it calls printioq to print          48280000
it and to look for any queued requests. once it has done all that       48285000
it calls printioq again and passes the available list head and          48290000
tail pointers so printioq can format the available list.                48295000
                                                                        48300000
                                                                        48305000
condition code returns:       none                                      48310000
input variables:                                                        48315000
optn            0  = all lists                                          48320000
                1  = active list                                        48325000
                2  = available list                                     48330000
pldev          -1  = all ldevs                                          48335000
              >=0  = particular ldev                                    48340000
output variables:             none                                      48345000
                                                                        48350000
this procedure assumes the exsistence of the following procedures       48355000
    core        getdstaddr     printerror     printioq                  48360000
    printioqmsg      printioqsummary          dcore                     48365000
                                                                        48370000
and the following global variables      stop'print     outfile          48375000
                                                                        48380000
;                                                                       48385000
                                                                        48390000
                                                                        48395000
integer ldev:=0,    << holds current ldev >>                            48400000
        maxldev;    << holds max ldev from lpdt wd0.(0:8) >>            48405000
                                                                        48410000
logical ditp,       << holds ditp for current ldev from lpdt >>         48415000
        ditflags,   << holds word0 of dit for current ldev   >>         48420000
        ioqp,       << holds the ioqp from the dit           >>         48425000
        lf:=%20040; << used for linefeeds                    >>         48430000
                                                                        48435000
double  lpdtbase,   << holds bank & base of lpdt dst         >>         48440000
        ioqbase;    << holds bank & base of ioq dst          >>         48445000
                                                                        48450000
array   lpdtve(0:3);<< holds lpdt entry for mpeve            >>         48455000
                                                                        48460000
equate  ioqdst   =   %13,   << dst number of ioq >>                     48465000
        lpdtdst  =   %15,   << lpdt dst number   >>                     48470000
     ioqp'offset =   2,     << offset in dit to ioqp     >>             48475000
        inuse    =   4,     << request type for printioq >>             48480000
        avail    =   5;     << request type for printioq >>             48485000
                                                                        48490000
define  disc     =   (1:1)#,                                            48495000
      virtualdev =   (0:1)#,                                            48500000
        terminal =   (0:1)#,                                            48505000
        linefeed =   write'rec(outfile,lf,1,0)#;                        48510000
                                                                        48515000
                                                                        48520000
subroutine check'continue;                                              48525000
begin                                                                   48530000
if stop'print then begin                                                48535000
  stop'print := false;                                                  48540000
  go jump'out;  << clear flag and go back to ci >>                      48545000
  end;                                                                  48550000
end;  << check'continue >>                                              48555000
                                                                        48560000
                                                                        48565000
                                                                        48570000
<< look at sysdb and dst pointers, if not the >>                        48575000
<< same then output error msg and carry on using dst pointer. >>        48580000
                                                                        48585000
tos:=getdstaddr(ioqdst);                                                48590000
if <> then go err;                                                      48595000
assemble(ddup);   << duplicate bank and base of ioq dst >>              48600000
ioqbase:=tos;     << save for later >>                                  48605000
if not mpeve then begin                                       <<850830>>48610000
  tos:=(core(%1005d)land%177740)+%1000;   << get sysglob pointer >>     48615000
  assemble( cmp; del ); << compare the two and pop bank number >>       48620000
  if <> then printerror(67);                                            48625000
end;   << this cuz ioq dst could be in bank 1 for mpe v/e >>  <<850830>>48630000
                                                                        48635000
                                                                        48640000
! i knocked out the calls to enable/disable'autostop and      <<860429>>48645000
! prompt'stop because they were screwing up the operation of  <<860429>>48650000
! the autostop on/off command.                                <<860429>>48655000
                                                                        48660000
if optn = 0 then                                                        48665000
  begin                                                                 48670000
  printioqsummary;   << print the summary info >>                       48675000
  if <> then return; << error will already have handled, just return >> 48680000
  linefeed;linefeed;                                                    48685000
  end;                                                                  48690000
                                                                        48695000
lpdtbase:=getdstaddr(lpdtdst);                                          48700000
if <> then go err;                                                      48705000
if mpeve then                                                           48710000
maxldev:=core(lpdtbase)     << mpeve may have more >>                   48715000
else                                                                    48720000
maxldev:=core(lpdtbase).(0:8);  << find highest ldev from lpdt >>       48725000
                                                                        48730000
<< now the inuse ioqs >>                                                48735000
if optn = 0 or optn = 1 then                                            48740000
  begin                                                                 48745000
  check'continue;                                                       48750000
  printioqmsg(31);   << in-use list header >>                           48755000
  linefeed;                                                             48760000
  printioq(inuse,0,-1,pldev);  << col headings >>                       48765000
  while (ldev:=ldev+1) <> (maxldev+1) do begin << go through ldevs >>   48770000
    if ctrly then begin                                       <<850830>>48775000
      write'rec(outfile,lbuf,0,0);                            <<850830>>48780000
      move buf:=" <CONTROL-Y>";                               <<850830>>48785000
      write'rec(outfile,lbuf,-12,%60);                        <<850830>>48790000
      return;                                                 <<850830>>48795000
    end;                                                      <<850830>>48800000
     if mpeve then begin  << in mpeve 4 word entry and ditp >>          48805000
     getcore (lpdtbase +double(ldev*4),4,lpdtve); << in word 3>>        48810000
     if <>then go err;                                                  48815000
     ditp := lpdtve(2) + %1000  << ditp sysbase rel>>                   48820000
     end else                                                           48825000
      ditp:=(core(lpdtbase+double(ldev*2)))+%1000; << get ditp >>       48830000
      if mpeve then begin                                               48835000
      if not lpdtve(0).virtualdev then begin                            48840000
         ditflags:=core(double(ditp)); << get ditflags from dit >>      48845000
         if <> then go err;                                             48850000
         if not ditflags.disc or ditflags.terminal then begin           48855000
      << want no discs here >>                                          48860000
            if (ioqp:=core(double(ditp+ioqp'offset))) <> 0 then begin   48865000
           << ldev is doing something >>                                48870000
               printioq(inuse,ioqp,0,pldev);<< print & find queued ioqs 48875000
               if <> then return; << had an error, bail out >>          48880000
               check'continue;                                          48885000
               end;                                                     48890000
         end;                                                           48895000
      end;                                                              48900000
      end else    <<end mpeve >>                                        48905000
      begin                                                             48910000
      if not ditp.virtualdev then begin                                 48915000
         ditflags:=core(double(ditp)); << get ditflags from dit >>      48920000
         if <> then go err;                                             48925000
         if not ditflags.disc or ditflags.terminal then begin           48930000
      << want no discs here >>                                          48935000
            if (ioqp:=core(double(ditp+ioqp'offset))) <> 0 then begin   48940000
           << ldev is doing something >>                                48945000
               printioq(inuse,ioqp,0,pldev);<< print & find queued ioqs 48950000
               if <> then return; << had an error, bail out >>          48955000
               check'continue;                                          48960000
               end;                                                     48965000
         end;                                                           48970000
      end;                                                              48975000
     end;                                                               48980000
    end;                                                                48985000
  end;                                                                  48990000
                                                                        48995000
                                                                        49000000
<< now the available list >>                                            49005000
if optn = 0 or optn = 2 then                                            49010000
  begin                                                                 49015000
  linefeed;linefeed;                                                    49020000
                                                                        49025000
  printioqmsg(32);    << available list header >>                       49030000
  check'continue;                                                       49035000
                                                                        49040000
  if mpeve then begin                                                   49045000
  tos:=avail;                                                           49050000
  tos:=dcore(ioqbase+4d);                                               49055000
  printioq(*,*,*,pldev);                                                49060000
  end else begin                                                        49065000
  tos:=avail;                                                           49070000
  tos:=dcore(ioqbase+2d);  << get head/tail from ioq header info >>     49075000
  printioq(*,*,*,pldev);                                                49080000
  end;                                                                  49085000
  if <> then return;                                                    49090000
  check'continue;                                                       49095000
  end;                                                                  49100000
                                                                        49105000
                                                                        49110000
jump'out:                                                               49115000
return;                                                                 49120000
                                                                        49125000
err:                                                                    49130000
printerror(68);                                                         49135000
                                                                        49140000
                                                                        49145000
end; <<fmtioq>>                                                         49150000
$page "                        PROCEDURE FMTDIT"                        49155000
<<************************************************************>>        49160000
<< fmtdit                                                     >>        49165000
<<************************************************************>>        49170000
<< formats dits for ldevs which aren't terminals              >>        49175000
<<************************************************************>>        49180000
procedure fmtdit(ldevnum);                                              49185000
value ldevnum;                                                          49190000
integer ldevnum;                                                        49195000
option variable;                                                        49200000
begin                                                                   49205000
                                                                        49210000
<< condition code returned as follows        >>                         49215000
<<                                           >>                         49220000
<< ccg - getcore failed getting ldt or lpdt  >>                         49225000
<< cce - successful                          >>                         49230000
<< ccl - getdstaddr failed                   >>                         49235000
                                                                        49240000
                                                                        49245000
define                                                                  49250000
              cc = status.(6:2)#,                                       49255000
      virtualdev = (0:1)#;  << lpdt1 bit for ldevs >>                   49260000
                                                                        49265000
logical type,        << holds type of current ldev >>                   49270000
        terminal,    << set by find'ditlen if current ldev is >>        49275000
                     << a terminal. ( true = terminal )       >>        49280000
        ditflags,    << holds word 0 of dit for current ldev  >>        49285000
        sub'type,    << holds subtype of current ldev >>                49290000
        lpdt1,       << first word of lpdt entry   >>                   49295000
        lpdt2,       << second word of lpdt entry  >>                   49300000
        lpdt3,       << 3. word lpdt (mpeve only) >>                    49305000
        lpdt4,       << 4. word lpdt (mpeve only) >>                    49310000
        ditp,        << pointer to dit for current ldev >>              49315000
        dltp,        << pointer to dlt for current ldev >>              49320000
        dltword5,    << word 5 of dlt = dev type & ditlen >>            49325000
        ditlen,      << length in words of dit     >>                   49330000
        one'ldev=q-4,<< parm map, see if all ldevs or just one >>       49335000
        status = q-1;<< for cond code return >>                         49340000
                                                                        49345000
                                                                        49350000
double  lpdtentry=lpdt1,  << holds lpdt entry for ldev >>               49355000
        lpdtbase,    << base address of lpdt  >>                        49360000
        ldtbase;     << base address of ldt   >>                        49365000
                                                                        49370000
integer ldev:=0,     << holds current ldev >>                           49375000
        maxldev,     << max ldev # from lpdt >>                         49380000
        len;         << for ascii intrinsic >>                          49385000
                                                                        49390000
array   lbuf(0:39),                                                     49395000
        lf(0:1),                                                        49400000
        ldtbuf(0:4), << holds current ldevs ldt entry >>                49405000
        lpdtve(*)= q+5; << holds lpdt entry for ldev (mpeve) >>         49410000
              << must be lpdt1....lpdt4 >>                              49415000
equate  ldtdst  =  %16,   << dst num of ldt >>                          49420000
       lpdtdst  =  %15,   << as above but for lpdt >>                   49425000
         octal  =  0;     << need for mode selection in octaldump >>    49430000
                                                                        49435000
                                                                        49440000
byte array buf(*)=lbuf;                                                 49445000
                                                                        49450000
                                                                        49455000
                                                                        49460000
logical subroutine find'ditlen(ditp);                                   49465000
value ditp;                                                             49470000
logical ditp;                                                           49475000
begin                                                                   49480000
                                                                        49485000
<< dlt word 5.(0:8) is the length in words of the dit for >>            49490000
<< the particular driver. use word 4 of dit to track down >>            49495000
<< the dlt.                                               >>            49500000
<< also found that ldt is not always in memory and as luck              49505000
   would have it dlt word 5.(8:8) is the device type, so will           49510000
   get the device type from here. >>                                    49515000
<< i also noticed that multipoint terminals don't                       49520000
   set the terminal bit in their dits.                                  49525000
   means have to check device type now to                               49530000
   sort it out                                                          49535000
>>                                                                      49540000
                                                                        49545000
                                                                        49550000
dltp:=core(double(ditp+4));  << get word 4 of dit >>                    49555000
dltp:=dltp+%1005;  << adjust sysdb rel and set addr for word 5 >>       49560000
dltword5:=core(double(dltp));  << get dit len and dev type >>           49565000
                                                                        49570000
ditflags:=core(double(ditp));  << get dit flags >>                      49575000
                                                                        49580000
find'ditlen:=dltword5.(0:8)-1;  << set up ditlen for return >>          49585000
type:=dltword5.(8:8);  << keep the device type >>                       49590000
                                                                        49595000
if ditflags.(0:1) or type = 16 or type > 32 then                        49600000
    terminal:=true else terminal:=false;                                49605000
                                                                        49610000
end;   << subroutine find'ditlen >>                                     49615000
                                                                        49620000
                                                                        49625000
                                                                        49630000
subroutine printinfo(dev);                                              49635000
value dev;                                                              49640000
integer dev;                                                            49645000
begin                                                                   49650000
                                                                        49655000
write'rec(outfile,lf,1,0);                                              49660000
move buf:=" LDEV :     TYPE :      SUBTYPE : ";                         49665000
ascii(dev,10,buf(7));                                                   49670000
ascii(type,10,buf(18));                                                 49675000
len:=ascii(sub'type,10,buf(34));                                        49680000
write'rec(outfile,lbuf,-(len+34),0);                                    49685000
octaldump(outfile,double(ditp),double(ditp+ditlen),octal,1);            49690000
                                                                        49695000
end;   << subroutine printinfo >>                                       49700000
                                                                        49705000
                                                                        49710000
lpdtbase:=getdstaddr(lpdtdst); << get base addr of lpdt >>              49715000
if <> then go dst'err;                                                  49720000
if mpeve then                                                           49725000
maxldev:=core(lpdtbase)  <<get maxldev from word0 lpdt >>               49730000
else                                                                    49735000
maxldev:=core(lpdtbase).(0:8);  << get max ldev from word0 lpdt >>      49740000
                                                                        49745000
if one'ldev then begin << just want dit for one ldev >>                 49750000
    if ldevnum > maxldev then begin                                     49755000
        printerror(68);                                                 49760000
        return;                                                         49765000
        end;                                                            49770000
    if mpeve then  begin                                                49775000
    getcore (lpdtbase+double(ldevnum*4),4,lpdtve); << mpeve only >>     49780000
    if <> then go err                                                   49785000
    end else begin                                                      49790000
    lpdtentry:=dcore(lpdtbase+double(ldevnum*2));                       49795000
    if <> then go err;                                                  49800000
    end;                                                                49805000
    if not lpdt1.virtualdev then begin                                  49810000
        sub'type:=lpdt2.(12:4);                                         49815000
        if mpeve then                                                   49820000
           ditp:= lpdt3 + %1000  << ditp sysdbrel. >>                   49825000
        else                                                            49830000
           ditp:=lpdt1+%1000;  << make ditp abs >>                      49835000
        ditlen:=find'ditlen(ditp);  << get dit length >>                49840000
        printinfo(ldevnum);                                             49845000
        end;                                                            49850000
    return;                                                             49855000
    end;                                                                49860000
                                                                        49865000
move buf:="**** DITS FOR EVERYTHING BUT TERMINALS ****";                49870000
write'rec(outfile,lbuf,-43,0);                                          49875000
lf:=%20040;                                                             49880000
write'rec(outfile,lf,1,0);                                              49885000
                                                                        49890000
while (ldev:=ldev+1) < (maxldev+1) do begin  << scan through ldevs >>   49895000
    if ctrly then begin                                       <<850830>>49900000
      write'rec(outfile,lbuf,0,0);                            <<850830>>49905000
      move buf:=" <CONTROL-Y>";                               <<850830>>49910000
      write'rec(outfile,lbuf,-12,%60);                        <<850830>>49915000
      return;                                                 <<850830>>49920000
    end;                                                      <<850830>>49925000
    if stop'print then begin                                            49930000
        stop'print:=false;                                              49935000
        return;        << go back to ci >>                              49940000
        end;                                                            49945000
    if mpeve then begin                                                 49950000
    getcore (lpdtbase+double (ldev*4),4,lpdtve);                        49955000
    if <> then go err                                                   49960000
    end else begin                                                      49965000
    lpdtentry:=dcore(lpdtbase+double(ldev*2));                          49970000
    if <> then go err;                                                  49975000
    end;                                                                49980000
    if not lpdt1.virtualdev then begin  << real ldevs only >>           49985000
<< find'ditlen now gets device type from dlt, ldt may be out >>         49990000
        sub'type:=lpdt2.(12:4);                                         49995000
        if mpeve then                                                   50000000
        ditp := lpdt3 + %1000   << ditp in word 3(mpeve) >>             50005000
        else                                                            50010000
        ditp:=lpdt1+%1000;  << ditp sysdb rel in lpdt >>                50015000
        ditlen:=find'ditlen(ditp);  << get len of dit in words >>       50020000
        if not terminal then   << dont want terminals >>                50025000
            printinfo(ldev);                                            50030000
        end;                                                            50035000
    end; << scanning through the ldevs >>                               50040000
                                                                        50045000
cc:=cce;                                                                50050000
return;                                                                 50055000
                                                                        50060000
dst'err:                                                                50065000
cc:=ccg;                                                                50070000
return;                                                                 50075000
                                                                        50080000
err:                                                                    50085000
cc:=ccl; << getcore/core problem >>                                     50090000
                                                                        50095000
                                                                        50100000
end; <<formatdit>>                                                      50105000
$page"                            PROCEDURE FMTSBUF"                    50110000
<<************************************************************>>        50115000
<< procedure fmtsbuf                                          >>        50120000
<<************************************************************>>        50125000
<< prints out the sbuf,pri msg & sec msg table summaries      >>        50130000
<<************************************************************>>        50135000
procedure fmtsbuf;                                                      50140000
begin                                                                   50145000
                                                                        50150000
                                                                        50155000
                                                                        50160000
<<************************************************************>>        50165000
<< this procedure assumes the exsistence of the following     >>        50170000
<< globule procedures -                                       >>        50175000
<<    getcore          getdstaddr                             >>        50180000
<< and the following globule variables -                      >>        50185000
<<    outfile          stop'print                             >>        50190000
<<************************************************************>>        50195000
<< condition code returns   -    none                         >>        50200000
<< input variables          -    none                         >>        50205000
<< output variables         -    none                         >>        50210000
<<************************************************************>>        50215000
                                                                        50220000
                                                                        50225000
array sbufheader(0:7),  << holds sbuf header >>                         50230000
            lbuf(0:39); << output buffer     >>                         50235000
                                                                        50240000
array primsgheader(*)=sbufheader,                                       50245000
      secmsgheader(*)=sbufheader;                                       50250000
                                                                        50255000
double array sbufhead'd(*)=sbufheader;                                  50260000
double sbufbase,  << holds bank & base of sbuf dst >>                   50265000
    pmsgtblbase,  << holds bank & base of pri msg dst >>                50270000
    smsgtblbase;  << holds bank & base of sec msg dst >>                50275000
                                                                        50280000
byte array buf(*)=lbuf;                                                 50285000
                                                                        50290000
integer len,     << for ascii return >>                                 50295000
        loop,    << counting variable >>                                50300000
        msgnum,  << message number for print'msg >>                     50305000
        count,   << byte count for print'msg >>                         50310000
        cctl;    << carraige control req'd in print'msg >>              50315000
equate   sbufdst  =  %10,  << dst# of sbufs >>                          50320000
    primsgtbldst  =  %72,  << pri msg table dst # >>                    50325000
    secmsgtbldst  =  %21,  << sec msg table dst # >>                    50330000
      numentries  =  0,    << word 0 of sbuf header >>                  50335000
           tsize  =  1,    << word 1 of sbuf header >>                  50340000
           thead  =  2,    << word 2 of sbuf header >>                  50345000
           ttail  =  3,    << word 3 of sbuf header >>                  50350000
            tuse  =  4,    << word 4 of sbuf header >>                  50355000
          tovrfl  =  5,    << word 4 of sbuf header >>                  50360000
          trqsts  =  3;    << double word 3 of sbuf header >>           50365000
                                                                        50370000
                                                                        50375000
define    secondary   =   (0:8)#,                                       50380000
            primary   =   (8:8)#,                                       50385000
         impprocpcb   =   (0:8)#,                                       50390000
          entrysize   =   (8:8)#,                                       50395000
           maxinuse   =   (0:8)#,                                       50400000
           curinuse   =   (8:8)#;                                       50405000
                                                                        50410000
define    moveprint   =   move buf:=buf(6-len),(len);                   50415000
                          write'rec(outfile,lbuf,-len,0)#,              50420000
           sbufword   =   len:=ascii(sbufheader#,                       50425000
           linefeed   =   print'msg(17,-1,0)#;                          50430000
                                                                        50435000
                                                                        50440000
                                                                        50445000
                                                                        50450000
                                                                        50455000
                                                                        50460000
subroutine print'msg(msgnum,count,cctl);                                50465000
value msgnum,count,cctl;                                                50470000
integer msgnum,count,cctl;                                              50475000
begin                                                                   50480000
                                                                        50485000
if stop'print then begin                                                50490000
    stop'print:=false;                                                  50495000
    go jump'out;  << exit procedure back to ci >>                       50500000
    end;                                                                50505000
                                                                        50510000
lbuf:="  ";                                                             50515000
move lbuf(1):=lbuf,(39);                                                50520000
                                                                        50525000
case msgnum of begin                                                    50530000
<< 0 >> move buf:="********** SYSTEM BUFFER ANALYSIS **********";       50535000
<< 1 >> move buf:="ELEMENTS IN PRI AREA      ";                         50540000
<< 2 >> move buf:="ELEMENTS IN SEC AREA      ";                         50545000
<< 3 >> move buf:="SIZE OF EACH ELEMENT      ";                         50550000
<< 4 >> move buf:="INDEX FIRST FREE ENTRY    ";                         50555000
<< 5 >> move buf:="INDEX LAST FREE ENTRY     ";                         50560000
<< 6 >> move buf:="MAX ELEMENTS IN USE       ";                         50565000
<< 7 >> move buf:="CURRENT ELEMENTS IN USE   ";                         50570000
<< 8 >> move buf:="OVERFLOWS                 ";                         50575000
<< 9 >> move buf:="TOTAL REQUESTS            ";                         50580000
<< 10>> move buf:="****** PRIMARY MESSAGE TABLE ANALYSIS ******";       50585000
<< 11>> move buf:="NUMBER OF CONFIG ENTRIES  ";                         50590000
<< 12>> move buf:="ENTRY SIZE                ";                         50595000
<< 13>> move buf:="NUMBER ENTRIES AVAILABLE  ";                         50600000
<< 14>> move buf:="INDEX 1ST FREE ENTRY      ";                         50605000
<< 15>> move buf:="PIN OF 1ST IMP PROCESS    ";                         50610000
<< 16>> move buf:="***** SECONDARY MESSAGE TABLE ANALYSIS *****";       50615000
<< 17>> ;   << just for linefeeds >>                                    50620000
<< 18>> move buf:=                                                      50625000
"**** PROBLEM FORMATTING THE TABLE ****";                               50630000
<< 19>> move buf:="*** PRI MESSAGE TABLE DST NOT IN MEMORY, SORRY ***"; 50635000
<< 20>> move buf:="*** SEC MESSAGE TABLE DST NOT IN MEMORY, SORRY ***"; 50640000
<<21>> move buf:="*** SEGMENT IS VIRTUAL ***";                          50645000
                                                                        50650000
    end;                                                                50655000
                                                                        50660000
                                                                        50665000
write'rec(outfile,lbuf,count,cctl);                                     50670000
                                                                        50675000
end; << subroutine print'msg >>                                         50680000
                                                                        50685000
                                                                        50690000
sbufbase:=getdstaddr(sbufdst);  << get addr of table >>                 50695000
if <> then go dip'out;                                                  50700000
                                                                        50705000
if vm'inuse and sbufbase >= vm'min then print'msg(21,-26,0);            50710000
                                                                        50715000
getcore(sbufbase,8,sbufheader);  << get table head >>                   50720000
if <> then go dip'out;                                                  50725000
                                                                        50730000
                                                                        50735000
linefeed;linefeed;                                                      50740000
print'msg(0,-50,0);  << header >>                                       50745000
linefeed;                                                               50750000
print'msg(1,-26,%320);  << primary elements >>                          50755000
sbufword(numentries).primary,8,buf);                                    50760000
moveprint;                                                              50765000
print'msg(2,-26,%320);  << secondary elements >>                        50770000
sbufword(numentries).secondary,8,buf);                                  50775000
moveprint;                                                              50780000
print'msg(3,-26,%320);   << element size >>                             50785000
sbufword(tsize).entrysize,8,buf);                                       50790000
moveprint;                                                              50795000
print'msg(6,-26,%320);   << max in use >>                               50800000
sbufword(tuse).maxinuse,8,buf);                                         50805000
moveprint;                                                              50810000
print'msg(7,-26,%320);   << current in use >>                           50815000
sbufword(tuse).curinuse,8,buf);                                         50820000
moveprint;                                                              50825000
print'msg(8,-26,%320);   << overflows >>                                50830000
sbufword(tovrfl),8,buf);                                                50835000
moveprint;                                                              50840000
print'msg(9,-26,%320);   << total requests >>                           50845000
len:=dascii(sbufhead'd(trqsts),8,buf);                                  50850000
move buf:=buf(11-len),(len);                                            50855000
write'rec(outfile,lbuf,-len,0);                                         50860000
print'msg(4,-26,%320);   << index of 1st free entry >>                  50865000
sbufword(thead),8,buf);                                                 50870000
moveprint;                                                              50875000
print'msg(5,-26,%320);   << index of tail >>                            50880000
sbufword(ttail),8,buf);                                                 50885000
moveprint;                                                              50890000
                                                                        50895000
                                                                        50900000
<< now for the primary message table >>                                 50905000
                                                                        50910000
linefeed;linefeed;                                                      50915000
pmsgtblbase:=getdstaddr(primsgtbldst); << get addr of table >>          50920000
if > then begin    << dst is absent >>                                  50925000
     print'msg(19,-60,0);                                               50930000
     linefeed;                                                          50935000
     go sod'it;                                                         50940000
     end;                                                               50945000
if < then go dip'out;                                                   50950000
                                                                        50955000
getcore(pmsgtblbase,5,primsgheader);<< get 1st 5 words from table >>    50960000
if <> then go dip'out;                                                  50965000
                                                                        50970000
print'msg(10,-50,0);   << header  >>                                    50975000
linefeed;                                                               50980000
loop:=0;  << init loop variable >>                                      50985000
while (loop:=loop+1) < 6 do begin                                       50990000
    print'msg(loop+10,-26,%320);                                        50995000
    len:=ascii(primsgheader(loop-1),8,buf);                             51000000
    moveprint;                                                          51005000
    end;                                                                51010000
                                                                        51015000
sod'it:  << come here if pri message table is out of memory >>          51020000
                                                                        51025000
linefeed;linefeed;                                                      51030000
smsgtblbase:=getdstaddr(secmsgtbldst);<< get addr of table >>           51035000
if > then begin                                                         51040000
    print'msg(20,-60,0);  << dst absent >>                              51045000
    linefeed;                                                           51050000
    go jump'out;    << back to ci >>                                    51055000
    end;                                                                51060000
if < then go dip'out;                                                   51065000
                                                                        51070000
getcore(smsgtblbase,5,secmsgheader);<< get 1st five words from table>>  51075000
if <> then go dip'out;                                                  51080000
                                                                        51085000
print'msg(16,-50,0);   << header >>                                     51090000
linefeed;                                                               51095000
loop:=0;   << init counter >>                                           51100000
while (loop:=loop+1) < 6 do begin                                       51105000
    print'msg(loop+10,-26,%320);                                        51110000
    len:=ascii(secmsgheader(loop-1),8,buf);                             51115000
    moveprint;                                                          51120000
    end;                                                                51125000
                                                                        51130000
                                                                        51135000
linefeed;                                                               51140000
return;  << normal exit route >>                                        51145000
                                                                        51150000
jump'out:   << stop'print exit route >>                                 51155000
return;                                                                 51160000
                                                                        51165000
dip'out:   << come here for various failures >>                         51170000
print'msg(18,-70,0);                                                    51175000
                                                                        51180000
end;   << procedure fmtsbuf >>                                          51185000
$page "                           WHICH'MPE"                            51190000
<<************************************************************>>        51195000
<<procedure which'mpe                                         >>        51200000
<<************************************************************>>        51205000
procedure which'mpe(caller);                                            51210000
value caller;                                                           51215000
logical caller;                                                         51220000
begin                                                                   51225000
                                                                        51230000
<<************************************************************>>        51235000
<< this procedure looks at sysglob extension cells 74,75,76 to>>        51240000
<< establish which base release of mpe we are looking at.     >>        51245000
<< it is responsible for setting one of the global flags, ie. >>        51250000
<< mpeiv, mpevp or mpeve and setting the global integer, for  >>        51255000
<< use in case statements, to either 0,1,2 or 3.              >>        51260000
<<************************************************************>>        51265000
<< this procedure assumes the existence of the following,     >>        51270000
<< core, getcore,   procedures                                >>        51275000
<< outfile, stop'print, mpeiv, mpevp, mpeve, mpetype variables>>        51280000
<<************************************************************>>        51285000
<< it is called from the outer block during the initialization>>        51290000
<< of the program and from ci for the 'v' command.            >>        51295000
<<************************************************************>>        51300000
<< input variables:  caller   = 1 call when texting in file   >>        51305000
<<                            = 2 call from ci                >>        51310000
<< output variables: none                                     >>        51315000
<<************************************************************>>        51320000
                                                                        51325000
array       vuf(0:2),                                                   51330000
          fwflag(0:1), << check for old/new microcode mpeve>>           51335000
           lbuf(0:39);                                                  51340000
                                                                        51345000
byte array vufb(*)=vuf,                                                 51350000
            buf(*)=lbuf;                                                51355000
                                                                        51360000
integer     len,                                                        51365000
            sysglobextnaddr; << address of sysglob extn    >>           51370000
                                                                        51375000
logical     lf;       << for linefeeds  >>                              51380000
                                                                        51385000
equate      sysglobextnpntr   =   %1377, << abs addr of pointer >>      51390000
                                         << to sysglob extension>>      51395000
                 sysglobvuf   =   %1114, << abs pntr for sysglob>>      51400000
                                         << vuf.                >>      51405000
                    vufpntr   =   %74;   << offset for vuf into >>      51410000
                                         << sysglob extension.  >>      51415000
                                                                        51420000
                                                                        51425000
define      linefeed     =     lf:=%20040;                              51430000
                               write'rec(outfile,lf,1,0)#;              51435000
                                                                        51440000
move buf:=                                                              51445000
  "MPE VERSION: HP32033 .  .  .   (BASE  .  .  ).";                     51450000
                                                                        51455000
getcore(%1114d,3,vuf);  << get first version >>                         51460000
if <> then go trouble;                                                  51465000
buf(20):=vufb(5);  << version >>                                        51470000
lbuf(11):=vuf;     << update level >>                                   51475000
buf(25):=vufb(2);   << first digit of fix >>                            51480000
buf(26):=vufb(3);   << second digit of fix >>                           51485000
                                                                        51490000
<< now to track down the base version from the sysglob extn >>          51495000
                                                                        51500000
sysglobextnaddr:=core(double(sysglobextnpntr));<<get sysdb addr>>       51505000
if <> then go trouble;                                                  51510000
sysglobextnaddr:=sysglobextnaddr+%1000; << make abs addr >>             51515000
getcore(double(sysglobextnaddr+vufpntr),3,vuf); << get words >>         51520000
if <> then go trouble;                                                  51525000
lbuf(18):=vuf;     << base mit version            >>                    51530000
buf(39):=vufb(2);  << first digit of update level >>                    51535000
buf(40):=vufb(3);  << second digit of update      >>                    51540000
lbuf(21):=vuf(2);  << get the fix level           >>                    51545000
                                                                        51550000
linefeed;                                                               51555000
write'rec(outfile,lbuf,-46,0);                                          51560000
                                                                        51565000
<< now, if we were called form the outer block we must >>               51570000
<< initialize the global mpetype variables.            >>               51575000
                                                                        51580000
if caller then begin  << caller is 1, must be texting file >>           51585000
                                                                        51590000
  mpeiv:=mpevp:=mpeve:=false;  << set to known state >>                 51595000
  mpetype:=0;                                                           51600000
                                                                        51605000
  if vufb(1)="C" then begin                                             51610000
    mpeiv:=true;                                                        51615000
    mpetype:=0;                                                         51620000
    end                                                                 51625000
  else if (vufb(1)="E" or vufb(1)="F") then begin                       51630000
    mpevp:=true;                                                        51635000
    mpetype:=1;                                                         51640000
    end                                                                 51645000
  else if vufb(1)="G" or vufb(1)="M" or vufb(1)="X" then begin          51650000
    if vufb(1)="X" or vufb(1)="M" then begin                            51655000
      move buf:=                                                        51660000
        "EXPERIMENTAL RELEASE OF MPEV.";                                51665000
      write'rec(outfile,lbuf,-29,0);                                    51670000
      end;                                                              51675000
    mpeve:=true;                                                        51680000
    getcore (%1220d,1,fwflag); << check microcode >>                    51685000
    if fwflag = 0  then                                                 51690000
      mpetype := 2  << old m-code >>                                    51695000
    else mpetype := 3; << new m-code >>                                 51700000
    end                                                                 51705000
  else begin  << cannot identify which release we are on >>             51710000
    trouble: << come here if trouble at first >>                        51715000
    move buf:=                                                          51720000
      "CANNOT IDENTIFY THE RELEASE OF MPE. WILL ASSUME MPEIV";          51725000
    write'rec(outfile,lbuf,-53,0);                                      51730000
    mpeiv:=true;                                                        51735000
    mpetype:=0;                                                         51740000
    end;                                                                51745000
  end;                                                                  51750000
                                                                        51755000
end;  << procedure which'mpe >>                                         51760000
$page "                    PROCEDURE PROCTREE"                          51765000
$control segment=format                                       <<850917>>51770000
<<*******************************************>>                         51775000
<< procedure proc'tree                       >>                         51780000
<<------------------------------------------->>                         51785000
<< this procedure prints out the process-    >>                         51790000
<< tree. proctree is called with 'f ptree'-  >>                         51795000
<< command.                                  >>                         51800000
<<*******************************************>>                         51805000
                                                                        51810000
procedure proc'tree(address,outfile);                                   51815000
value address;                                                          51820000
double address;                                                         51825000
integer outfile;                                                        51830000
                                                                        51835000
begin     << proctree  >>                                               51840000
                                                                        51845000
                                                                        51850000
  << this procedure assumes the existence of the >>                     51855000
  << global variables:                           >>                     51860000
  <<                                             >>                     51865000
  <<    pcb'good       outfile     address       >>                     51870000
  <<    pcbentry       mpetype     mpeve         >>                     51875000
  <<                                             >>                     51880000
  << and the following procedures                >>                     51885000
  <<                                             >>                     51890000
  <<    core   getcore                           >>                     51895000
                                                                        51900000
                                                                        51905000
                                                                        51910000
integer maxpin,        << # of configured entries; pcb(0) >>            51915000
        pin,           << pin# being formated >>                        51920000
        pri,           << priority >>                                   51925000
        bitmapword,    << index into bitmap >>                          51930000
        char'ctr,                                                       51935000
        n'char,                                                         51940000
        c'pin,          << current pin# >>                              51945000
        b,f,            << indices >>                                   51950000
        f'pin,          << father pin >>                                51955000
        pcb'size,       << size of pcb entry        >>                  51960000
        pcb'lw,         << last word of pcb         >>                  51965000
        bank'nr,        << bank#                    >>                  51970000
        s1 = s-1;       << top of stack - 1         >>                  51975000
                                                                        51980000
logical branch,          << true: currently in a (sub-)tree >>          51985000
        brother,         << true: brother was found >>                  51990000
        show'father,     << true: print pin# of son's father >>         51995000
        father'info,     << index (mpe5) or pin# of father >>           52000000
        son'info,        << index (mpe5) or pin# of son >>              52005000
        brother'info,    << index (mpe5) or pin# of brother >>          52010000
        stk'info,                                                       52015000
        mpe'five,        << true if mpeve and new microcode  >>         52020000
        mpe'four;        << true for all other versions of              52025000
                            mpe4 and mpe5                   >>          52030000
                                                                        52035000
                                                                        52040000
logical array bitmap(0:256),  << bit list for referenced entries >>     52045000
              text(0:99),     << output buffer >>                       52050000
              w'line(0:79);   << output buffer >>                       52055000
                                                                        52060000
integer array bro'pin(0:256),    << ... to save brother pins >>         52065000
              top'pin(0:256),    << ...to save top pins of a tree >>    52070000
              father'pin(0:256); << ...to save father pins >>           52075000
                                                                        52080000
                                                                        52085000
byte array b'text(*) = text,                                            52090000
           b'line(*) = w'line,                                          52095000
           b'bitmap(*) = bitmap,                                        52100000
           buf'ascii(0:9);                                              52105000
                                                                        52110000
double pcb'fwa,    << first word adr of pcb table >>                    52115000
       c'pcb'ptr,  << current pcb adr (low mem loc 4) >>                52120000
       adr'offset;           << offset between pcbt base & cpcb >>      52125000
                                                                        52130000
intrinsic ascii,fwrite,debug;                                           52135000
                                                                        52140000
subroutine line;                                                        52145000
begin                                                                   52150000
b'line:="-"; move b'line(1):=b'line,(78);                     <<850916>>52155000
write'rec(outfile,w'line,-79,0);                                        52160000
end;                                                                    52165000
                                                                        52170000
subroutine getmpe5;                                                     52175000
begin                                                                   52180000
 father'info  := mpe5father;                                            52185000
 son'info     := mpe5son;                                               52190000
 brother'info := mpe5brother;                                           52195000
 stk'info     := mpe5stkinfo;                                           52200000
end;                                                                    52205000
                                                                        52210000
subroutine getmpe4;                                                     52215000
begin                                                                   52220000
 father'info  := mpe4father;                                            52225000
 son'info     := mpe4son;                                               52230000
 brother'info := mpe4brother;                                           52235000
 stk'info     := mpe4stkinfo;                                           52240000
                                                                        52245000
end;                                                                    52250000
                                                                        52255000
subroutine  fmt'pcb'info;                                               52260000
begin                                                                   52265000
text := "  ";   move text(1) := text, (99);                             52270000
                                                                        52275000
<< format pcb info >>                                                   52280000
     << get process type and convert pin number to ascii >>             52285000
                       move buf'ascii(0):="     ";                      52290000
                       n'char := ascii(pin,8,buf'ascii(0));             52295000
                       if pin = c'pin then                              52300000
                            move b'text := "->",2                       52305000
                       else                                             52310000
                       move b'text(0):="  ",2;                          52315000
                       move *:=buf'ascii(6-n'char),(n'char),2;          52320000
                                                                        52325000
                                                                        52330000
                       if pcbentry(9).(0:1) = 1 then                    52335000
                          move * := " LIVE ",2;                         52340000
                       if pcbentry(9).(5:1) = 1 then                    52345000
                          move * := " STOV ",2;                         52350000
                       if pcbentry(9).(6:3)= 6 then                     52355000
                          move * := " UCOP ",2;   <<system ucop>>       52360000
                       if pcbentry(9).(6:3)= 5 then                     52365000
                          move * := " UNKNOWN ",2;                      52370000
                       if pcbentry(9).(6:3)= 4 then                     52375000
                          move * := " SYST ",2;                         52380000
                       if pcbentry(9).(6:3)=3 then                      52385000
                          move *:= " UMTASK ",2; <<user main task>>     52390000
                       if pcbentry(9).(6:3)= 2 then                     52395000
                          move * := " UMAIN ",2;                        52400000
                       if pcbentry(9).(6:3)= 1 then                     52405000
                          move *:=  " USONM ",2;                        52410000
                       if pcbentry(9).(6:3)= 0 then                     52415000
                          move *:=  " USER ",2;                         52420000
                                                                        52425000
                       if pcbentry(4).(3:1) = 1 then                    52430000
                          begin                                         52435000
                          if pcbentry(9).(1:2) = 0 then                 52440000
                          move * := " MA=>FAT ",2;                      52445000
                          if pcbentry(9).(1:2) = 1 then                 52450000
                          move * := " MA<=FAT ",2;                      52455000
                          if pcbentry(9).(1:2) = 2 then                 52460000
                          move * := " MA=>SON ",2;                      52465000
                          if pcbentry(9).(1:2) = 3 then                 52470000
                          move * := " MA<=SON ",2;                      52475000
                          end;                                          52480000
                                                                        52485000
                 <<------pinfo--------->>                               52490000
                                                                        52495000
                       if pcbentry(8).(0:3) = 1 then                    52500000
                          move * := " HK ",2;                           52505000
                       if pcbentry(8).(0:3) = 2 then                    52510000
                          move * := " SK ",2;                           52515000
                       if pcbentry(8).(0:3) = 3 then                    52520000
                          move * := " STOP ",2;                         52525000
                       if pcbentry(8).(0:3) =4 then                     52530000
                          move * := " HIBE ",2;                         52535000
                       if pcbentry(8).(0:3) = 5 then                    52540000
                          move * := " ESCA ",2;                         52545000
                       if pcbentry(8).(0:3) = 6 then                    52550000
                          move * := " BREA ",2;                         52555000
                                                                        52560000
                 <<-----wakemask------->>                               52565000
                                                                        52570000
                       if pcbentry(4).(0:1) =1 then                     52575000
                          move * := " MOUR ",2;                         52580000
                       if pcbentry(4).(1:1) = 1 then                    52585000
                          move * := " GRIN ",2;                         52590000
                       if pcbentry(4).(2:1) = 1 then                    52595000
                          move * := " LRIN ",2;                         52600000
                       if pcbentry(4).(3:1) = 1 then                    52605000
                          move * := " MAIL ",2;                         52610000
                       if pcbentry(4).(4:1) = 1 then                    52615000
                          move * := " B/IO ",2;                         52620000
                       if pcbentry(4).(5:1) = 1 then                    52625000
                          move * := " I/OW ",2;                         52630000
                       if pcbentry(4).(6:1) = 1 then                    52635000
                          move * := " UCOP ",2;                         52640000
                       if pcbentry(4).(7:1) = 1 then                    52645000
                          move * := " JUNK ",2;                         52650000
                       if pcbentry(4).(8:1) = 1 then                    52655000
                          move * := " TIME ",2;                         52660000
                       if pcbentry(4).(9:1) = 1 then                    52665000
                          move * := " MSGW ",2;                         52670000
                       if pcbentry(4).(10:1) = 1 then                   52675000
                          move * := " SONW ",2;                         52680000
                       if pcbentry(4).(11:1) = 1 then                   52685000
                          move * := " FATH ",2;                         52690000
                       if pcbentry(4).(12:1) = 1 then                   52695000
                          move * := " IMPE ",2;                         52700000
                       if pcbentry(4).(13:1) = 1 then                   52705000
                          move * := " SIRW ",2;                         52710000
                       if pcbentry(4).(14:1) = 1 then                   52715000
                          move * := " TOUT ",2;                         52720000
                       if pcbentry(4).(15:1) = 1 then                   52725000
                          move * := " MEMO ",2;                         52730000
                                                                        52735000
             << queueinfo >>                                            52740000
                                                                        52745000
           if pcbentry(13).(0:1) = 1 then                               52750000
              move * := " DISP ",2;                                     52755000
           if pcbentry(13).(1:1) = 1 then                               52760000
              move * := " LQ ",2 ;                                      52765000
           if pcbentry(13).(2:1) = 1 then                               52770000
              move * := " CQ ",2 ;                                      52775000
           if pcbentry(13).(3:1) = 1 then                               52780000
              move * := " DQ ",2;                                       52785000
           if pcbentry(13).(4:1) = 1 then                               52790000
              move * := " EQ ",2;                                       52795000
           if pcbentry(13).(5:1) = 1 then                               52800000
              move * := " INTER ",2;                                    52805000
           if pcbentry(13).(6:1) = 1 then                               52810000
              move * := " CORER ",2;                                    52815000
           if pcbentry(13).(7:1) = 1 then                               52820000
              move * := " ASOFT ",2;                                    52825000
             move * := " PRI=",2;                                       52830000
           tos:=pcbentry(13).(8:8);pri:=tos;                            52835000
             n'char:=ascii(pri,8,buf'ascii);                            52840000
             move * := buf'ascii(6-n'char),(n'char),2;                  52845000
                                                                        52850000
                                                                        52855000
         << now get resabortinfo >>                                     52860000
          if pcbentry(0).(0:1) =1 then                                  52865000
             move * := " SAR ",2;                                       52870000
          if pcbentry (0).(1:1)  = 1 then                               52875000
             move * := " BF ",2;                                        52880000
          if pcbentry(0).(2:1) = 1 then                                 52885000
             move * := " CRIT ",2;                                      52890000
          if pcbentry(0).(3:1) = 1 then                                 52895000
             move * := " HSIR ",2;                                      52900000
          if pcbentry (0).(4:1) = 1 then                                52905000
             move * := " PIOVR ",2;                                     52910000
          if pcbentry (0).(5:1) = 1 then                                52915000
             move * := " HSPRI ",2;                                     52920000
          if pcbentry (0).(6:1) = 1 then                                52925000
             move * := " IPEXP ",2;                                     52930000
          if pcbentry (0).(7:1) = 1 then                                52935000
             move * := " PC ",2;                                        52940000
          if pcbentry (0).(8:1) = 1 then                                52945000
             move * := " DSOFT ",2;                                     52950000
          if pcbentry (0).(9:1) = 1 then                                52955000
             move * := " LW ",2;                                        52960000
          if pcbentry (0).(10:1) = 1 then                               52965000
             move * := " SW ",2;                                        52970000
          if pcbentry (0).(11:1) =1 then                                52975000
             move * := " TRW ",2;                                       52980000
          if pcbentry (0).(12:1) = 1 then                               52985000
             move * := " USEDQ ",2;                                     52990000
          if pcbentry (0).(13:1) = 1 then                               52995000
             move * := " HIPRI ",2;                                     53000000
          if pcbentry (0).(14:1) = 1 then                               53005000
             move * := " STOVA ",2;                                     53010000
          if pcbentry (0).(15:1) = 1 then                               53015000
             move * := " RITBK ",2;                                     53020000
                                                                        53025000
          if show'father then                                           53030000
             begin                                                      53035000
              n'char := ascii(f'pin,8,buf'ascii(0));                    53040000
              move * := " FATH = ",2;                                   53045000
              move * := buf'ascii(6-n'char),(n'char),2;                 53050000
              show'father := false;                                     53055000
             end;                                                       53060000
                                                                        53065000
          char'ctr := tos - @b'text;                                    53070000
                                                                        53075000
         write'rec(outfile,text,-char'ctr,0);                           53080000
end;  << subroutine fmt'pcb'info >>                                     53085000
                                                                        53090000
                                                                        53095000
                                                                        53100000
                                                                        53105000
<< main body >>                                                         53110000
                                                                        53115000
mpe'four := mpe'five := false;                                          53120000
if  mpeve and (mpetype = 3) then                                        53125000
   begin                                                                53130000
    mpe'five := true;                                                   53135000
    pcb'size := %25;                                                    53140000
    pcb'lw := 20;                                                       53145000
   end                                                                  53150000
 else                                                                   53155000
   begin                                                                53160000
    mpe'four := true;                                                   53165000
    pcb'size := %20;                                                    53170000
    pcb'lw := 15;                                                       53175000
   end;                                                                 53180000
                                                                        53185000
bitmap := "  ";  move bitmap(1) := bitmap, (255);                       53190000
                                                                        53195000
if mpe'five then           << mpeve + new microcode >>                  53200000
  begin                                                                 53205000
    tos := address;                                                     53210000
    bank'nr := tos.(11:5);  << extract bank'nr; bits 11:5 of ... >>     53215000
    del;                    << ... second word of address        >>     53220000
    tos := address;                                                     53225000
    tos.(11:5) := 0;        << zero out bank'bits --> make rel ... >>   53230000
                            << ... bank address        >>               53235000
    s1 := bank'nr;        << store bank'nr in s-1; i.e. in first ...>>  53240000
    address := tos;        << ... word of address as reqired by ... >>  53245000
  end;                      << ... procedure getcore        >>          53250000
                                                                        53255000
                                                                        53260000
pcb'fwa := address+%1000d; << add %1000 to sysglob rel pcb base >>      53265000
getcore(pcb'fwa,pcb'size,pcbentry);                                     53270000
if = then                                                               53275000
          maxpin := pcbentry(0)                                         53280000
else                                                                    53285000
     return;                                                            53290000
                                                                        53295000
c'pcb'ptr := double(core(4d)); << get cpcbptr out of low mem loc 4 >>   53300000
    << for mpe5: cpcb ptr is pcb base relative >>                       53305000
if mpe'five then adr'offset := c'pcb'ptr                                53310000
  else                                                                  53315000
    adr'offset := c'pcb'ptr - pcb'fwa;                                  53320000
         << get offset between pcb base & current pcb; mpe4 only >>     53325000
adr'offset := (adr'offset)/double(pcb'size); << calculate >>            53330000
tos := adr'offset;                      << ... current ... >>           53335000
c'pin := tos;                           << ... pin# >>                  53340000
del;                                                                    53345000
                                                                        53350000
pin := 1;                                                               53355000
f := b := -1;                                                           53360000
branch := brother  := show'father := false;                             53365000
top'pin := pin;                                                         53370000
line;                                                                   53375000
                                                                        53380000
nextpin:          << loop for next pin# >>                              53385000
                                                                        53390000
  if ctrly then begin                                         <<850830>>53395000
    write'rec(outfile,lbuf,0,0);                              <<850830>>53400000
    move buf:=" <CONTROL-Y>";                                 <<850830>>53405000
    write'rec(outfile,lbuf,-12,%60);                          <<850830>>53410000
    return;                                                   <<850830>>53415000
  end;                                                        <<850830>>53420000
                                                              <<850830>>53425000
  if mpe'five then                                                      53430000
    begin                                                               53435000
     tos := pcb'fwa; << prepare pcb'fwa for passing to getcore ... >>   53440000
     s1 := bank'nr;  << ... i.e.: (bank'nr,address)             >>      53445000
     pcb'fwa := tos;                                                    53450000
    end;                                                                53455000
                                                                        53460000
     address := pcb'fwa + double(logical(pin) * logical(pcb'size));     53465000
         while pin <= maxpin and not stop'print  do                     53470000
         begin      << while >>                                         53475000
         pcbentry := "  "; move pcbentry(1):=pcbentry,(20);   <<850916>>53480000
         getcore(address,pcb'size,pcbentry);                            53485000
         if = then                                                      53490000
         begin   << if = >>                                             53495000
                                                                        53500000
         if mpe'four then getmpe4 else  getmpe5;                        53505000
                                                                        53510000
         if not branch then << check for son entry >>                   53515000
                                                                        53520000
               if pcbentry(9).(6:3) =1  or                              53525000
                  pcbentry(9).(6:3) =0  then                            53530000
                           begin  pin := pin +1; go nextpin; end;       53535000
                                                                        53540000
          << branch = true >>                                           53545000
                                                                        53550000
          bitmapword := pin;                                            53555000
          if b'bitmap(bitmapword) = 1 then                              53560000
            << entry already referenced >>                              53565000
            begin          << referenced >>                             53570000
             if branch then                                             53575000
              begin                                                     53580000
               pin := top'pin(f);                                       53585000
                    << get last top pin of (sub-)tree >>                53590000
               f := f-1;                                                53595000
               if f < 0  then branch := false;                          53600000
               go nextpin;                                              53605000
              end;                                                      53610000
                                                                        53615000
        << not branch >>                                                53620000
                                                                        53625000
             pin := pin + 1;                                            53630000
             go nextpin;                                                53635000
            end;    << referenced >>                                    53640000
                                                                        53645000
                                                                        53650000
             << bitmap(bitmapword) = 0; not referenced yet >>           53655000
                                                                        53660000
             move b'bitmap(bitmapword) := 1;                            53665000
             if pcbentry(pcb'lw) = %177777 or   << free entry >>        53670000
                pcbentry(3).(1:10) = 0  then                            53675000
                 begin pin := pin + 1; go nextpin; end;                 53680000
                                                                        53685000
             << a valid entry was found >>                              53690000
             << format the entry        >>                              53695000
                                                                        53700000
                 fmt'pcb'info;                                          53705000
                                                                        53710000
                                                                        53715000
                 if pcbentry(9).(6:3) = 0 then  << user type >>         53720000
                    if brother'info <> 0 then  << brother exists >>     53725000
                       begin                                            53730000
                        b := b+1;                                       53735000
                        bro'pin(b) := brother'info;                     53740000
                        father'pin(b) := father'info;                   53745000
                        brother := true;                                53750000
                       end;                                             53755000
                                                                        53760000
                 << now check if a son pin exists >>                    53765000
                                                                        53770000
                 if son'info <> 0 then  << son exists >>                53775000
                   begin           << son >>                            53780000
                     if branch = true  and brother = true then          53785000
                     begin                                              53790000
                        f := f+1;                                       53795000
                        top'pin(f) := pin;                              53800000
                          << save current pin as father pin >>          53805000
                     end;                                               53810000
                     if branch = false then                             53815000
                        << the first son in family tree was found >>    53820000
                        << save father pin >>                           53825000
                       begin                                            53830000
                         f := f+1;                                      53835000
                         top'pin(f) := pin;                             53840000
                         branch := true;                                53845000
                       end;                                             53850000
                     pin := son'info;                                   53855000
                                << new pin := son pin >>                53860000
                     go nextpin;                                        53865000
                   end        << son >>                                 53870000
                                                                        53875000
               else    << no son pin exists >>                          53880000
                                                                        53885000
                   begin      << no son >>                              53890000
                     if brother then                                    53895000
                        begin          << brother >>                    53900000
                         pin := bro'pin(b);  << restore last brother >> 53905000
                         f'pin := father'pin(b);                        53910000
                         b := b-1;                                      53915000
                         if b < 0 then brother := false;                53920000
                         line;                                          53925000
                         show'father := true;                           53930000
                         go nextpin;                                    53935000
                        end         << brother >>                       53940000
                                                                        53945000
                     else                                               53950000
                                                                        53955000
                      if branch then                                    53960000
                        begin                                           53965000
                          pin := top'pin(f);                            53970000
                           << restore last father pin >>                53975000
                          f := f-1;                                     53980000
                          if f < 0 then branch := false;                53985000
                           << get out of family tree >>                 53990000
                          line;                                         53995000
                          go nextpin;                                   54000000
                        end;                                            54005000
                      << branch = brother =false >>                     54010000
                     pin := pin +1;     << increment pin >>             54015000
                     line;                                              54020000
                     go nextpin;                                        54025000
                   end;       << no son >>                              54030000
         end  << if = >>                                                54035000
                                                                        54040000
         else     << ccg or ccl >>                                      54045000
              return;                                                   54050000
                                                                        54055000
         end;  << while >>                                              54060000
     end; <<proctree>>                                                  54065000
$page   "EXECUTE'MPE'COMMAND"                                           54070000
<<*************************************************************>>       54075000
<< procedure  execute'mpe'command                              >>       54080000
<<------------------------------------------------------------->>       54085000
<< execute mpe command (no udc's)                              >>       54090000
<< any error code returned by the command intrinsic is passed  >>       54095000
<< to genmessage to output the propper cierr to the terminal   >>       54100000
<<*************************************************************>>       54105000
                                                                        54110000
procedure execute'mpe'command(mpe'command'image);                       54115000
                                                                        54120000
byte array mpe'command'image;                                           54125000
                                                                        54130000
<<************************************************************>>        54135000
<< input:                                                     >>        54140000
<< mpe'command'image  byte pointer to the beginning of the    >>        54145000
<<                    mpe command string, which is terminated >>        54150000
<<                    by an cr character                      >>        54155000
<< output:                                                    >>        54160000
<< if no error        mpes output of the command, normaly to  >>        54165000
<<                    the terminal                            >>        54170000
<< if not existing                                            >>        54175000
<<    command         "*** UNDEFINED MPE COMMAND ***"         >>        54180000
<<                    printerror # 44                         >>        54185000
<< if mpe generates                                           >>        54190000
<<    an error        the error is output to the terminal     >>        54195000
<<                    using the genmessage intrinsic          >>        54200000
<<------------------------------------------------------------>>        54205000
<< this procedure requires the existence of printerror        >>        54210000
<<************************************************************>>        54215000
                                                                        54220000
begin                                                                   54225000
  equate undefined = 69, << errorcode for procedure printerror >>       54230000
         cierr     = 2;  << message set # for cierr in mpes catalog>>   54235000
  integer error,parm,mpe'catalog;                                       54240000
  intrinsic command,genmessage;                                         54245000
  byte array message'catalog(0:23);                                     54250000
                                                                        54255000
  command(mpe'command'image,error,parm);                                54260000
  if <> then if < then                                                  54265000
                    printerror(undefined) <<undefined mpe command>>     54270000
                  else                                                  54275000
                    begin                                               54280000
                    move message'catalog := "CATALOG.PUB.SYS ";         54285000
                    mpe'catalog := fopen(message'catalog,%5,%420);      54290000
                    if < then printerror(undefined);                    54295000
                    genmessage(mpe'catalog,cierr,error);                54300000
                    if <> then printerror(undefined);                   54305000
                    fclose(mpe'catalog,0,0);                            54310000
                    end;                                                54315000
end;                                                                    54320000
$page"                       PROCEDURE SNAPSHOT"               <<*nth*>>54325000
$control segment=idat4                                                  54330000
logical procedure snapshot(location,length);                   <<*nth*>>54335000
    value location,length;                                     <<*nth*>>54340000
    double location;                                           <<*nth*>>54345000
    integer length;                                            <<*nth*>>54350000
  <<procedure snapshot takes a picture of the ioq or the drq,>><<*nth*>>54355000
  <<stores it in a data seg to be recalled later for display>> <<*nth*>>54360000
  <<location contains the location of the table to access.>>   <<*nth*>>54365000
  <<length passes the size of the data segment. snapshot>>     <<*nth*>>54370000
  <<returns the extra data segment number. >>                  <<*nth*>>54375000
    begin                                                      <<*nth*>>54380000
      equate max'xds'size'adr = %1111;                         <<*nth*>>54385000
      equate mstartptr = %1034;                                <<*nth*>>54390000
      logical array dummybuf(0:15);                            <<*nth*>>54395000
      logical max'xds'size,dstno,resident:=false;              <<*nth*>>54400000
      max'xds'size := absolute(max'xds'size'adr);              <<*nth*>>54405000
      absolute(max'xds'size'adr) := length + 128;              <<*nth*>>54410000
      snapshot := dstno := getdataseg(length,0);               <<*nth*>>54415000
      if < then write'rec(outfile,lbuf,10,0);                           54420000
      absolute(max'xds'size'adr) := max'xds'size;              <<*nth*>>54425000
      while not resident do                                    <<*nth*>>54430000
        begin                                                  <<*nth*>>54435000
        tos := @dummybuf;                                      <<*nth*>>54440000
        tos := dstno;  <<data segment of table specified>>     <<*nth*>>54445000
        tos := 0;   << offset >>                               <<*nth*>>54450000
        tos := 2;                                              <<*nth*>>54455000
        assemble(mfds 4);                                      <<*nth*>>54460000
        disable;                                               <<*nth*>>54465000
        if absolute(dstno*4 +absolute(2) ).(0:1)=1             <<*nth*>>54470000
          then enable                                          <<*nth*>>54475000
          else                                                 <<*nth*>>54480000
            begin                                              <<*nth*>>54485000
            tos := absolute(dstno*4 + absolute(2) + 2);        <<*nth*>>54490000
            tos := absolute(dstno*4 + absolute(2) + 3);        <<*nth*>>54495000
            tos := location;                                   <<*nth*>>54500000
            tos := length;                                     <<*nth*>>54505000
            assemble(mabs 5);                                  <<*nth*>>54510000
            resident := true;                                  <<*nth*>>54515000
            mstart:=core( mstartptr d );                       <<*nth*>>54520000
                                                               <<*nth*>>54525000
            enable;                                            <<*nth*>>54530000
            end; << else >>                                    <<*nth*>>54535000
        end;  << while >>                                      <<*nth*>>54540000
                                                               <<*nth*>>54545000
    end;   << snapshot >>                                      <<*nth*>>54550000
                                                               <<*nth*>>54555000
$page"                          PROCEDURE FMTMON"                       54560000
$control segment=format                                                 54565000
procedure fmtmon(prntfile);                                             54570000
  value prntfile;                                                       54575000
  integer prntfile;                                                     54580000
  begin                                                                 54585000
      logical cystopped;                                                54590000
    double monptr:=%1017d,locmon,cloc,endmon,stmon:=%1260d;             54595000
      logical  msize;                                                   54600000
      logical work1,work2,mfdsword,mondst;                              54605000
   equate measinfotabptr = %1261;                                       54610000
                                                                        54615000
logical subroutine mon(coreloc);                                        54620000
  value coreloc;                                                        54625000
  double coreloc;                                                       54630000
    begin                                                               54635000
    tos := logical(coreloc-locmon);                                     54640000
    tos := 1;   << move count >>                                        54645000
    tos := @mfdsword;                                                   54650000
    tos := mondst;                                                      54655000
    assemble( dxch );  << switch segment offset and length>>            54660000
                       <<with previous two words >>                     54665000
    assemble(mfds4);                                                    54670000
    mon := mfdsword;                                                    54675000
    end;                                                                54680000
                                                                        54685000
                                                                        54690000
subroutine event(enumb);                                                54695000
  value enumb;                                                          54700000
  integer enumb;                                                        54705000
  begin                                                                 54710000
         if enumb=0    then move pbuf:="QONSEG"                         54715000
    else if enumb=1    then move pbuf:="MAKEOC"                         54720000
    else if enumb=2    then move pbuf:="SPECIALRQ"                      54725000
    else if enumb=4    then move pbuf:="FETCHSEG"                       54730000
    else if enumb=5    then move pbuf:="SEGIO"                <<851231>>54735000
    else if enumb=6    then move pbuf:="SIODONE"                        54740000
    else if enumb=7    then move pbuf:="CGARBAGE"                       54745000
    else if enumb=8    then move pbuf:="SWAPIN"                         54750000
    else if enumb=12   then move pbuf:="ALLOCMEM"                       54755000
    else if enumb=13   then move pbuf:="DEALLOCM"                       54760000
    else if enumb=14   then move pbuf:="CACHEMOV"                       54765000
    else if enumb=15   then move pbuf:="GET_CDT"                        54770000
    else if enumb=16   then move pbuf:="QUE_LDR"              <<851231>>54775000
    else if enumb=17   then move pbuf:="DQUE_LDR"                       54780000
    else if enumb=18   then move pbuf:="FIND_DE"                        54785000
    else if enumb=19   then move pbuf:="LOCKRANG"                       54790000
    else if enumb=20   then move pbuf:="ALCSTBLK"                       54795000
    else if enumb=21   then move pbuf:="DEALCSTBLK"                     54800000
    else if enumb=23   then move pbuf:="RELRESOURCES"                   54805000
    else if enumb=24   then move pbuf:="EXCHDB"                         54810000
    else if enumb=40   then move pbuf:="QUIESCE"                        54815000
    else if enumb=60   then move pbuf:="FOPEN"                          54820000
    else if enumb=61   then move pbuf:="FOPEN'"                         54825000
    else if enumb=62   then move pbuf:="FREAD"                          54830000
    else if enumb=63   then move pbuf:="FWRITE"                         54835000
    else if enumb=64   then move pbuf:="FREADDIR"                       54840000
    else if enumb=65   then move pbuf:="FWRITEDIR"                      54845000
    else if enumb=66   then move pbuf:="FUPDATE"                        54850000
    else if enumb=67   then move pbuf:="IOWAIT"                         54855000
    else if enumb=68   then move pbuf:="FREADSEEK"                      54860000
    else if enumb=69   then move pbuf:="FSPACE"                         54865000
    else if enumb=70   then move pbuf:="FPOINT"               <<851231>>54870000
    else if enumb=71   then move pbuf:="FCONTROL"                       54875000
    else if enumb=72   then move pbuf:="FSETMODE"                       54880000
    else if enumb=74   then move pbuf:="FCHECK"                         54885000
    else if enumb=75   then move pbuf:="FGETINFO"                       54890000
    else if enumb=76   then move pbuf:="FREADLABEL"                     54895000
    else if enumb=77   then move pbuf:="FWRITELABEL"                    54900000
    else if enumb=78   then move pbuf:="FLOCK"                          54905000
    else if enumb=79   then move pbuf:="FUNLOCK"                        54910000
    else if enumb=80   then move pbuf:="FRENAME"                        54915000
    else if enumb=81   then move pbuf:="FCLOSE"                         54920000
    else if enumb=82   then move pbuf:="AWAKEDEV"                       54925000
    else if enumb=83   then move pbuf:="STRATEGY"                       54930000
    else if enumb=84   then move pbuf:="INITIATE"                       54935000
    else if enumb=86   then move pbuf:="CDT_ATT"              <<851231>>54940000
    else if enumb=87   then move pbuf:="MAP_DOM"                        54945000
    else if enumb=88   then move pbuf:="UN_MAP_RG"                      54950000
    else if enumb=89   then move pbuf:="LINK_REG"                       54955000
    else if enumb=90   then move pbuf:="REQCACHE"                       54960000
    else if enumb=98   then move pbuf:="DISK TRAFFIC"                   54965000
    else if enumb=100  then move pbuf:="DISK ERROR"                     54970000
    else if enumb=101  then move pbuf:="DISKERROR"                      54975000
    else if enumb=110  then move pbuf:="START I/O"                      54980000
    else if enumb=111  then move pbuf:="I/O COMPLETION"                 54985000
    else if enumb=120  then move pbuf:="SOFT'DEATH"                     54990000
    else if enumb=125  then move pbuf:="IOBUFTRP"             <<851231>>54995000
    else if enumb=130  then move pbuf:="ATTACHIO"                       55000000
    else if enumb=132  then move pbuf:="ATTACHIO"                       55005000
    else if enumb=139  then move pbuf:="C_ABSENT"                       55010000
    else if enumb=140  then move pbuf:="COPEN"                          55015000
    else if enumb=142  then move pbuf:="CABORTIO"                       55020000
    else if enumb=144  then move pbuf:="CSIOWAIT"                       55025000
    else if enumb=146  then move pbuf:="CCLOSE"                         55030000
    else if enumb=147  then move pbuf:="CREAD"                          55035000
    else if enumb=149  then move pbuf:="CWRITE"                         55040000
    else if enumb=150  then move pbuf:="CSDRIVER"                       55045000
    else if enumb=152  then move pbuf:="CCONTROL"                       55050000
    else if enumb=153  then move pbuf:="COPENTRACEFILE"                 55055000
    else if enumb=154  then move pbuf:="CCLOSETRACEFILE"                55060000
    else if enumb=155  then move pbuf:="CPOLLIST"                       55065000
    else if enumb=160  then move pbuf:="CREAD"                          55070000
    else if enumb=191  then move pbuf:="DISKINTRPT"                     55075000
    else if enumb=192  then move pbuf:="GIPINTERUPT"                    55080000
    else if enumb=193  then move pbuf:="STARTIO"                        55085000
    else if enumb=194  then move pbuf:="SIODM-ENTRY"                    55090000
    else if enumb=195  then move pbuf:="SIODM-EXIT"                     55095000
    else if enumb=200  then move pbuf:="DISKBUGCATCHER"                 55100000
    else if enumb=201  then move pbuf:="DISKBUGCATCHER"                 55105000
    else if enumb=211  then move pbuf:="PROC COMPLETION"                55110000
    else if enumb=221  then move pbuf:="CONFIG INFO"                    55115000
    else if enumb=222  then move pbuf:="CONFIG INFO"                    55120000
    else if enumb=223  then move pbuf:="CONFIG-INFO"                    55125000
    else if enumb=224  then move pbuf:="SYSPINS"                        55130000
    else if enumb=225  then move pbuf:="SYSPINS"                        55135000
    else if enumb=226  then move pbuf:="SYSPINS"                        55140000
    else if enumb=227  then move pbuf:="SYSPINS"                        55145000
    else if enumb=228  then move pbuf:="TIMESTAMP"            <<851231>>55150000
    else if enumb=228  then move pbuf:="MONOFF"                         55155000
    else if enumb=230  then move pbuf:="TERMREAD"                       55160000
    else if enumb=231  then move pbuf:="DC1DC2ACK"                      55165000
    else if enumb=232  then move pbuf:="TERMWRITE"                      55170000
    else if enumb=233  then move pbuf:="BINREAD"                        55175000
    else if enumb=234  then move pbuf:="TERMLOGON"                      55180000
    else if enumb=235  then move pbuf:="TERMLOGOFF"                     55185000
    else if enumb=236  then move pbuf:="SPECCHAR"                       55190000
    else if enumb=237  then move pbuf:="BREAK"                          55195000
    else if enumb=238  then move pbuf:="SPECREAD"                       55200000
    else if enumb=240  then move pbuf:="PFAIL"                          55205000
    else if enumb=-211 then move pbuf:="TERMIN"                         55210000
    else if enumb=-240 then move pbuf:="CAUSE"                          55215000
    else if enumb=-241 then move pbuf:="PROCESS"                        55220000
    else if enumb=-242 then move pbuf:="BUILD MKR"                      55225000
    else if enumb=-243 then move pbuf:="CHANGE ST"                      55230000
    else if enumb=-244 then move pbuf:="TIMEOUT"                        55235000
    else                                                                55240000
pnumb:                                                                  55245000
        if pbuf="  " then                                               55250000
         begin        <<put out number only>>                           55255000
          putnump(enumb);   <<event number>>                            55260000
          @pbuf:=@pbuf-7;   <<back off pointer>>                        55265000
         end;         <<put out number only>>                           55270000
 end;  <<event subroutine>>                                             55275000
                                                                        55280000
                                                                        55285000
subroutine fmtmon'dump;                                                 55290000
                                                                        55295000
begin                                                                   55300000
  mstart:=core(%1034 d);                                                55305000
  cloc:=double(mstart)+locmon;                                          55310000
  cloc := cloc-8d;  <<curr pointer is last entry+1>>                    55315000
  if cloc < locmon then cloc:=endmon-8d;  <<wrap around>>               55320000
  if cloc < 1d then go bailout;                                         55325000
  cystopped := false;                                                   55330000
  ctrly := false;                                                       55335000
  while msize > 8 and not stop'print do                                 55340000
  begin                                                                 55345000
    if ctrly then begin                                       <<850916>>55350000
      move buf:=" <CONTROL-Y>";                               <<850916>>55355000
      write'rec(outfile,lbuf,0,0);  << blank line >>          <<850916>>55360000
      write'rec(outfile,lbuf,-12,0);                          <<850916>>55365000
      go bailout;                                             <<850916>>55370000
    end;                                                      <<850916>>55375000
    @pbuf:=@buf;         <<beginning of line>>                          55380000
    putdnump(cloc);      <<location of memory pointer>>                 55385000
    @pbuf:=@buf+5;       <<space over memory address>>                  55390000
    work2:=0;            <<column counter>>                             55395000
    while msize > 0 land work2 < 1 do                                   55400000
      begin              <<while room across page>>                     55405000
      @pbuf:=@pbuf+1;    <<over previous event>>                        55410000
      work1:=core(cloc)/21;  <<pick up pin index>>                      55415000
      putnump(work1); <<pin>>                                           55420000
      work1:=core(cloc+1d);  << event >>                                55425000
      event(work1);   <<event>>                                         55430000
      @pbuf:=@pbuf+16;       <<skip over event>>                        55435000
      putnum(core(cloc+2d)); <<word 1>>                                 55440000
      putnum(core(cloc+3d)); <<word 2>>                                 55445000
      putnum(core(cloc+4d)); <<word 3>>                                 55450000
      putnum(core(cloc+5d)); <<word 4>>                                 55455000
      putnum(core(cloc+6d)); <<word 5>>                                 55460000
      putnum(core(cloc+7d)); <<word 6>>                                 55465000
      cloc:=cloc-8d;         <<next location>>                          55470000
      if cloc < locmon                                                  55475000
        then cloc:=endmon-8d;  << table wraps around >>                 55480000
      msize:=msize-8;        <<four fewer words left>>                  55485000
      work2:=work2+1;        <<count columns done>>                     55490000
      end;               <<done across page>>                           55495000
    printline(prntfile); <<print formatted line>>                       55500000
  end;                                                                  55505000
bailout:                                                                55510000
ctrly := false;                                                         55515000
end;  <<  subroutine fmtmon'dump  >>                                    55520000
                                                                        55525000
                                                                        55530000
subroutine fmtmon'live;                                                 55535000
                                                                        55540000
begin                                                                   55545000
  mondst := snapshot(locmon,msize);                                     55550000
   << mstart is set in snapshot while disabled >>                       55555000
  if (mstart:=mstart-8)<8 then mstart:=core(locmon-1d)-8;               55560000
  if mstart>(msize-8) then go bailout;                                  55565000
  cloc:=double(mstart)+locmon;                                          55570000
  if cloc < 1d then go bailout;                                         55575000
  cystopped := false;                                                   55580000
  ctrly := false;                                                       55585000
  while (msize > 8) and not stop'print do                               55590000
  begin                                                                 55595000
    if ctrly then begin                                       <<850916>>55600000
      move buf:=" <CONTROL-Y>";                               <<850916>>55605000
      write'rec(outfile,lbuf,0,0);  << blank line >>          <<850916>>55610000
      write'rec(outfile,lbuf,-12,0);                          <<850916>>55615000
      go bailout;                                             <<850916>>55620000
    end;                                                      <<850916>>55625000
    @pbuf:=@buf;         <<beginning of line>>                          55630000
    putdnump(cloc);      <<location of memory pointer>>                 55635000
    @pbuf:=@buf+5;       <<space over memory address>>                  55640000
    work2:=0;            <<column counter>>                             55645000
    while msize > 0 land work2 < 1 do                                   55650000
      begin              <<while room across page>>                     55655000
      @pbuf:=@pbuf+1;    <<over previous event>>                        55660000
      putnump(mon(cloc)/21);  <<pick up pin>>                           55665000
      event(mon(cloc+1d));    <<event>>                                 55670000
      @pbuf:=@pbuf+16;        <<skip over event>>                       55675000
      putnum(mon(cloc+2d)); <<word 1>>                                  55680000
      putnum(mon(cloc+3d)); <<word 2>>                                  55685000
      putnum(mon(cloc+4d)); <<word 3>>                                  55690000
      putnum(mon(cloc+5d)); <<word 4>>                                  55695000
      putnum(mon(cloc+6d)); <<word 5>>                                  55700000
      putnum(mon(cloc+7d)); <<word 6>>                                  55705000
      cloc:=cloc-8d;          <<next location>>                         55710000
      if cloc < locmon                                                  55715000
        then cloc:=endmon-8d; << table wraps around >>                  55720000
      msize:=msize-8;       <<four fewer words left>>                   55725000
      work2:=work2+1;       <<count columns done>>                      55730000
      end;                <<done across page>>                          55735000
    printline(prntfile);                                                55740000
  end;                                                                  55745000
bailout:                                                                55750000
ctrly := false;                                                         55755000
if mondst <> 0 then reldataseg(mondst);                                 55760000
end;  <<  subroutine fmtmon'live  >>                                    55765000
                                                                        55770000
                                                                        55775000
                                                                        55780000
blankbuf;                                                               55785000
if mpeversion = 4 then printerror(64)                                   55790000
else                                                                    55795000
  begin                                                                 55800000
  move lbuf(8):="******    MONITOR TABLE    ******";                    55805000
  printline(prntfile);                                                  55810000
  move lbuf:="LOC    PIN   EVENT";                                      55815000
  printline(prntfile);                                                  55820000
  work1 := core(%1011d);                                                55825000
  tos := work1 land %37;                                                55830000
  tos := (work1 land %177740) + %1000; << offset in bank >>             55835000
  locmon := tos;                                                        55840000
  msize:=core(locmon-1d);                                               55845000
  if msize < 8 then msize:=%2000;                                       55850000
  if msize > 8192 then msize:=%2000;                                    55855000
  endmon:=locmon+double(msize);                                         55860000
                                                                        55865000
  if live'sys then fmtmon'live                                          55870000
  else fmtmon'dump;                                                     55875000
  end;                                                                  55880000
                                                                        55885000
end; <<fmtmon>>                                                         55890000
$page "                     PROCEDURE ISFREE "                          55895000
$control segment=idat4                                                  55900000
<<***********************************************************>>         55905000
<< isfree                                                    >>         55910000
<<----------------------------------------------------------->>         55915000
<< this procedure is a function that receives as an argument >>         55920000
<< a pcb entry number and returns true if the pcb entry is   >>         55925000
<< free, otherwise it returns false.                         >>         55930000
<<***********************************************************>>         55935000
                                                                        55940000
logical procedure isfree(pcb'entry);                                    55945000
   value pcb'entry;                                                     55950000
   integer pcb'entry;                                                   55955000
                                                                        55960000
   begin                                                                55965000
     integer pcbfree,pcb'ent'size,offset;                        <<nsf>>55970000
     double pcbaddr;                                             <<nsf>>55975000
                                                                 <<nsf>>55980000
     pcb'ent'size:=%20+(mpeversion-4)*5;                         <<nsf>>55985000
     offset:=15+(mpeversion-4)*6;                                <<nsf>>55990000
     pcbaddr:=getdstaddr(3);                                     <<nsf>>55995000
     isfree:=false;                                                     56000000
     pcbaddr:=pcbaddr+double(pcb'entry*pcb'ent'size+offset);     <<nsf>>56005000
     pcbfree:=core(pcbaddr);                                     <<nsf>>56010000
     if pcbfree=%177777 then isfree:=true;                       <<nsf>>56015000
   end;                                                                 56020000
                                                                        56025000
$page "                     PROCEDURE COMPUTE"                          56030000
<<***********************************************************>>         56035000
<< compute                                                   >>         56040000
<<----------------------------------------------------------->>         56045000
<< parse and execute the compute command                    >>          56050000
<<***********************************************************>>         56055000
procedure compute(parmstring);                                          56060000
  byte array parmstring;                                                56065000
begin                                                                   56070000
                                                                        56075000
  << this rocedure assumes the existence of the >>                      56080000
  << global variable "OUTFILE" as well as the   >>                      56085000
  << following procedures:                      >>                      56090000
  <<        printerror         expreval         >>                      56095000
  <<        parsemode          putchar          >>                      56100000
                                                                        56105000
                                                                        56110000
equate  maxparms = 5;                                                   56115000
                                                                        56120000
define  length = infoword.(0:8)#;                                       56125000
                                                                        56130000
                                                                        56135000
logical  exprvalue,  <<value of input expression>>                      56140000
          infoword;  <<word returned by mycommand>>                     56145000
integer   dispmode,  <<display mode requested>>                         56150000
                 n,  <<# chars to print>>                               56155000
          numparms;  <<number of parameters>>                           56160000
                                                                        56165000
logical array lbuf(0:39);  <<output buffer>>                            56170000
byte array buf(*)=lbuf;                                                 56175000
                                                                        56180000
double array  parms(0:maxparms);                                        56185000
                                                                        56190000
byte array  delimiters(0:1),                                            56195000
               tempbuf(0:9);                                            56200000
                                                                        56205000
byte pointer  string;                                                   56210000
                                                                        56215000
<<parse string to get expression and display mode>>                     56220000
delimiters(0):=",";                                                     56225000
delimiters(1):=cr;                                                      56230000
mycommand(parmstring,delimiters,maxparms,numparms,parms);               56235000
if <> then begin                                                        56240000
  printerror(0);                                                        56245000
  return; end;                                                          56250000
                                                                        56255000
if not (0 <= numparms <= 2) then begin                                  56260000
  printerror(7);                                                        56265000
  return; end;                                                          56270000
                                                                        56275000
<<have correct number of parameters>>                                   56280000
exprvalue:=0;    <<default value>>                                     56285000
dispmode:=0;     <<octal>>                                              56290000
if numparms >= 1 then begin                                             56295000
  tos:=parms(0);                                                        56300000
  infoword:=tos;                                                        56305000
  @string:=tos;                                                         56310000
                                                                        56315000
  if length > 0 then begin                                              56320000
    string(length):=cr;                                                 56325000
    exprvalue:=expreval(string);                                        56330000
    if <> then begin                                                    56335000
      printerror(19);                                                   56340000
      return; end; end;                                                 56345000
                                                                        56350000
  if numparms >= 2 then begin                                           56355000
    dispmode:=parsemode(parms(1));                                      56360000
    if <> then begin                                                    56365000
      printerror(1);                                                    56370000
      return; end; end; end;                                            56375000
                                                                        56380000
<<have valid expression and mode>>                                      56385000
buf:=" ";                                                               56390000
move buf(1):=buf,(79);  <<blank out the buffer>>                        56395000
                                                                        56400000
case dispmode of begin                                                  56405000
                                                                        56410000
   <<octal>>  begin                                                     56415000
              n:=ascii(exprvalue,8,tempbuf);                            56420000
              move buf:=tempbuf(6-n),(n); end;                          56425000
 <<integer>>  n:=ascii(exprvalue,10,buf);                               56430000
   <<ascii>>  begin                                                     56435000
              putchar(exprvalue.(0:8),buf);                             56440000
              putchar(exprvalue.(8:8),buf(1));                          56445000
              n:=2; end;                                                56450000
                                                                        56455000
end;  <<case>>                                                          56460000
                                                                        56465000
write'rec(outfile,lbuf,-n,0);                                           56470000
                                                                        56475000
end;  <<compute>>                                                       56480000
$page"                PROCEDURE USEFILE"                                56485000
$control segment=idat5                                                  56490000
<<**************************************************>>           <<nsf>>56495000
<<  usefile                                         >>           <<nsf>>56500000
<<-------------------------------------------------->>           <<nsf>>56505000
<< link in load map file for use in formatting the  >>           <<nsf>>56510000
<< stacks.                                          >>           <<nsf>>56515000
<<**************************************************>>           <<nsf>>56520000
                                                                 <<nsf>>56525000
integer procedure usefile(parmstring);                           <<nsf>>56530000
  byte array parmstring;                                         <<nsf>>56535000
                                                                 <<nsf>>56540000
begin                                                            <<nsf>>56545000
                                                                 <<nsf>>56550000
equate maxparms=1;                                               <<nsf>>56555000
define cc = status.(6:2)#,                                       <<nsf>>56560000
   length = infoword.(0:8)#;                                     <<nsf>>56565000
                                                                 <<nsf>>56570000
logical infoword;                                                <<nsf>>56575000
double array parms(0:maxparms);                                  <<nsf>>56580000
byte array delimiters(0:3),discfilename(0:29),ldname(0:7);       <<nsf>>56585000
integer numparms,n,error,recsize,devtype,blksize,filecode,i,     <<nsf>>56590000
        addr,temp,scancnt;                                       <<nsf>>56595000
logical devtyp,hdaddr,status=q-1;                                <<nsf>>56600000
double eof,mpe'rec;                                                     56605000
logical array tmpbuf(0:63);                                             56610000
byte array btmp(*) = tmpbuf;                                            56615000
byte pointer string;                                                    56620000
cc:=cce;  <<assume no errors>>                                   <<nsf>>56625000
delimiters(0):=",";                                              <<nsf>>56630000
delimiters(1):=cr;                                               <<nsf>>56635000
                                                                 <<nsf>>56640000
if auto'file(loadmap) then                                              56645000
  begin                                                                 56650000
  printerror(79);                                                       56655000
  return;                                                               56660000
  end;                                                                  56665000
                                                                        56670000
mycommand(parmstring,delimiters,maxparms,numparms,parms);        <<nsf>>56675000
if <> then begin                                                 <<nsf>>56680000
  printerror(0);                                                 <<nsf>>56685000
  cc:=ccg;                                                       <<nsf>>56690000
  return; end;                                                   <<nsf>>56695000
                                                                 <<nsf>>56700000
if not (0 <= numparms <= maxparms) then begin                    <<nsf>>56705000
  printerror(7);                                                 <<nsf>>56710000
  cc:=ccl;                                                       <<nsf>>56715000
  return; end;                                                   <<nsf>>56720000
                                                                 <<nsf>>56725000
if numparms = 0 then return;  << nothing specified >>            <<nsf>>56730000
if ld'in'use then begin                                          <<nsf>>56735000
  printerror(55);                                                <<nsf>>56740000
  end;                                                           <<nsf>>56745000
                                                                 <<nsf>>56750000
if numparms = 1 then begin                                       <<nsf>>56755000
  if logical(parms(0)).(0:8) > 0 then begin                      <<nsf>>56760000
    tos:=parms(0);                                               <<nsf>>56765000
    infoword:=tos;                                               <<nsf>>56770000
    @string:=tos;                                                <<nsf>>56775000
    if length > 26 then begin                                    <<nsf>>56780000
      printerror(56);                                            <<nsf>>56785000
      return; end                                                <<nsf>>56790000
    else begin                                                   <<nsf>>56795000
      n:=length;                                                 <<nsf>>56800000
      move discfilename:=string,(n);                             <<nsf>>56805000
      discfilename(n):="#";                                      <<nsf>>56810000
    end;                                                         <<nsf>>56815000
  end;                                                           <<nsf>>56820000
                                                                 <<nsf>>56825000
  ldfile := fopen(discfilename,%7,%300);                                56830000
  if <> then begin                                               <<nsf>>56835000
    printerror(57);                                              <<nsf>>56840000
    return; end                                                  <<nsf>>56845000
  else begin                                                     <<nsf>>56850000
    fgetinfo(ldfile,,,,recsize,devtype,,,filecode,,eof,,,,              56855000
             blksize);                                           <<nsf>>56860000
                                                                        56865000
                                                                        56870000
                                                                        56875000
                                                                 <<nsf>>56880000
    if (recsize <> -128)    or                                   <<nsf>>56885000
       ((devtype.(8:8) <> 3) land (devtype.(8:8) <> 0))   or     <<nsf>>56890000
       (filecode <> 0)      or                                   <<nsf>>56895000
       (eof > 60d)          or                                   <<nsf>>56900000
       (blksize <> 2*recsize) then begin                         <<nsf>>56905000
         printerror(58);                                         <<nsf>>56910000
         return;                                                 <<nsf>>56915000
    end;                                                         <<nsf>>56920000
                                                                 <<nsf>>56925000
    freaddir(ldfile,tmpbuf,-20,2d);                                     56930000
    new'loadmap := not(btmp = " ");                                     56935000
    if new'loadmap then mpe'rec := 2d                                   56940000
    else mpe'rec := 4d;                                                 56945000
    freaddir(ldfile,tmpbuf,-20,mpe'rec);                                56950000
    if <> then                                                          56955000
      begin                                                             56960000
      printerror(60);                                                   56965000
      return;                                                           56970000
      end                                                               56975000
    else                                                                56980000
      begin                                                             56985000
      lbuf(2) := core(verno);     <<version id>>                        56990000
      lbuf    := core(upno);      <<update id >>                        56995000
      lbuf(1) := core(fno);       << fix id   >>                        57000000
      if btmp( 7) <> buf(4),(2) or                                      57005000
         btmp(10) <> buf   ,(2) or                                      57010000
         btmp(13) <> buf(2),(2) then                                    57015000
      begin                                                             57020000
      printerror(59);                                                   57025000
      return;                                                           57030000
      end;                                                              57035000
    end;                                                                57040000
                                                                 <<nsf>>57045000
  end;                                                           <<nsf>>57050000
  ld'in'use:=true;                                               <<nsf>>57055000
end;                                                             <<nsf>>57060000
                                                                 <<nsf>>57065000
end;  <<usefile>>                                                <<nsf>>57070000
$page"                 PROCEDURE CI"                                    57075000
$control segment=idat4                                                  57080000
<<***********************************************************>>         57085000
<< ci                                                        >>         57090000
<<----------------------------------------------------------->>         57095000
<< command interpreter for the program                       >>         57100000
<<***********************************************************>>         57105000
procedure ci;                                                           57110000
begin                                                                   57115000
                                                                        57120000
  << this procedure assumes the existence of the following >>           57125000
  << global variables:                                     >>           57130000
  <<                                                       >>           57135000
  <<     infile - input file number for $stdinx            >>           57140000
  <<      ctrly - flag indicating if control-y integer     >>           57145000
                                                                        57150000
  << we remain in this procedure until the user enters     >>           57155000
  << an exit command                                       >>           57160000
                                                                        57165000
  << this procedure assumes the existence of the >>                     57170000
  << global variable "COREF" as well as the      >>                     57175000
  << following procedures:                       >>                     57180000
  <<        printerror        parsedisplay       >>                     57185000
  <<        display           formatinfo         >>                     57190000
  <<        textfile          compute            >>                     57195000
  <<        help                                 >>                     57200000
                                                                        57205000
equate  maxparms = 2;                                            <<nsf>>57210000
                                                                        57215000
equate  <<indices for valid commands>>                                  57220000
     invalid'cmd =  0,                                                  57225000
        null'cmd =  1,                                                  57230000
        exit'cmd =  2,                                                  57235000
        disp'cmd =  3,                                                  57240000
        find'cmd =  4,                                         <<*nth*>>57245000
         fmt'cmd =  5,                                         <<*nth*>>57250000
        text'cmd =  6,                                         <<*nth*>>57255000
     compute'cmd =  7,                                         <<*nth*>>57260000
       debug'cmd =  8,                                         <<*nth*>>57265000
         set'cmd =  9,                                         <<*nth*>>57270000
        help'cmd = 10,                                         <<*nth*>>57275000
        live'cmd = 11,                                                  57280000
         out'cmd = 12,                                           <<nsf>>57285000
         mod'cmd = 13,                                           <<nsf>>57290000
         use'cmd = 14,                                           <<nsf>>57295000
       close'cmd = 15,                                                  57300000
     version'cmd = 16,                                                  57305000
         mpe'cmd = 17,                                                  57310000
        auto'cmd = 18;                                                  57315000
                                                                        57320000
define length = infoword.(0:8)#, length2 = infoword2.(0:8)#,     <<nsf>>57325000
           cc = status.(6:2)#;                                   <<nsf>>57330000
logical      done,  <<true: exit command entered>>                      57335000
         infoword,  <<used during auto'text processing>>         <<nsf>>57340000
        infoword2,  <<used during auto'text processing>>         <<nsf>>57345000
   match'suppress;  <<matching memory suppressed flag>>          <<nsf>>57350000
integer  dispmode,  <<display mode for d & p commands>>                 57355000
          command,  <<index of command specified>>                      57360000
                i,  <<loop variable>>                                   57365000
                n,                                                      57370000
            error, numparms,                                     <<nsf>>57375000
            dummy,                                                      57380000
          numchar;  <<number of characters input>>                      57385000
double  dispcount,  <<# words to display in d & p commands>>            57390000
        startaddr;  <<offset for d & p commands>>                       57395000
double array parms(0:maxparms);                                  <<nsf>>57400000
                                                                        57405000
byte pointer  cmdstart,  <<start of command>>                           57410000
                string,  <<start of loadmap file spec>>          <<nsf>>57415000
             parmstart;  <<start of command parameters>>                57420000
                                                                        57425000
byte array delimiters(0:1);                                      <<nsf>>57430000
logical array lbuf(0:99);                                      <<*nth*>>57435000
byte array buf(*)=lbuf;                                                 57440000
logical array tempbuf(0:99);                                            57445000
byte array btempbuf(*)=tempbuf;                                         57450000
                                                                        57455000
done:=false;                                                            57460000
                                                                        57465000
if auto'text then begin                                          <<nsf>>57470000
  numchar:=outchar;                                              <<nsf>>57475000
  move buf:=pbuf,(numchar);                                      <<nsf>>57480000
  buf(numchar):=cr;                                              <<nsf>>57485000
  @cmdstart:=@buf;                                               <<nsf>>57490000
  @parmstart:=@cmdstart(1);                                      <<nsf>>57495000
  delimiters(0):=",";  delimiters(1):=cr;                        <<nsf>>57500000
  mycommand(parmstart,delimiters,maxparms,numparms,parms);       <<nsf>>57505000
  if <> then begin                                               <<nsf>>57510000
    printerror(0);                                               <<nsf>>57515000
    done:=true;                                                  <<nsf>>57520000
    end;                                                         <<nsf>>57525000
  if not (0 <= numparms <= maxparms) then begin                  <<nsf>>57530000
    printerror(7);                                               <<nsf>>57535000
    done:=true; end;                                             <<nsf>>57540000
  if numparms <> 0 then begin                                    <<nsf>>57545000
    if numparms = 1 then begin                                   <<nsf>>57550000
      textfile(parmstart);                                       <<nsf>>57555000
      move buf:="DUMPFILE SPECIFIED= ";                          <<nsf>>57560000
      @pbuf:=@pbuf+1;                                            <<nsf>>57565000
      move buf(19):=pbuf,(numchar),2;                            <<nsf>>57570000
      outchar:=tos-@buf;                                         <<nsf>>57575000
      @pbuf:=@pbuf-1;                                            <<nsf>>57580000
      write'rec(outfile,lbuf,-outchar,0);                               57585000
      end                                                        <<nsf>>57590000
    else begin                                                   <<nsf>>57595000
      tos:=parms(1);                                             <<nsf>>57600000
      infoword:=tos;                                             <<nsf>>57605000
      @string:=tos;                                              <<nsf>>57610000
      tos:=parms(0);                                             <<nsf>>57615000
      infoword2:=tos;                                            <<nsf>>57620000
      @parmstart:=tos;                                           <<nsf>>57625000
      buf(length2+1):=cr;                                        <<nsf>>57630000
      textfile(parmstart);                                       <<nsf>>57635000
      move btempbuf:="DUMPFILE SPECIFIED= ";                     <<nsf>>57640000
      @pbuf:=@pbuf+1;                                            <<nsf>>57645000
      move btempbuf(19):=pbuf,(length2),2;                       <<nsf>>57650000
      @pbuf:=@pbuf-1;                                            <<nsf>>57655000
      write'rec(outfile,tempbuf,-(length2+19),0);                       57660000
      usefile(string);                                           <<nsf>>57665000
      move btempbuf:="LOADMAP SPECIFIED = ";                     <<nsf>>57670000
      move btempbuf(19):=string,(length),2;                      <<nsf>>57675000
      write'rec(outfile,tempbuf,-(length+19),0);                        57680000
    end;                                                         <<nsf>>57685000
    auto'text:=false;                                            <<nsf>>57690000
  end;                                                           <<nsf>>57695000
end;                                                             <<nsf>>57700000
                                                                 <<nsf>>57705000
while not done do begin  <<loop until exit command>>                    57710000
  ctrly:=false;                                                         57715000
  stop'print:=false;                                                    57720000
                                                                        57725000
                                                               << hks >>57730000
  screen'line := 1;  <<reset line counter for screen control>> << hks >>57735000
                                                                        57740000
  <<prompt user>>                                                       57745000
  buf:="-";                                                             57750000
  print(lbuf,-1,%320);                                                  57755000
                                                                        57760000
  <<read command>>                                                      57765000
  fcontrol(infile,16,dummy);   << disable control y >>                  57770000
  numchar:= fread(infile,lbuf,-200);                           <<*nth*>>57775000
  if <> then                                                            57780000
    <<end-of-file or i/o error>>                                        57785000
    return;                                                             57790000
  fcontrol(infile,17,dummy);   << disable control y >>                  57795000
                                                                        57800000
  if buf = ":" then buf(numchar) := cr                                  57805000
  else                                                                  57810000
    begin                                                               57815000
  << squeeze out the blanks.  >>                               << hks >>57820000
    outchar := 0;                                              << hks >>57825000
    for inchar := 0 until numchar-1 do                         << hks >>57830000
      begin                                                    << hks >>57835000
      if buf(inchar) <> " " then                               << hks >>57840000
        begin                                                  << hks >>57845000
        squeez(outchar) := buf(inchar);                        << hks >>57850000
        outchar := outchar + 1;                                << hks >>57855000
        end;                                                   << hks >>57860000
      end; << until do >>                                      << hks >>57865000
    if outchar > 0 then                                        << hks >>57870000
      begin                                                    << hks >>57875000
      move buf := squeez, (outchar);                           << hks >>57880000
      buf(outchar) := cr;                                      << hks >>57885000
      end;                                                              57890000
    numchar := outchar;                                        << hks >>57895000
    end;                                                                57900000
                                                               << hks >>57905000
  <<upshift 1st part of string - use of "MYCOMMAND">>                   57910000
  <<will upshift the remainder of the string       >>                   57915000
  move buf := buf while ans;                                 <<84326>>  57920000
                                                                        57925000
  if buf = "P" then                                                     57930000
    begin                                                               57935000
    move buf := buf(1), (numchar);                                      57940000
    numchar := numchar - 1;                                             57945000
    print'enabled := true;                                              57950000
    end                                                                 57955000
  else                                                                  57960000
    print'enabled := false;                                             57965000
                                                                        57970000
  <<determine command from first letter(s) of input>>          <<*nth*>>57975000
  @cmdstart:=@buf;                                                      57980000
  if numchar = 0 then                                                   57985000
    command:=null'cmd                                                   57990000
  else begin                                                            57995000
                                                                        58000000
    <<determine command type>>                                          58005000
    command:= if cmdstart = "E" then exit'cmd                           58010000
              else                                                      58015000
              if cmdstart = "D" then disp'cmd                           58020000
              else                                             <<*nth*>>58025000
              if cmdstart = "FIND" then find'cmd               <<*nth*>>58030000
              else                                                      58035000
              if cmdstart = "F" then fmt'cmd                            58040000
              else                                                      58045000
              if cmdstart = "=" then compute'cmd                        58050000
              else                                                      58055000
              if cmdstart = "T" then text'cmd                           58060000
              else                                                      58065000
              if cmdstart = "!" then debug'cmd                          58070000
              else                                                      58075000
              if cmdstart = "S" then set'cmd                            58080000
              else                                                      58085000
              if cmdstart = "H" then help'cmd                           58090000
              else                                             <<*nth*>>58095000
              if cmdstart = "L" then live'cmd                  <<*nth*>>58100000
              else                                               <<nsf>>58105000
              if cmdstart = "M" then mod'cmd                     <<nsf>>58110000
              else                                               <<nsf>>58115000
              if cmdstart = "U" then use'cmd                     <<nsf>>58120000
              else                                                      58125000
              if cmdstart = "C" then close'cmd                          58130000
              else                                                      58135000
              if cmdstart = "V" then version'cmd                        58140000
              else                                                      58145000
              if cmdstart = ":" then mpe'cmd                            58150000
              else                                                      58155000
              if cmdstart = "A" then auto'cmd                           58160000
                                else invalid'cmd; end;                  58165000
                                                                        58170000
  if print'enabled and command <> invalid'cmd then             << hks >>58175000
     begin                                                     << hks >>58180000
     write'rec(print'file,lbuf,0,%40);                                  58185000
     btempbuf := "-";                                                   58190000
     move btempbuf(1) := buf, (numchar);                                58195000
     write'rec(print'file,tempbuf,-numchar-1,%60);                      58200000
     end;                                                      << hks >>58205000
                                                                        58210000
  if new'text and (command=disp'cmd    or                               58215000
                   command=find'cmd    or                      <<*nth*>>58220000
                   command=fmt'cmd     or                               58225000
                   command=mod'cmd     or                        <<nsf>>58230000
                   command=use'cmd     or                        <<nsf>>58235000
                   command=version'cmd or                               58240000
                   command=set'cmd      )                               58245000
              and not live'sys                                 <<*nth*>>58250000
     then begin                                                         58255000
     printerror(32);    <<must text in file first>>                     58260000
     command:=null'cmd; <<bypass following case  >>                     58265000
     end;                                                               58270000
                                                                        58275000
  if cmdstart <> "FIND" then                                   << hks >>58280000
     @parmstart := @cmdstart(1)                                         58285000
  else                                                                  58290000
     @parmstart:=@cmdstart(4);<<1st parm start for "FIND" cmd>><< hks >>58295000
                                                                        58300000
  <<execute the command>>                                               58305000
  case command of begin                                                 58310000
                                                                        58315000
    <<invalid command>>                                                 58320000
    printerror(8);                                                      58325000
                                                                        58330000
    <<null command>>                                                    58335000
    ;                                                                   58340000
                                                                        58345000
    <<exit command>>                                                    58350000
    done:=true;                                                         58355000
                                                                        58360000
    <<display command>>                                                 58365000
    begin                                                               58370000
    parsedisplay(parmstart,startaddr,dispcount,dispmode,match'suppress);58375000
    if = then                                                           58380000
      display(parmstart,startaddr,dispcount,dispmode,                   58385000
              match'suppress);                                          58390000
    end;                                                                58395000
                                                                        58400000
    <<find command>>                                           <<*nth*>>58405000
    find(parmstart);                                           <<*nth*>>58410000
                                                               <<*nth*>>58415000
    <<format command>>                                                  58420000
    formatinfo(parmstart);                                              58425000
                                                                        58430000
    <<text command>>                                                    58435000
    begin                                                      <<*nth*>>58440000
      live'sys := false;                                       <<*nth*>>58445000
    textfile(parmstart);                                                58450000
    end;                                                       <<*nth*>>58455000
                                                                        58460000
    <<compute command>>                                                 58465000
    compute(parmstart);                                                 58470000
                                                                        58475000
    <<debug command>>                                                   58480000
    debug;                                                              58485000
                                                                        58490000
    << set command >>                                                   58495000
    set'reg(parmstart);                                                 58500000
                                                                        58505000
    <<help command (9)>>                                                58510000
    help(cmdstart,buf,parmstart);                                       58515000
                                                                        58520000
    <<live command>>                                           <<*nth*>>58525000
    if sysmgr then                                                      58530000
    begin                                                      <<*nth*>>58535000
      live'sys := true;                                        <<*nth*>>58540000
      textfile(parmstart);                                     <<*nth*>>58545000
    end                                                                 58550000
    else printerror(84);  << requires sysmgr cap >>                     58555000
                                                               <<*nth*>>58560000
    ;                                                            <<nsf>>58565000
                                                                        58570000
    <<modify command for "FIXING THINGS" >>                      <<nsf>>58575000
    if live'sys then printerror(62)                                     58580000
    else                                                                58585000
      begin                                                             58590000
      parsemodify(parmstart,startaddr,dispcount,dispmode);       <<nsf>>58595000
      if = then                                                  <<nsf>>58600000
        modify(parmstart,startaddr,dispcount,dispmode);                 58605000
      end;                                                              58610000
                                                                        58615000
    <<use a loadmap file for stack formatting>>                  <<nsf>>58620000
    usefile(parmstart);                                          <<nsf>>58625000
                                                                        58630000
    <<close hardcopy file>>                                             58635000
    close'print'file;                                                   58640000
                                                                        58645000
    <<version command>>                                                 58650000
    which'mpe(2);                                                       58655000
                                                                        58660000
    << mpe command >>                                                   58665000
    execute'mpe'command(parmstart);                                     58670000
                                                                        58675000
    << autostop on/off command >>                                       58680000
    if parmstart = "ON" then                                            58685000
      enable'autostop                                                   58690000
    else                                                                58695000
      disable'autostop;                                                 58700000
                                                                        58705000
  end; <<case>> end;                                                    58710000
                                                                        58715000
if not new'text then                                                    58720000
  begin                                                                 58725000
  fclose(coref,1,0); << save last file that was referenced >>           58730000
    if <> then                                                          58735000
      begin                                                             58740000
      fcheck(coref,error);                                              58745000
      genmsgu(8,error);                                                 58750000
      printerror(30);                                                   58755000
      end;                                                              58760000
  if vm'inuse then                                                      58765000
    begin                                                               58770000
    fclose(vmfile,1,0);                                                 58775000
    if <> then                                                          58780000
      begin                                                             58785000
      fcheck(vmfile,error);                                             58790000
      genmsgu(8,error);                                                 58795000
      printerror(30);                                                   58800000
      end;                                                              58805000
    end;                                                                58810000
  end;                                                                  58815000
                                                                        58820000
                                                               << hks >>58825000
if print'file'open then close'print'file;                      << hks >>58830000
end;  <<ci>>                                                            58835000
$page "         PROCEDURE  OPEN'PRINT'FILE"                    << hks >>58840000
<<******************************************>>                 << hks >>58845000
<<  open'print'file                         >>                 << hks >>58850000
<<------------------------------------------>>                 << hks >>58855000
<<  open the hardcopy file, idatlist        >>                 << hks >>58860000
<<******************************************>>                 << hks >>58865000
                                                               << hks >>58870000
procedure open'print'file;                                     << hks >>58875000
                                                               << hks >>58880000
begin                                                          << hks >>58885000
                                                               << hks >>58890000
integer error,error'len;                                       << hks >>58895000
logical array lout'buf(0:39);                                  << hks >>58900000
byte array out'buf(*) = lout'buf;                              << hks >>58905000
                                                               << hks >>58910000
<<  this procedure is used to open a hardcopy list file,  >>   << hks >>58915000
<<  idatlist, whenever a "P ON" command is issued and a   >>   << hks >>58920000
<<  hardcopy list file is not currently opened.           >>   << hks >>58925000
                                                               << hks >>58930000
                                                               << hks >>58935000
print'file := fopen(lpfname,%404,1,-132,lpdevname,,,,16);      << hks >>58940000
if < then begin    <<error opening print file>>                << hks >>58945000
   fcheck(,error); <<get error number>>                        << hks >>58950000
   ferrmsg(error,lout'buf,error'len);                          << hks >>58955000
   print(lout'buf,-error'len,%40);                             << hks >>58960000
   printerror(45);                                             << hks >>58965000
   print'file'open := false;                                   << hks >>58970000
   end                                                         << hks >>58975000
else begin                                                     << hks >>58980000
   print'file'open := true;                                    << hks >>58985000
   move out'buf:= " New hardcopy listing file has been opened";<< hks >>58990000
   print(lout'buf,21,%40);                                     << hks >>58995000
   end;                                                        << hks >>59000000
end; <<open'print'file>>                                       << hks >>59005000
                                                               << hks >>59010000
                                                               << hks >>59015000
$page "         PROCEDURE  CLOSE'PRINT'FILE"                   << hks >>59020000
<<**********************************************>>             << hks >>59025000
<< close'print'file                             >>             << hks >>59030000
<<---------------------------------------------->>             << hks >>59035000
<< close the hardcopy file, idatlist            >>             << hks >>59040000
<<**********************************************>>             << hks >>59045000
                                                               << hks >>59050000
procedure close'print'file;                                    << hks >>59055000
begin                                                          << hks >>59060000
                                                               << hks >>59065000
integer error'num,len;                                         << hks >>59070000
logical array lout'buf(0:39);                                  << hks >>59075000
byte array out'buf(*) = lout'buf;                              << hks >>59080000
                                                               << hks >>59085000
<<  this procedure is used to close the hardcopy  >>           << hks >>59090000
<<  file, idatlist, whenever this file is needed  >>           << hks >>59095000
<<  to be closed, i.e. when an error occurs while >>           << hks >>59100000
<<  writing to this file, the user does a         >>           << hks >>59105000
<<  "P CLOSE" command, or when exiting idat.      >>           << hks >>59110000
<<                                                >>           << hks >>59115000
<<    print'file - file number of hardcopy file   >>           << hks >>59120000
<<                                                >>           << hks >>59125000
                                                               << hks >>59130000
if print'file'open then                                                 59135000
   begin                                                                59140000
   move out'buf:=" Attempting to CLOSE print file ...";        << hks >>59145000
   print(lout'buf,17,%320);                                    << hks >>59150000
   fclose(print'file,1,0);                                     << hks >>59155000
   if <> then begin                                            << hks >>59160000
      move out'buf := " Error while closing";                  << hks >>59165000
      print(lout'buf,10,%40);                                  << hks >>59170000
      fcheck(print'file,error'num);                            << hks >>59175000
      ferrmsg(error'num,lout'buf,len);                         << hks >>59180000
      print(lout'buf,-len,%40);                                << hks >>59185000
      fclose(print'file,4,0);                                  << hks >>59190000
      if <> then begin                                         << hks >>59195000
         move out'buf := " Attempt to delete IDATLIST failed ";<< hks >>59200000
         print (lout'buf,17,%40);                              << hks >>59205000
         end;                                                  << hks >>59210000
      end                                                      << hks >>59215000
   else begin                                                  << hks >>59220000
      move out'buf := " CLOSED ";                              << hks >>59225000
      print(lout'buf,4,%40);                                   << hks >>59230000
      end;                                                     << hks >>59235000
   end                                                                  59240000
else printerror(63);                                                    59245000
print'file'open := false;                                      << hks >>59250000
                                                               << hks >>59255000
end; <<close'print'file>>                                      << hks >>59260000
                                                               << hks >>59265000
                                                               << hks >>59270000
<<*********************************************************>>           59275000
<<  prompt'stop                                            >>           59280000
<<--------------------------------------------------------->>           59285000
<<  prompt to see if user wishes to continue printing      >>           59290000
<<  to terminal                                            >>           59295000
<<*********************************************************>>           59300000
logical procedure prompt'stop;                                          59305000
begin                                                                   59310000
                                                                        59315000
logical array lprompt'buf(0:39);                               << hks >>59320000
byte array prompt'buf(*) = lprompt'buf;                        << hks >>59325000
integer len;                                                   << hks >>59330000
                                                                        59335000
if not print'enabled then                                               59340000
  begin                                                                 59345000
  move prompt'buf := " < CR to Continue > ";                   << hks >>59350000
  print(lprompt'buf,10,%53);                                   << hks >>59355000
  len := read(lprompt'buf,-1);                                 << hks >>59360000
  prompt'stop := (len <> 0);                                            59365000
  move prompt'buf := (27,"A",27,"G",27,"K");                            59370000
  print(lprompt'buf,-6,%320);                                           59375000
  screen'line := 0;                                            << hks >>59380000
  end;                                                                  59385000
end; << prompt'stop >>                                         << hks >>59390000
                                                                        59395000
procedure enable'autostop;                                              59400000
begin                                                                   59405000
  autostop'on := true;                                                  59410000
  screen'line := 1;                                                     59415000
end;                                                                    59420000
                                                                        59425000
procedure disable'autostop;                                             59430000
begin                                                                   59435000
  autostop'on := false;                                                 59440000
end;                                                                    59445000
                                                                        59450000
                                                                        59455000
$page "         PROCEDURE  WRITE'REC"                          << hks >>59460000
<<*********************************************************>>  << hks >>59465000
<< write'rec                                               >>  << hks >>59470000
<<--------------------------------------------------------->>  << hks >>59475000
<< write record to appropriate stdlist and print files     >>  << hks >>59480000
<<*********************************************************>>  << hks >>59485000
procedure write'rec(file'num,lout'buf,buflen,ccode);           << hks >>59490000
value file'num,buflen,ccode;                                   << hks >>59495000
integer file'num,buflen,ccode;                                 << hks >>59500000
logical array lout'buf;                                        << hks >>59505000
begin                                                          << hks >>59510000
                                                                        59515000
define cc = status.(6:2)#;                                              59520000
logical status = q-1;     << status reg in marker >>                    59525000
                                                                        59530000
byte array out'buf(*)=lout'buf;                                << hks >>59535000
logical array lprompt'buf(0:39);                               << hks >>59540000
byte array prompt'buf(*) = lprompt'buf;                        << hks >>59545000
integer len, error'num;                                        << hks >>59550000
                                                               << hks >>59555000
<<  this procedure is used in place of fwrite in the  >>       << hks >>59560000
<<  other procedures of idat, so that the output      >>       << hks >>59565000
<<  may be directed to either stdlist or to a         >>       << hks >>59570000
<<  separate print file (hardcopy listing), idatlist, >>       << hks >>59575000
<<  depending on the setting of the print'enabled     >>       << hks >>59580000
<<  variable.  it is also used to allow the printing  >>       << hks >>59585000
<<  of twenty-two lines at a time to be printed to    >>       << hks >>59590000
<<  stdlist and then prompt the user for a carriage   >>       << hks >>59595000
<<  return for continuation of output.                >>       << hks >>59600000
                                                               << hks >>59605000
                                                               << hks >>59610000
                                                               << hks >>59615000
cc := cce;                                                              59620000
if print'enabled then                                                   59625000
  begin                                                                 59630000
  if not print'file'open then open'print'file;                          59635000
  if print'file'open then                                               59640000
    begin                                                               59645000
    fwrite(print'file,lout'buf,buflen,ccode);                           59650000
    if <> then                                                          59655000
      begin                                                             59660000
      cc := if < then ccl else ccg;                                     59665000
      move out'buf:=                                           << hks >>59670000
          "  **  ERROR WHILE WRITING TO PRINT FILE  **",2;     << hks >>59675000
      len := tos - @out'buf;                                            59680000
      print(lout'buf,-len,%40);                                << hks >>59685000
      fcheck(print'file,error'num);                            << hks >>59690000
      ferrmsg(error'num, lprompt'buf, len);                    << hks >>59695000
      print(lprompt'buf, -len, %40);                           << hks >>59700000
      close'print'file;                                        << hks >>59705000
      print'enabled := false;                                  << hks >>59710000
      move out'buf := " ** Hardcopy listing disabled **";      << hks >>59715000
      print(lout'buf,16,%40);                                  << hks >>59720000
      return;                                                  << hks >>59725000
      end;                                                              59730000
    end;                                                                59735000
  end                                                                   59740000
else                                                                    59745000
  begin                                                                 59750000
  fwrite(outfile,lout'buf,buflen,ccode);                                59755000
  if <> then                                                   << hks >>59760000
     begin                                                     << hks >>59765000
     cc := if < then ccl else ccg;                                      59770000
     move prompt'buf := " Error writing to $STDLIST ", 2;      << hks >>59775000
     len := tos - @prompt'buf;                                 << hks >>59780000
     print (lprompt'buf, -len, %40);                           << hks >>59785000
     fcheck(outfile,error'num);                                << hks >>59790000
     ferrmsg(error'num, lprompt'buf, len);                     << hks >>59795000
     print(lprompt'buf, -len, %40);                            << hks >>59800000
     return;                                                   << hks >>59805000
     end;                                                      << hks >>59810000
<< determine if time to prompt user for continuation of data >><< hks >>59815000
  if autostop'on  and  screen'line >= 23 then                           59820000
    stop'print := prompt'stop;                                          59825000
  screen'line := screen'line + 1;                                       59830000
  end;                                                                  59835000
                                                               << hks >>59840000
end;  << write'rec >>                                                   59845000
$page "                     PROCEDURE WELCOME"                          59850000
<<***********************************************************>>         59855000
<< welcome                                                   >>         59860000
<<----------------------------------------------------------->>         59865000
<< display welcome message on $stdlist                       >>         59870000
<<***********************************************************>>         59875000
procedure welcome;                                                      59880000
begin                                                                   59885000
                                                               <<84311>>59890000
integer length;                                                <<84311>>59895000
                                                                        59900000
logical array lbuf(0:39);                                               59905000
byte array buf(*)=lbuf;                                                 59910000
                                                                        59915000
move buf := ("Interactive MPE-IV/V Dump Analysis Tool - ",     <<84311>>59920000
             "30 June 86"), 2;                                 <<*nth*>>59925000
length := tos - @buf;                                          <<84311>>59930000
print (lbuf, -length, 0);                                      <<84311>>59935000
move buf := "(C) HEWLETT-PACKARD COMPANY 1985", 2;             <<84311>>59940000
length := tos - @buf;                                          <<84311>>59945000
print (lbuf, -length, %60);                                    <<84311>>59950000
                                                                        59955000
                                                                        59960000
move buf := "Type 'H' for Help",2;                                      59965000
length := tos - @buf;                                          <<84311>>59970000
print (lbuf, -length, %60);                                    <<84311>>59975000
end;  <<welcome>>                                                       59980000
                                                                        59985000
$page "         PROCEDURE  HELP"                                        59990000
<<**********************************************>>                      59995000
<<   help                                       >>                      60000000
<<---------------------------------------------->>                      60005000
<<   open help catalog, increase zsize, and     >>                      60010000
<<   call external procedure helproc for        >>                      60015000
<<   "HELP" command                             >>                      60020000
<<**********************************************>>                      60025000
                                                                        60030000
procedure help(command,buf,parms);                                      60035000
                                                                        60040000
byte array buf;                                                         60045000
byte pointer command,  <<entire command                   >>            60050000
     parms;          <<points to parameters             >>              60055000
                                                                        60060000
begin                                                                   60065000
                                                                        60070000
integer catnum,      <<file number of help catalog      >>              60075000
        i,           <<parse counter                    >>              60080000
        err,         <<helproc returns error code       >>              60085000
        actsize,     <<zsize before expansion           >>              60090000
        expandsz,    <<helproc requires 3564 extra words>>              60095000
        error1,      <<procinfo: success?               >>              60100000
        error2;      <<procinfo: additional return info >>              60105000
byte array idathelp(0:28), <<file.group.acct of program >>              60110000
           idatprog(0:40); <<procinfo: group, acct of idat>>            60115000
intrinsic fopen,fclose,zsize,procinfo;                                  60120000
                                                                        60125000
<< try to find idathelp in the same group.account  idat  is >> <<84326>>60130000
<< run  in.  if  that fails, try logon group.acct (allowing >> <<84326>>60135000
<< file equations).  if that fails, try  idathelp.idat.kse. >> <<84326>>60140000
<< if that fails, give up.                                  >> <<84326>>60145000
<< the user interface group has a manual describing helproc.          >>60150000
<< in order to accomodate the 3564 extra stack words required,        >>60155000
<< idat must be preped or run with maxdata=8192.                      >>60160000
                                                                        60165000
err:=0;                                                                 60170000
catnum:=0;                                                              60175000
                                                                        60180000
<< search for and open prepared help catalog >>                         60185000
                                                                        60190000
procinfo(error1,error2,0,10,idatprog);  <<idatprog:=file.group.acct   >>60195000
if error1 <> 0 then begin                                               60200000
   printerror(33);                                                      60205000
   return;                                                              60210000
   end;                                                                 60215000
while idatprog <> "." do @idatprog:=@idatprog+1; <<scan to .group.acct>>60220000
move idathelp:="IDATHELP";                                              60225000
move idathelp(8):=idatprog,(18);                                        60230000
catnum:=fopen(idathelp,1,%300);                                         60235000
if <> then                                                     <<84326>>60240000
   begin   << can't open idathelp.rungrp.runacct.           >> <<84326>>60245000
   fcheck (catnum, err);                                       <<84326>>60250000
   if 52 <= err <= 53 then                                     <<84326>>60255000
      begin   << doesn't exist, try idathelp.log.on.        >> <<84326>>60260000
      idathelp(8) := " ";   << delimit file name.           >> <<84326>>60265000
      catnum := fopen (idathelp, 1, %300);                     <<84326>>60270000
      if <> then                                               <<84326>>60275000
         begin   << still can't open it.                    >> <<84326>>60280000
         fcheck (catnum, err);                                 <<84326>>60285000
         if 52 <= err <= 53 then                               <<84326>>60290000
            begin   << doesn't exist, .idat.kse last chance >> <<84326>>60295000
            move idathelp(8) := ".IDAT.KSE ";                  <<84326>>60300000
            catnum := fopen (idathelp, 1, %300);               <<84326>>60305000
            if <> then fcheck (catnum, err);                   <<84326>>60310000
            end;    << doesn't exist, .idat.kse last chance >> <<84326>>60315000
         end;    << still can't open it.                    >> <<84326>>60320000
      end;    << doesn't exist, try idathelp.log.on.        >> <<84326>>60325000
   end;    << can't open idathelp.rungrp.runacct.           >> <<84326>>60330000
                                                               <<84326>>60335000
<< at this point, either the help file is open (catnum <> 0)>> <<84326>>60340000
<< or err contains the reason why not.                      >> <<84326>>60345000
                                                               <<84326>>60350000
if catnum = 0 then                                             <<84326>>60355000
   begin                                                       <<84326>>60360000
   genmsgu (8, err);                                           <<84326>>60365000
   printerror (39);                                            <<84326>>60370000
   return;                                                     <<84326>>60375000
   end;                                                        <<84326>>60380000
                                                               <<84326>>60385000
                                                                        60390000
actsize:=zsize(0);                        <<query current zsize       >>60395000
expandsz:=zsize(actsize+3564);            <<helproc requires large z  >>60400000
if <> then                                                     <<84326>>60405000
   begin   << unable to expand zsize.                       >> <<84326>>60410000
   printerror (34);   << tell user to prep with ...         >> <<84326>>60415000
   printerror (40);   << ... maxdata >= 8192.               >> <<84326>>60420000
   end     << unable to expand zsize.                       >> <<84326>>60425000
else                                                           <<84326>>60430000
   begin                                                       <<84326>>60435000
   while parms = " " do @parms := @parms + 1;                  <<84326>>60440000
   helproc (catnum, outfile, parms, buf, err, true);           <<84326>>60445000
   actsize := zsize (actsize);   << restore old zsize.      >> <<84326>>60450000
   end;                                                        <<84326>>60455000
fclose(catnum,0,0);                       <<close help catalog        >>60460000
                                                                        60465000
end;  <<help>>                                                          60470000
                                                                        60475000
                                                                        60480000
                                                                        60485000
$page"         GET'DST'ENTRY"                                           60490000
procedure get'dst'entry(dst'number, dst'entry);                         60495000
  value dst'number;                                                     60500000
  integer dst'number;                                                   60505000
  logical array dst'entry;                                              60510000
                                                                        60515000
begin                                                                   60520000
  integer i;                                                            60525000
                                                                        60530000
  for i := 0 until 3 do                                                 60535000
    dst'entry(i) :=                                                     60540000
      core(double(core(2d) + logical(dst'number*4 + i)));               60545000
                                                                        60550000
end;  << get'dst'entry >>                                               60555000
$page"     AUTO'FILE:  Check for good system file in dump file"         60560000
$control segment=tapev1                                                 60565000
logical procedure auto'file(filenumber);                                60570000
  value filenumber;                                                     60575000
  integer filenumber;                                                   60580000
                                                                        60585000
begin                                                                   60590000
  auto'file := directory(fleof) <> 0d;                                  60595000
end;                                                                    60600000
$page"    FREAD'SYSFILE'DIR: Access a system file from dump"            60605000
$control segment=idat5                                                  60610000
procedure fread'sysfile'dir(filenumber,target,tcount,recnum);           60615000
  value filenumber,tcount,recnum;                                       60620000
  integer filenumber,tcount;                                            60625000
  double recnum;                                                        60630000
  logical array target;                                                 60635000
                                                                        60640000
begin                                                                   60645000
                                                                        60650000
  define cc = status.(6:2) #;                                           60655000
                                                                        60660000
  logical status = q-1;                                                 60665000
                                                                        60670000
                                                                        60675000
  cc := cce;  << assume no errors >>                                    60680000
  if recnum >= directory(fleof) or                                      60685000
     not auto'file(filenumber)  then                                    60690000
    begin                                                               60695000
    cc := ccg;                                                          60700000
    return;                                                             60705000
    end;                                                                60710000
  if tcount < 0 then  tcount := (-tcount)/2;                            60715000
  if tcount > (-integer(directory(flrecsize)))/2  then                  60720000
    tcount := (-integer(directory(flrecsize)))/2;                       60725000
  reading'sysfile := true;                                              60730000
  getcore(directory(start'addr) +                                       60735000
          recnum * (-directory(flrecsize))/2d, tcount, target);         60740000
  if < then cc:= ccl                                                    60745000
  else if > then cc := ccg;                                             60750000
  reading'sysfile := false;                                             60755000
                                                                        60760000
end;   << fread'sysfile'dir >>                                          60765000
$page"  TIME'STAMP: Put a time stamp on real & virtual files"           60770000
procedure time'stamp;                                                   60775000
                                                                        60780000
begin                                                                   60785000
                                                                        60790000
logical array l'timebuf(0:13);                                          60795000
byte array timebuf(*) = l'timebuf;                                      60800000
                                                                        60805000
dateline(timebuf);                                                      60810000
 << put time in directory >>                                            60815000
freaddir(coref,corebuf,4096,(max'real'mem+1d)/4096d);                   60820000
move corebuf(time'loc*2) := l'timebuf, (14);                            60825000
fwritedir(coref,corebuf,4096,(max'real'mem+1d)/4096d);                  60830000
 << put time in virtual file >>                                         60835000
if vmfile <> 0  then                                                    60840000
  begin                                                                 60845000
  freaddir(vmfile,corebuf,4096,0d);                                     60850000
  move corebuf := l'timebuf, (14);                                      60855000
  fwritedir(vmfile,corebuf,4096,0d);                                    60860000
  end;                                                                  60865000
old'block'number := -1d; << next core call fills corebuf >>             60870000
                                                                        60875000
end;  << time'stamp >>                                                  60880000
$page"  COMPARE'TIME'STAMP: Do real and virtual files match?"           60885000
logical procedure compare'time'stamp;                                   60890000
                                                                        60895000
begin                                                                   60900000
                                                                        60905000
logical array l'timebuf(0:13);                                          60910000
byte array timebuf(*) = l'timebuf;                                      60915000
logical array lc'time(0:13);                                            60920000
byte array c'time(*) = lc'time;                                         60925000
                                                                        60930000
freaddir(coref,corebuf,4096,(max'real'mem+1d)/4096d);                   60935000
freaddir(vmfile,l'timebuf,14,0d);                                       60940000
move lc'time := corebuf(time'loc*2), (14);                              60945000
compare'time'stamp := c'time = timebuf, (27);                           60950000
old'block'number := -1d; << next core call fills corebuf >>             60955000
                                                                        60960000
end;  << compare'time'stamp >>                                          60965000
$page"     NAME'CST:  Get DST name from loadmap file"                   60970000
procedure name'cst(cst'num,target);                                     60975000
  value cst'num;                                                        60980000
  integer cst'num;                                                      60985000
  logical array target;                                                 60990000
                                                                        60995000
begin                                                                   61000000
  byte array btarget(*)=target;                                         61005000
  logical array tmpbuf(0:63);                                           61010000
  byte array btmpbuf(*)=tmpbuf;                                         61015000
  integer error;                                                        61020000
                                                                        61025000
  if auto'file(loadmap) then                                            61030000
    begin                                                               61035000
    if new'loadmap then                                                 61040000
      begin                                                             61045000
      fread'sysfile'dir(loadmap,tmpbuf,64,                              61050000
                        double((cst'num mod 51) + 2));                  61055000
      if <> then return;                                                61060000
      move btarget := btmpbuf((cst'num/51)*25 + 4), (21);               61065000
      end                                                               61070000
    else                                                                61075000
      begin                                                             61080000
      fread'sysfile'dir(loadmap,tmpbuf,64,                              61085000
                        double((cst'num mod 50) + 4));                  61090000
      if <> then return;                                                61095000
      move target := tmpbuf((cst'num/50)*16 + 2), (14);                 61100000
      end;                                                              61105000
    end                                                                 61110000
  else                                                                  61115000
    if ld'in'use then                                                   61120000
      begin                                                             61125000
      if new'loadmap then                                               61130000
        begin                                                           61135000
        freaddir(ldfile,tmpbuf,64,double((cst'num mod 51) + 2));        61140000
        if <> then                                                      61145000
          begin                                                         61150000
          fcheck(ldfile,error);                                         61155000
          genmsgu(8,error);                                             61160000
          printerror(60);                                               61165000
          end;                                                          61170000
        move btarget := btmpbuf((cst'num/51)*25 + 4), (21);             61175000
        end                                                             61180000
      else                                                              61185000
        begin                                                           61190000
        freaddir(ldfile,tmpbuf,64,double((cst'num mod 50) + 4));        61195000
        if <> then                                                      61200000
          begin                                                         61205000
          fcheck(ldfile,error);                                         61210000
          genmsgu(8,error);                                             61215000
          printerror(60);                                               61220000
          end;                                                          61225000
        move target := tmpbuf((cst'num/50)*16 + 2), (14);               61230000
        end;                                                            61235000
      end;                                                              61240000
end;  << name'cst >>                                                    61245000
                                                                        61250000
$page "CHKLDMAP: Compare dump vers with its loadmap vers"               61255000
$control segment=tapev1                                                 61260000
procedure chkldmap;                                                     61265000
comment                                                                 61270000
                                                                        61275000
purpose:                                                                61280000
  this procedure attempts to verify that the mpe version                61285000
  obtained from the dump and the version in the loadmap                 61290000
  file included on the tape(tape'version=1) are the same.               61295000
  if not, the directory entry for loadmap is nullified.                 61300000
                                                                        61305000
globals altered:                                                        61310000
     directory                                                          61315000
;                                                                       61320000
                                                                        61325000
begin                                                                   61330000
                                                                        61335000
array tmpbuf(0:63);                                                     61340000
byte array btmp(*)=tmpbuf;                                              61345000
double mpe'rec;                                                         61350000
                                                                        61355000
if auto'file(loadmap) then                                              61360000
  begin                                                                 61365000
  fread'sysfile'dir(loadmap,tmpbuf,-20,2d);                             61370000
  new'loadmap := not(btmp = " ");                                       61375000
  if new'loadmap then mpe'rec := 2d                                     61380000
  else mpe'rec := 4d;                                                   61385000
  fread'sysfile'dir(loadmap,tmpbuf,-20,mpe'rec);                        61390000
  if <> then move l'directory := 8(0)                                   61395000
  else                                                                  61400000
    begin                                                               61405000
    lbuf(2) := core(verno);     <<version id>>                          61410000
    lbuf    := core(upno);      <<update id >>                          61415000
    lbuf(1) := core(fno);       << fix id   >>                          61420000
    if btmp( 7) <> buf(4),(2) or                                        61425000
       btmp(10) <> buf   ,(2) or                                        61430000
       btmp(13) <> buf(2),(2) then                                      61435000
    move l'directory := 8(0);                                           61440000
    end;                                                                61445000
  end;                                                                  61450000
end;  <<chkldmap>>                                                      61455000
$page "  FREAD'MULTIVOL: FREAD with multiple volume capability"         61460000
integer procedure fread'multivol(fileno, buffer, count);                61465000
                                                                        61470000
<<  this procedure is used in place of fread's from tape  >>            61475000
<<  where is is desired to have multi-volume input        >>            61480000
<<  capability.                                           >>            61485000
                                                                        61490000
    value fileno, count;                                                61495000
    integer fileno, count;                                              61500000
    logical array buffer;                                               61505000
                                                                        61510000
begin                                                                   61515000
                                                                        61520000
  define cc = status.(6:2)#;                                            61525000
                                                                        61530000
  equate forwardtomark  = 7,                                            61535000
         backwardtomark = 8,                                            61540000
         rewindunload   = 9,                                            61545000
         serdisc        = %37;                                          61550000
  array trailbuf(0:10);                                                 61555000
  integer tlog;                                                         61560000
  logical status = q-1, proper'volume, parm;                            61565000
                                                                        61570000
  tlog := fread(fileno,buffer,count);                                   61575000
  if < then                                                             61580000
    begin                                                               61585000
    fread'multivol := tlog;                                             61590000
    cc:= ccl;                                                           61595000
    return;                                                             61600000
    end                                                                 61605000
  else if > then                                                        61610000
    do                                                                  61615000
      begin                                                             61620000
      tlog := fread(fileno,trailbuf,10);                                61625000
      currentvol := currentvol + 1;                                     61630000
      if tlog <> 10 or trailbuf <> currentvol then                      61635000
        begin                                                           61640000
        cc := ccg;                                                      61645000
        fcontrol(fileno,backwardtomark,parm);                           61650000
        fspace(fileno,1);                                               61655000
        return;                                                         61660000
        end;                                                            61665000
      do                                                                61670000
        begin                                                           61675000
        fcontrol(fileno,rewindunload,parm);                             61680000
        move buf := "MOUNT NEXT VOLUME ";                               61685000
        printop(lbuf,9,0);                                              61690000
        if devtype.(8:8) = serdisc then                                 61695000
          fcontrol(fileno,forwardtomark,parm);                          61700000
        tlog := fread(fileno,trailbuf,10);                              61705000
        proper'volume :=                                                61710000
          if tlog = 10 and trailbuf = currentvol then                   61715000
            true                                                        61720000
          else                                                          61725000
            false;                                                      61730000
        if not proper'volume then                                       61735000
          begin                                                         61740000
          move buf := "IMPROPER VOLUME ";                               61745000
          printop(lbuf,8,parm);                                         61750000
          end;                                                          61755000
        end                                                             61760000
      until proper'volume;                                              61765000
                                                                        61770000
      << read and check next record >>                                  61775000
      tlog := fread(fileno,buffer,count);                               61780000
      if < then                                                         61785000
        begin                                                           61790000
        fread'multivol := tlog;                                         61795000
        cc := ccl;                                                      61800000
        return;                                                         61805000
        end;                                                            61810000
      end                                                               61815000
    until = ;                                                           61820000
  fread'multivol := tlog;                                               61825000
  cc := cce;                                                            61830000
end; << fread'multivol >>                                               61835000
                                                                        61840000
$page"      GET'SYSTEM'FILES: Read system files from tape"              61845000
procedure get'system'files;                                             61850000
                                                                        61855000
begin                                                                   61860000
                                                                        61865000
                                                                        61870000
define  << file label entry excerpt>>                                   61875000
    label'flrecsize = tapebuf(%45) #,                                   61880000
    label'ho'fleof  = tapebuf(%52) #,                                   61885000
    label'lo'fleof  = tapebuf(%53) #;                                   61890000
                                                                        61895000
  logical array tapebuf(0:127);                                         61900000
  integer len, error, read'count, filenumber;                           61905000
  double curr'addr;                                                     61910000
  double dwork;                                                         61915000
  logical ho'dwork = dwork;                                             61920000
  logical lo'dwork = dwork + 1;                                         61925000
                                                                        61930000
                                                                        61935000
  blankbuf;                                                             61940000
  corebuf := 0;  move corebuf(1) := corebuf, (4095);                    61945000
  curr'addr := max'real'mem + 129d;                                     61950000
  fpoint(coref,max'real'mem&dlsr(12) + 1d);                             61955000
  filenumber := 0;                                                      61960000
  read'count := 0;                                                      61965000
                                                                        61970000
  while filenumber < 4 do                                               61975000
    begin    << fread tape loop >>                                      61980000
    len := fread'multivol(dmptape,tapebuf,128);                         61985000
    if < then                                                           61990000
      begin                                                             61995000
      fcheck(dmptape,error);                                            62000000
      genmsgu(8,error);                                                 62005000
      printerror(25);                                                   62010000
      go errleave;                                                      62015000
      end                                                               62020000
    else if > then                                                      62025000
      begin    << found eof >>                                          62030000
      max'file := curr'addr - 1d;                                       62035000
      if read'count <> 0 then                                           62040000
        begin    << file has contents >>                                62045000
        << check for correct file length >>                             62050000
        dwork := curr'addr - directory(end'addr);                       62055000
        if dwork < 0d or dwork > 128d then  << bad file len >>          62060000
          << nullify directory entry >>                                 62065000
          move l'directory(start'addr*2) := 8(0);                       62070000
        << flush remainder of buffer after last file >>                 62075000
        if filenumber >= 3 and curr'addr modd 4096 <> 0 then            62080000
          begin                                                         62085000
          fwrite(coref,corebuf,4096,0);                                 62090000
          if <> then                                                    62095000
            begin                                                       62100000
            print'file'info(coref);                                     62105000
            printerror(26);                                             62110000
            go errleave;                                                62115000
            end;                                                        62120000
          end;                                                          62125000
        read'count := 0;                                                62130000
        end;     << file has contents >>                                62135000
      filenumber := filenumber + 1;                                     62140000
      end      << found eof >>                                          62145000
    else                                                                62150000
      begin    << copy to corebuf >>                                    62155000
      if read'count = 0 then  << 1st record is file label >>            62160000
        begin   << fill directory entry and print file name >>          62165000
        directory(start'addr) := curr'addr;                             62170000
        directory(flrecsize) := -double(-label'flrecsize);              62175000
        ho'dwork := label'ho'fleof;                                     62180000
        lo'dwork := label'lo'fleof;                                     62185000
        directory(fleof)  := dwork;                                     62190000
        directory(end'addr) := directory(start'addr) +                  62195000
            dwork * double((-label'flrecsize)/2) - 1d;                  62200000
        move buf :="READING IN ";                                       62205000
        case filenumber of                                              62210000
          begin                                                         62215000
          move buf(11) := "LOADMAP";                                    62220000
          move buf(11) := "MPECHECK";                                   62225000
          move buf(11) := "CONFDATA";                                   62230000
          move buf(11) := "HPPMAP";                                     62235000
          end;                                                          62240000
        printline(outfile);                                             62245000
        end     << fill directory entry and print file name >>          62250000
      else                                                              62255000
        begin                                                           62260000
        move corebuf(curr'addr modd 4096) := tapebuf, (128);            62265000
        if (curr'addr + 128d) modd 4096 = 0 then                        62270000
          begin                                                         62275000
          fwrite(coref,corebuf,4096,0);                                 62280000
          if <> then                                                    62285000
            begin                                                       62290000
            print'file'info(coref);                                     62295000
            printerror(26);                                             62300000
            go errleave;                                                62305000
            end;                                                        62310000
          corebuf := 0;  move corebuf(1) := corebuf, (4095);            62315000
          end;                                                          62320000
        curr'addr := curr'addr + 128d;                                  62325000
        end;                                                            62330000
      read'count := read'count + 1;                                     62335000
      end;    << copy to corebuf >>                                     62340000
    end;    << fread tape loop >>                                       62345000
  chkldmap;                                                             62350000
                                                                        62355000
errleave:                                                               62360000
                                                                        62365000
end;    << get'system'files >>                                          62370000
$page"            VMTODISK: Copy Virtual Storage to 'VIRFILE' "         62375000
procedure vmtodisk;                                                     62380000
comment                                                                 62385000
                                                                        62390000
    for the tape format used for dumps including virtual                62395000
    storage see the comment in the vers1'tapetodisk                     62400000
    procedure.                                                          62405000
                                                                        62410000
                                                                        62415000
    this procedure reads the variable length records                    62420000
    from the virtual storage tape file and writes them                  62425000
    to the virtual storage file.  this file has                         62430000
    fixed length 4k records with zero padding used                      62435000
    for segments whose lengths are not integer multiples                62440000
    of 4k.                                                              62445000
                                                                        62450000
    as the segments are read in, memory addresses are                   62455000
    assigned to them and these addresses are used when                  62460000
    each of the segments are 'swapped in' to the                        62465000
    pseudo dst.  the starting address for virtual                       62470000
    storage is immediately after the highest real                       62475000
    memory address.  maxmem is increased to include                     62480000
    virtual storage after it has all been read from                     62485000
    tape and swapped in.  the header and trailer records                62490000
    from tape for each data segment are not included                    62495000
    in the virtual file.  only the data segments and the                62500000
    above zero padding are in the virtual storage file.                 62505000
                                                                        62510000
end of comment;                                                         62515000
                                                                        62520000
begin                                                                   62525000
        define                                                          62530000
        << data segment table entry >>                                  62535000
        rl'dsabsent = rl'dst'entry(0).(0:1) #,                          62540000
        rl'dsroc    = rl'dst'entry(1).(1:1) #,                          62545000
        rl'dsimi    = rl'dst'entry(1).(2:1) #,                          62550000
                                                                        62555000
        dsabsent    = dst'entry(0).(0:1)    #,                          62560000
        dsroc       = dst'entry(1).(1:1)    #,                          62565000
        dsimi       = dst'entry(1).(2:1)    #;                          62570000
                                                                        62575000
  integer vm'rec'num,len,num'ds'recs,dstno,dummy,i;                     62580000
  double vm'addr;                                                       62585000
  logical vm'bank = vm'addr, vm'base = vm'addr+1;                       62590000
  logical array rl'dst'entry(0:3);                                      62595000
  logical array dst'entry(0:3);                                         62600000
                                                                        62605000
  subroutine vm'error(err'num);                                         62610000
  value err'num;  integer err'num;                                      62615000
  begin                                                                 62620000
    case err'num of                                                     62625000
      begin                                                             62630000
      << 0>> move buf:=                                                 62635000
               "READ ERROR FROM TAPE";                                  62640000
      << 1>> move buf:=                                                 62645000
               "INVALID HEADER RECORD - VM TAPE FILE";                  62650000
      << 2>> move buf:=                                                 62655000
               "DATA SEGMENT LENGTH ERROR - VM TAPE FILE";              62660000
      << 3>> move buf:=                                                 62665000
               "BAD RECORD LENGTH - VM TAPE FILE";                      62670000
      << 4>> move buf:=                                                 62675000
               "CC <> CCE ON FWRITE TO VM DISK FILE";                   62680000
      << 5>> move buf:=                                                 62685000
               "INVALID TRAILER RECORD - VM TAPE FILE";                 62690000
      << 6>> move buf:=                                                 62695000
               "EXPECTED EOF MARK - REAL MEMORY";                       62700000
      << 7>> move buf:=                                                 62705000
               "BAD DST NUMBER - VM TAPE FILE";                         62710000
      end;                                                              62715000
    printline(outfile);                                                 62720000
    << skip to next tape file >>                                        62725000
    fcontrol(dmptape,7,dummy);                                          62730000
    << disable the use of virtual memory for the remainder >>           62735000
    vm'inuse := false;                                                  62740000
    assemble( exit 0 );  << return from vmtodisk >>                     62745000
  end;   << vm'error >>                                                 62750000
                                                                        62755000
subroutine sdf'error(error'word);                                       62760000
value error'word;  logical error'word;                                  62765000
begin                                                                   62770000
  if error'word.(0:1) then                                              62775000
    begin                                                               62780000
    move buf := "SDF ERROR - INVALID LDEV NUMBER";                      62785000
    printline(outfile);                                                 62790000
    end;                                                                62795000
  if error'word.(1:1) then                                              62800000
    begin                                                               62805000
    if rl'dsimi = 1  then                                               62810000
      move buf := ("SDF WARNING - NOT ABLE TO DUMP IMI DATA ",          62815000
                   "SEGMENT")                                           62820000
    else                                                                62825000
      move buf:= "SDF ERROR - INVALID VIRTUAL MEMORY ADDRESS";          62830000
    printline(outfile);                                                 62835000
    end;                                                                62840000
  if error'word.(2:1) then                                              62845000
    begin                                                               62850000
    move buf := "SDF ERROR - DISC READ ERROR";                          62855000
    printline(outfile);                                                 62860000
    end;                                                                62865000
  if error'word.(3:1) then                                              62870000
    begin                                                               62875000
    move buf := "SDF ERROR - INVALID TABLE STRUCTURE";                  62880000
    printline(outfile);                                                 62885000
    end;                                                                62890000
end;   << sdf'error >>                                                  62895000
                                                                        62900000
  <<   p r o c e d u r e    m a i n   >>                                62905000
  blankbuf;                                                             62910000
  vm'inuse := true;                                                     62915000
  vm'rec'num := 0;                                                      62920000
                                                                        62925000
  move buf:="READING VIRTUAL STORAGE";                                  62930000
  printline(outfile);                                                   62935000
  len := fread(dmptape,tempbuf,4096);                                   62940000
  if <= then vm'error(6);  << should be eof >>                          62945000
  while true do                                                         62950000
    begin   << read data segments >>                                    62955000
    len := fread'multivol(dmptape,tempbuf,4096);                        62960000
    if < then  << read error >>                                         62965000
      vm'error(0);                                                      62970000
    if > then    << end of virtual memory file >>                       62975000
      begin                                                             62980000
      << calc new maxmem to include vm >>                               62985000
      maxmem := maxmem + double(vm'rec'num) * 4096d;                    62990000
      if vm'rec'num = 0 then                                            62995000
        begin                                                           63000000
        vm'inuse := false;                                              63005000
        move buf := "NO VIRTUAL MEMORY";                                63010000
        printline(outfile);                                             63015000
        end                                                             63020000
      else                                                              63025000
        begin                                                           63030000
        move buf := "READING OF VIRTUAL STORAGE COMPLETE";              63035000
        printline(outfile);                                             63040000
        end;                                                            63045000
      return;                                                           63050000
      end;                                                              63055000
    << check for tape being appended by an old dpan5 >>                 63060000
    if len = 23 then  << size of version 0 verification rec >>          63065000
      begin                                                             63070000
      move buf :=                                                       63075000
        "TAPE HAS BEEN WRITTEN ON BY OLDER VERSION OF DPAN";            63080000
      printline(outfile);                                               63085000
      move buf :=                                                       63090000
        "VIRTUAL STORAGE AND SYSTEM FILES ARE LOST";                    63095000
      printline(outfile);                                               63100000
      vm'inuse := false;                                                63105000
      get'files := false;                                               63110000
      return;                                                           63115000
      end;                                                              63120000
    << this record should be a header record >>                         63125000
    if tempbuf(0) <> 0 or len <> 12 then                                63130000
      vm'error(1);                                                      63135000
    dstno := tempbuf(1); << dst # from header record >>                 63140000
    if not(1 <= dstno <= integer(core(double(dst'min))))  then          63145000
      vm'error(7);                                                      63150000
      << get dst entry from header >>                                   63155000
    move dst'entry := tempbuf(3), (4);                                  63160000
    if tempbuf(2) = 0 then                                              63165000
      num'ds'recs := 0                                                  63170000
    else                                                                63175000
      begin   << non-zero data seg len >>                               63180000
        << calculate # 4k records in seg >>                             63185000
      num'ds'recs := (tempbuf(2) - 1)/4096 + 1;                         63190000
      for i := 1 until num'ds'recs do                                   63195000
        begin  << copy all records for one data seg >>                  63200000
        len := fread'multivol(dmptape,tempbuf,4096);                    63205000
        if < then  << read error >>                                     63210000
          vm'error(0);                                                  63215000
        if > then  << unexpected eof >>                                 63220000
          begin                                                         63225000
          move buf := "UNEXPECTED EOF IN VM FILE";                      63230000
          printline(outfile);                                           63235000
          vm'inuse := false;                                            63240000
          return;                                                       63245000
          end;                                                          63250000
        << check for correct record length >>                           63255000
        if i = num'ds'recs then << last rec in this data seg >>         63260000
          begin                                                         63265000
          if len < 4096  and                                            63270000
            len <> integer(dst'entry.(3:13)*4) mod 4096  or             63275000
            len = 4096  and                                             63280000
            integer(dst'entry.(3:13)*4) mod 4096 <> 0  then             63285000
            vm'error(2);                                                63290000
          << pad last data seg record with zeros >>                     63295000
          if len <> 4096 then                                           63300000
            begin                                                       63305000
            tempbuf(len) := 0;                                          63310000
            move tempbuf(len+1) := tempbuf(len), (4095-len);            63315000
            end;                                                        63320000
          end                                                           63325000
        else   << other than last record in data seg >>                 63330000
          if len <> 4096 then                                           63335000
            vm'error(3);                                                63340000
        fpoint(vmfile,vmrec'min + double(vm'rec'num));                  63345000
        fwrite(vmfile,tempbuf,4096,0);                                  63350000
        if <> then                                                      63355000
          vm'error(4);                                                  63360000
        vm'rec'num := vm'rec'num + 1;                                   63365000
        end;  << copy all records for one data seg >>                   63370000
      end; << non-zero data seg len >>                                  63375000
    len := fread'multivol(dmptape,tempbuf,4096);                        63380000
    if < then    << read error >>                                       63385000
      vm'error(0);                                                      63390000
    if > then    << unexpected eof >>                                   63395000
      begin                                                             63400000
      move buf := "UNEXPECTED EOF IN VM FILE";                          63405000
      printline(outfile);                                               63410000
      vm'inuse := false;                                                63415000
      return;                                                           63420000
      end;                                                              63425000
    << this record should be a trailer record >>                        63430000
    if tempbuf(0) <> 1 or len <> 4  then                                63435000
      vm'error(5);  << not a trailer record >>                          63440000
    << set up for following conditionals >>                             63445000
    get'dst'entry(dstno,rl'dst'entry);                                  63450000
    << any sdf errors for this data seg? >>                             63455000
    if tempbuf(2) <> 0 or num'ds'recs = 0  then                         63460000
      begin                                                             63465000
      sdf'error(tempbuf(2));                                            63470000
      move buf := "DATA SEG        REMAINS ABSENT";                     63475000
      @pbuf := @buf + 8;                                                63480000
      putnump(dstno);                                                   63485000
      printline(outfile);                                               63490000
      end                                                               63495000
    <<dst entry from real memory shouldn't show present state>>         63500000
    else if rl'dsabsent = 0 or rl'dsroc = 1  then                       63505000
      begin                                                             63510000
      move buf :=                                                       63515000
        "VM DATA SEG       IS ALSO PRESENT IN REAL MEMORY";             63520000
      @pbuf := @buf + 11;                                               63525000
      putnump(dstno);                                                   63530000
      printline(outfile);                                               63535000
      end                                                               63540000
    else                                                                63545000
      begin                                                             63550000
      << convert dst entry to look like present state >>                63555000
      dsabsent := 0;                                                    63560000
      dsimi := 0;                                                       63565000
      << calc beginning virtual addr of this data seg >>                63570000
      vm'addr := vm'min + double(vm'rec'num - num'ds'recs) *            63575000
          4096d;                                                        63580000
      << put this address into the new dst entry >>                     63585000
      dst'entry(2) := vm'bank;                                          63590000
      dst'entry(3) := vm'base;                                          63595000
      << update pdst with new dst entry >>                              63600000
      freaddir(vmfile,tempbuf,4096,double(dstno/1024 + 1));             63605000
      for i := 0 until 3 do                                             63610000
        tempbuf((dstno*4) mod 4096 + i) := dst'entry(i);                63615000
      fwritedir(vmfile,tempbuf,4096,double(dstno/1024 + 1));            63620000
      end;                                                              63625000
    end;  << read data segments >>                                      63630000
end;  << vmtodisk >>                                                    63635000
$page"                     PROCEDURE  VERS1'TAPETODISK"                 63640000
procedure vers1'tapetodisk;                                             63645000
                                                                        63650000
comment                                                                 63655000
                                                                        63660000
    this procedure is called by tapetodisk, after main                  63665000
    memory has been read in, to process the remainder of                63670000
    a version one dump tape.  a virtual storage file is                 63675000
    created by the name given in 'virtfilename'.  record                63680000
    zero of this file is reserved for a time stamp with                 63685000
    room left for future changes.  record one is the                    63690000
    1st record where a copy of the dst is read into.  this              63695000
    is called the pseudo dst.  vmtodisk will 'swap in' the              63700000
    virtual data segments by making the respective dst                  63705000
    entries look like the present state.  this pseudo dst               63710000
    will be used by core where it replaces the real dst                 63715000
    in order to make the addition of the virtual                        63720000
    data segments transparent to all the formatting                     63725000
    routines.  the pdst can be from one to four records                 63730000
    long.  virtual storage follows with its 1st record                  63735000
    being pointed to by vmrec'min.                                      63740000
                                                                        63745000
                                                                        63750000
following are diagrams of the softdump version 1                        63755000
(with virtual storage) tape format:                                     63760000
                                                                        63765000
           dump tape format                                             63770000
                                                                        63775000
           --------------                                               63780000
           |  bot       |                                               63785000
           |------------|                                               63790000
           |  real      |                                               63795000
           |  memory    |                                               63800000
           |  area      |                                               63805000
           |------------|                                               63810000
           |  eof       |                                               63815000
           |------------|    \                                          63820000
           |  virtual   |     |                                         63825000
           |  storage   |     |  result of dseg=all                     63830000
           |  area      |     >  parameter of the                       63835000
           |------------|     |  dump command.                          63840000
           |  eof       |     |                                         63845000
           |------------|    /                                          63850000
           |  loadmap   |                                               63855000
           |------------|                                               63860000
           |  eof       |                                               63865000
           |------------|                                               63870000
           |  mpecheck  |                                               63875000
           |------------|                                               63880000
           |  eof       |                                               63885000
           |------------|                                               63890000
           |  confdata  |                                               63895000
           |------------|                                               63900000
           |  eof       |                                               63905000
           |------------|                                               63910000
           |  hppmap    |                                               63915000
           |------------|                                               63920000
           |  eof       |                                               63925000
           |------------|                                               63930000
           |  eof       |                                               63935000
           |------------|                                               63940000
                                                                        63945000
                                                                        63950000
                                                                        63955000
                                                                        63960000
           memory dump tape                                             63965000
           virtual storage area                                         63970000
                                                                        63975000
           --------------                                               63980000
           |  header    |                                               63985000
           |  record    |                                               63990000
           |------------|                                               63995000
           |  data      |                                               64000000
           |  segment   |                                               64005000
           |------------|                                               64010000
           |  trailer   |                                               64015000
           |  record    |                                               64020000
           |------------|    \                                          64025000
           |  header    |     |                                         64030000
           |  record    |     |  no data seg contents                   64035000
           |------------|     >  because of error.                      64040000
           |  trailer   |     |                                         64045000
           |  record    |     |                                         64050000
           |------------|    /                                          64055000
           |            |                                               64060000
           .     o      .                                               64065000
           .            .                                               64070000
           .     o      .                                               64075000
           .            .                                               64080000
           .     o      .                                               64085000
           |            |                                               64090000
           |------------|                                               64095000
           |  header    |                                               64100000
           |  record    |                                               64105000
           |------------|                                               64110000
           |  data      |                                               64115000
           |  segment   |                                               64120000
           |------------|                                               64125000
           |  trailer   |                                               64130000
           |  record    |                                               64135000
           |------------|                                               64140000
                                                                        64145000
                                                                        64150000
                                                                        64155000
                    memory dump tape                                    64160000
                    virtual storage area                                64165000
                    header record format                                64170000
                                                                        64175000
          0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                64180000
        |--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|               64185000
word 0  |                      0                        |               64190000
        |-----------------------------------------------|               64195000
word 1  |                     dst#                      |               64200000
        |-----------------------------------------------|               64205000
word 2  |            length of dst in words             |               64210000
        |-----------------------------------------------|               64215000
word 3  |a |0 |r |               size/4                 | firm          64220000
        |-----------------------------------------------| info          64225000
word 4  |d |r |i |s |m |f |s |c |w |                    |               64230000
        |c |o |m |t |o |w |y |o |d |   vmalloc          | flags         64235000
        |v |c |i |k |d |i |s |r |  |                    |               64240000
        |  |  |  |  |  |p |  |e |  |                    |               64245000
        |-----------------------------------------------|               64250000
word 5  |     ldev#             |        hoda           | hoda          64255000
        |-----------------------------------------------|               64260000
word 6  |                  loda                         | loda          64265000
        |-----------------------------------------------|               64270000
word 7  |         d             |          s            |               64275000
        |-----------------------------------------------|               64280000
word%10 |         t             |          #            |               64285000
        |-----------------------------------------------|               64290000
word%11 |         x             |          x            |               64295000
        |-----------------------------------------------|               64300000
word%12 |         x             |          x            |               64305000
        |-----------------------------------------------|               64310000
word%13 |         x             |          x            |               64315000
        |-----------------------------------------------|               64320000
                                                                        64325000
                                                                        64330000
                                                                        64335000
                                                                        64340000
                   memory dump tape                                     64345000
                   virtual storage area                                 64350000
                   trailer record format                                64355000
                                                                        64360000
          0  1  2  3  4  5  6  7  8  9 10 11 12 13 14 15                64365000
        |--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|--|               64370000
word 0  |                      1                        |               64375000
        |-----------------------------------------------|               64380000
word 1  |                     dst#                      |               64385000
        |-----------------------------------------------|               64390000
word 2  |i |i |d |i |///////////////////////////////////|               64395000
        |l |a |r |t |///////////////////////////////////| flags         64400000
        |d |d |e |s |///////////////////////////////////|               64405000
        |e |d |  |  |///////////////////////////////////|               64410000
        |v |r |  |  |///////////////////////////////////|               64415000
        |-----------------------------------------------|               64420000
word 3  |  number of records written for dst contents   |               64425000
        |-----------------------------------------------|               64430000
                                                                        64435000
                                                                        64440000
                                                                        64445000
         trailer record field descriptions                              64450000
                                                                        64455000
         ildev = invalid ldev                                           64460000
         iaddr = invalid virtual storage address                        64465000
         dre   = disc read error                                        64470000
         its   = invalid table structure                                64475000
                                                                        64480000
end of comment;                                                         64485000
                                                                        64490000
    begin                                                               64495000
                                                                        64500000
      define                                                            64505000
        absent = entry'word0.(0:1)#,                                    64510000
        roc    = entry'word1.(1:1)#;                                    64515000
      equate max'xds'size'adr = %1111;                                  64520000
      logical max'xds'size;                                             64525000
      logical numdstentries, numdstrecs;                                64530000
      integer numdstwords;                                              64535000
      integer entry'word0, entry'word1, dummy, error, i;                64540000
      double vmrecs;                                                    64545000
                                                                        64550000
      use'pseudo'dst := false;                                          64555000
      max'real'mem := maxmem;                                           64560000
      vm'min := maxmem + 1d;                                            64565000
      numdstentries := core(double(dst'min));                           64570000
      numdstwords := integer((numdstentries + 1) * 4);                  64575000
      numdstrecs := numdstentries/1024 + 1;                             64580000
      vmrec'min := double(numdstrecs + 1);                              64585000
                                                                        64590000
    << calculate total number of 4k records for vm space >>             64595000
    << zero padding is included                          >>             64600000
                                                                        64605000
      vmrecs := 0d;                                                     64610000
      for i := 1 until integer(numdstentries)  do                       64615000
        begin                                                           64620000
        entry'word0 := core(double(dst'min + logical(i*4)));            64625000
        entry'word1 := core(double(dst'min + logical(i*4)+1));          64630000
        if entry'word0 <> %100000                                       64635000
             and absent = 1  and  roc = 0  then << is virtual >>        64640000
          vmrecs :=                                                     64645000
            vmrecs + double((entry'word0.(3:13)-1)/1024 + 1);           64650000
        end;                                                            64655000
                                                                        64660000
    << open vm file >>                                                  64665000
                                                                        64670000
      vmfile := fopen(virtfilename,0,%504,4096,,,,,,                    64675000
                      vmrecs+1d+double(numdstrecs),32,1);               64680000
      if <> then                                                        64685000
        begin                                                           64690000
        move buf :=                                                     64695000
          "CC <> ON FOPEN TO DISK - VIRTUAL MEM FILE";                  64700000
        printline(outfile);                                             64705000
        print'file'info(vmfile);                                        64710000
        return;                                                         64715000
        end;                                                            64720000
                                                                        64725000
    << make room for time stamp >>                                      64730000
                                                                        64735000
      tempbuf := 0;  move tempbuf(1) := tempbuf, (4095);                64740000
      fwrite(vmfile,tempbuf,4096,0);                                    64745000
                                                                        64750000
    << copy dst into the pdst >>                                        64755000
                                                                        64760000
      i := 0;                                                           64765000
      while i < numdstwords  do                                         64770000
        begin                                                           64775000
        tempbuf(i mod 4096) :=                                          64780000
            core(double(dst'min + logical(i)));                         64785000
        if i mod 4096 = 4095 then                                       64790000
          fwrite(vmfile,tempbuf,4096,0);                                64795000
        i := i + 1;                                                     64800000
        end;                                                            64805000
      if i mod 4096 <> 0 then                                           64810000
        begin  << pad remainder of record with zeros >>                 64815000
        tempbuf(i mod 4096) := 0;                                       64820000
        move tempbuf((i mod 4096) + 1) :=                               64825000
          tempbuf(i mod 4096), (4095 - (i mod 4096));                   64830000
        fwrite(vmfile,tempbuf,4096,0);                                  64835000
        end;                                                            64840000
                                                                        64845000
    << copy vm from tape to vmfile while entering each vm >>            64850000
    << data segment's dst entry into the pdst             >>            64855000
                                                                        64860000
      vm'inuse := true;                                                 64865000
      get'files := true;                                                64870000
      vmtodisk;                                                         64875000
                                                                        64880000
      if vm'inuse then                                                  64885000
        begin  << we have vm >>                                         64890000
                                                                        64895000
        << save vm file on disc, then reopen >>                         64900000
        fclose(vmfile,1,0);                                             64905000
        if <> then                                                      64910000
          begin                                                         64915000
          fcheck(vmfile,error);                                         64920000
          genmsgu(8,error);                                             64925000
          printerror(31);                                               64930000
          return;                                                       64935000
          end                                                           64940000
        else                                                            64945000
          begin   << no problem closing, try to reopen.      >>         64950000
          vmfile := fopen (virtfilename, 3, 4);                         64955000
          if <> then                                                    64960000
            begin   << couldn't reopen file.                 >>         64965000
            fcheck (vmfile, error);                                     64970000
            genmsgu (8, error);                                         64975000
            printerror (21);                                            64980000
            return;                                                     64985000
            end;    << couldn't reopen file.                 >>         64990000
          end;    << no problem closing, try to reopen.      >>         64995000
        end   << we have vm >>                                          65000000
      else                                                              65005000
        fclose(vmfile,0,0);  << vm not in use, purge vm file >>         65010000
                                                                        65015000
    << print virtual address range >>                                   65020000
                                                                        65025000
      if vm'inuse then                                                  65030000
        begin                                                           65035000
        blankbuf;                                                       65040000
        move buf :=                                                     65045000
          "VIRTUAL 'ADDRESS' RANGE   =        000000 TO ";              65050000
        @pbuf := @buf + 28;                                             65055000
        putnum(memsize);                                                65060000
        @pbuf := @buf + 45;                                             65065000
        putnum(integer(maxmem&dlsr(16)));                               65070000
        putnum(integer(maxmem));                                        65075000
        blankbuf;   << printline(outfile); >>                           65080000
        end;                                                            65085000
                                                                        65090000
    << set up directory and                           >>                65095000
    << copy system files from tape to temp disk files >>                65100000
gsf:                                                                    65105000
      l'directory := 0;                                                 65110000
      move l'directory(1) := l'directory, (127);                        65115000
      move l'directory(sfd'loc*2) := "SYSTEM FILE DIRECTORY ";          65120000
                                                                        65125000
      if get'files then  get'system'files;                              65130000
                                                                        65135000
      directory(maxmem'loc) := maxmem;                                  65140000
      directory(max'file'loc) := max'file;                              65145000
      directory(vmrec'min'loc) := vmrec'min;                            65150000
      << store directory array into directory location >>               65155000
      << in real memory file                           >>               65160000
      freaddir(coref,corebuf,4096,(max'real'mem+1d)/4096d);             65165000
      move corebuf := l'directory, (128);                               65170000
      fwritedir(coref,corebuf,4096,(max'real'mem+1d)/4096d);            65175000
                                                                        65180000
      use'pseudo'dst := vm'inuse;                                       65185000
                                                                        65190000
      time'stamp;                                                       65195000
                                                                        65200000
      if vm'inuse then                                                  65205000
        begin                                                           65210000
        blankbuf;                                                       65215000
        printline(outfile);                                             65220000
        move buf := "*** VIRTUAL STORAGE IN EFFECT ***";                65225000
        printline(outfile);                                             65230000
        end;                                                            65235000
                                                                        65240000
    end;   << vers1'tapetodisk >>                                       65245000
                                                                        65250000
$page "         PROCEDURE  TEXTFILE"                                    65255000
$control segment=idat5                                                  65260000
<<**********************************************>>                      65265000
<<   textfile                                   >>                      65270000
<<---------------------------------------------->>                      65275000
<<   "TEXT" command, texting a disc file or     >>                      65280000
<<    copying a dumptape to disc                >>                      65285000
<<**********************************************>>                      65290000
procedure textfile(parmstring);                                         65295000
                                                                        65300000
   byte array parmstring;                                               65305000
                                                                        65310000
begin                                                                   65315000
                                                                        65320000
  << this procedure assumes the existence of the >>                     65325000
  << following:                                  >>                     65330000
  <<   procedure printerror                      >>                     65335000
  <<   global variables    coref                 >>                     65340000
  <<                       corebuf               >>                     65345000
  <<                       scrbuf                >>                     65350000
  <<                       asb                   >>                     65355000
  <<   mpe procedures   genmsgu                  >>                     65360000
  <<                    print'file'info          >>                     65365000
  <<   many global variables concerning the      >>                     65370000
  <<       registers as used in subroutines      >>                     65375000
  <<       get35context,get25context, and        >>                     65380000
  <<       get'seriesii'context                  >>                     65385000
                                                                        65390000
                                                                        65395000
equate maxparms    = 2;                                                 65400000
equate disc'access'type = 0;                                            65405000
equate serdisc     = %37;                                               65410000
equate sysfilearea = 64;  << system files go here >>                    65415000
                                                                        65420000
logical infoword, usetape, jnk;                                         65425000
                                                                        65430000
integer numparms,n,error,recsize,blksize;                               65435000
integer length,s'len, tape'type:=24;                                    65440000
integer tlog,bufsav,addrd,i;                                            65445000
                                                                        65450000
double array parms(0:maxparms);                                         65455000
                                                                        65460000
byte delim;                                                             65465000
byte array tp(0:8);                                                     65470000
byte array dumptape(0:9);                                               65475000
byte array delimiters(0:3), discfilename(0:36);                         65480000
byte array dummy(0:36);                                                 65485000
                                                                        65490000
byte pointer string;                                                    65495000
byte pointer pfname;                                                    65500000
                                                                        65505000
<<the following variables are used in determining if>>                  65510000
<<the dump contains an image of "SOFTDUMP".  see    >>                  65515000
<<later comment which lists the patterns we are     >>                  65520000
<<looking for, and their locations.                 >>                  65525000
                                                                        65530000
logical baddump;  <<true: dump is no good>>                             65535000
                                                                        65540000
logical array memory(0:7);                                              65545000
byte array memory'(*)=memory;                                           65550000
                                                                        65555000
logical array softdumppat(0:7);                                         65560000
byte array softdumppat'(*)=softdumppat;                                 65565000
                                                                        65570000
                                                                        65575000
                                                                        65580000
                                                                        65585000
      subroutine get35context; << series ii >>                          65590000
      <<-------------------->>                                          65595000
                                                                        65600000
         begin                                                          65605000
         xreg:=m35xreg;                                                 65610000
         dlreg:=m35dlreg;                                               65615000
         dbbankreg:=m35dbankreg;                                        65620000
         dbreg:=m35dbreg;                                               65625000
         qreg:=m35qreg;                                                 65630000
         sreg:=m35smreg;                                                65635000
         zbankreg:=m35sbankreg;                                         65640000
         zreg:=m35zreg;                                                 65645000
         stareg:=m35statusreg;                                          65650000
         pbbankreg:=m35pbankreg;                                        65655000
         pbreg:=m35pbreg;                                               65660000
         preg:=m35preg;                                                 65665000
         plreg:=m35plreg;                                               65670000
         cirreg:=m35cireg;                                              65675000
         cpx1:=m35cpx1;                                                 65680000
         cpx2:=m35cpx2;                                                 65685000
         sp1:=m35sp1reg;                                                65690000
         sp2:=m35sp2reg;                                                65695000
         if cnstarfish <> 0 then                                        65700000
            begin                                                       65705000
            i := cnstarfish*4; << compute location of drt >>            65710000
            corebuf(i) := cndrt0;                                       65715000
            corebuf(i+1) := cndrt1;                                     65720000
            corebuf(i+2) := cndrt2;                                     65725000
            corebuf(i+3) := cndrt3;                                     65730000
            end                                                         65735000
         else                                                           65740000
            corebuf(24) := m35contents24;                               65745000
         tos:=m35numbanks; tos:=0;                                      65750000
         maxmem := max'real'mem := tos-1d;                              65755000
         memsize:=m35numbanks;                                          65760000
         end  <<get35context>>;                                         65765000
                                                                        65770000
                                                                        65775000
      subroutine get25context;  << series 33 thru mm >>                 65780000
      <<-------------------->>                                          65785000
                                                                        65790000
         begin                                                          65795000
         xreg:=m25xreg;                                                 65800000
         dlreg:=m25dlreg;                                               65805000
         dbbankreg:=m25dbankreg;                                        65810000
         dbreg:=m25dbreg;                                               65815000
         qreg:=m25qreg;                                                 65820000
         sreg:=m25sreg;                                                 65825000
         zbankreg:=m25sbankreg;                                         65830000
         zreg:=m25zreg;                                                 65835000
         stareg:=m25statusreg;                                          65840000
         pbbankreg:=m25pbankreg;                                        65845000
         pbreg:=m25pbreg;                                               65850000
         preg:=m25preg;                                                 65855000
         plreg:=m25plreg;                                               65860000
         cirreg:=m25cireg;                                              65865000
         nir:=m25nirreg;                                                65870000
         isr:=m25isr;                                                   65875000
         if machineid = icf55                                           65880000
         then begin                                                     65885000
           nir := m55nirreg;                                            65890000
           cpx1 := m55cpx1;                                             65895000
           cpx2 := m55cpx2;                                             65900000
         end;                                                           65905000
         tos:=m25numbanks; tos:=0;                                      65910000
         maxmem := max'real'mem := tos-1d;                              65915000
         memsize:=m25numbanks;                                          65920000
         end  <<get25context>>;                                         65925000
                                                                        65930000
                                                                        65935000
subroutine check'tape'files;                                            65940000
<<------------------------>>                                            65945000
    << the record after the end of the memory dump is read>>            65950000
    << if it is not an end of file mark an eof is added,  >>            65955000
begin                                                                   65960000
                                                                        65965000
tlog:=fread(dmptape,corebuf,4096);                                      65970000
if <= then                                                              65975000
  begin                                                                 65980000
  fspace(dmptape,-1);                                                   65985000
  fcontrol (dmptape, 6, n);                                             65990000
  if <> then                                                            65995000
    begin                                                               66000000
    printerror(27);                                                     66005000
    go errleave;                                                        66010000
    end;                                                                66015000
  end;                                                                  66020000
end;                                                                    66025000
                                                                        66030000
                                                                        66035000
subroutine incomplete;                                                  66040000
<<------------------>>                                                  66045000
  << the input dump file has been found to be incomplete.  >>           66050000
  << print error message                                   >>           66055000
                                                                        66060000
begin                                                                   66065000
   move buf := "INCOMPLETE DUMP:    K WORDS SHORT";                     66070000
   @pbuf := @buf + 17;                                                  66075000
   ascii( (numrec*4), 10, pbuf );                                       66080000
   printline(outfile);                                                  66085000
                                                                        66090000
end;  << incomplete. >>                                                 66095000
                                                                        66100000
                                                                        66105000
subroutine get'seriesii'context;                                        66110000
<<--------------------------->>                                         66115000
  << the default machine context is the old series ii.     >>           66120000
  << other options (handled elsewhere) are models 25 & 35. >>           66125000
                                                                        66130000
begin                                                                   66135000
   if usetape then                                                      66140000
      begin   << warn user to save tape.                    >>          66145000
      printerror(36);   << this is not an error.            >>          66150000
      printerror(37);   << neither is this.                 >>          66155000
      end                                                               66160000
   else                                                                 66165000
      begin   << tried to text from disc, not allowed.      >>          66170000
      printerror(37);   << same msg, but this is an error.  >>          66175000
      go to errleave;                                                   66180000
      end;                                                              66185000
   addrd := corebuf( 0 );                                               66190000
   if logical( addrd ) > %1010 then                                     66195000
   begin                                                                66200000
      printerror(24);                                                   66205000
      go errleave;                                                      66210000
   end;                                                                 66215000
                                                                        66220000
series2or3 := true;  << used by getcore >>                              66225000
                                                                        66230000
<< save pertinent  parts of first record.                >>             66235000
   move scrbuf := corebuf(1), (26);                                     66240000
   bufsav := addrd + 1;                                                 66245000
                                                                        66250000
<< read next record and restore saved information.       >>             66255000
<< this record is written upon return to copy to disk code >>           66260000
   tlog := fread( dmptape,corebuf, 4096 );                              66265000
   if > then                                                            66270000
      incomplete                                                        66275000
   else if < then                                                       66280000
      begin   << tape error.                                >>          66285000
      printerror (25);                                                  66290000
      go to errleave;                                                   66295000
      end;    << tape error.                                >>          66300000
   move regsave := corebuf( bufsav+1 ), (26);                           66305000
   move corebuf( bufsav ) := scrbuf, (26);                              66310000
   move corebuf( bufsav-7 ) := regsave, (6);                            66315000
   corebuf( bufsav-1 ) := reg6;                                         66320000
   corebuf( bufsav )   := reg7;                                         66325000
                                                                        66330000
   tos := 0;                                                            66335000
   tos := memsize;                                                      66340000
   tos := tos&dcsr(3)&lsl(3);                                           66345000
   asb( xch );                                                          66350000
   tos := tos&csl(3);                                                   66355000
   asb( xch );                                                          66360000
   tos := tos - 1d;                                                     66365000
   if < then begin ddel; tos := %777777d; end;  << 256 k >>             66370000
   maxmem := tos;                                                       66375000
                                                                        66380000
end;  << get'seriesii'context >>                                        66385000
                                                                        66390000
                                                                        66395000
subroutine init'svregs;                                                 66400000
<<------------------->>                                                 66405000
 begin                                                                  66410000
                                                                        66415000
<< save the values of the registers in case the user>>                  66420000
<< changes them by using the "SET" command.  this   >>                  66425000
<< ensures that the registers can be reset to the   >>                  66430000
<< original values.                                 >>                  66435000
                                                                        66440000
  svdbbank:=dbbankreg;       svpbbank:=pbbankreg;                       66445000
  svdbreg :=dbreg;           svpbreg :=pbreg;                           66450000
  svsbank :=zbankreg;        svqreg  :=qreg;                            66455000
  svsreg  :=sreg;            svzreg  :=zreg;                            66460000
  svdlreg :=dlreg;                                                      66465000
                                                                        66470000
end; << subroutine init'svregs >>                                       66475000
                                                                        66480000
                                                                        66485000
subroutine get'series'type;                                             66490000
<<----------------------->>                                             66495000
begin                                                                   66500000
                                                                        66505000
                                                                        66510000
<< get machine id and appropriate machine context.       >>             66515000
   machineid := cnmachineid;                                            66520000
   if      machineid = model35                                          66525000
      then get35context                                                 66530000
   else if series'33'thru'mm                                            66535000
      then get25context                                                 66540000
   else    get'seriesii'context;                                        66545000
                                                                        66550000
case machineid of                                                       66555000
   begin                                                                66560000
  << series ii >> begin                                                 66565000
                  move seriesbuf:="II ";                                66570000
                  end;                                                  66575000
  << series iii>> begin                                                 66580000
                  move seriesbuf:="III";                                66585000
                  end;                                                  66590000
  << series 33 >> begin                                                 66595000
                  move seriesbuf:="33 ";                                66600000
                  end;                                                  66605000
  << series 44 >> begin                                                 66610000
                  move seriesbuf:="44 ";                                66615000
                  end;                                                  66620000
  << series 64 >> begin                                                 66625000
                  move seriesbuf:="64 ";                                66630000
                  end;                                                  66635000
  << series 37 >> begin                                                 66640000
                  move seriesbuf:="37 ";                                66645000
                  end;                                                  66650000
   end; <<case>>                                                        66655000
                                                                        66660000
end;                                                                    66665000
                                                                        66670000
subroutine check'soft'image;                                            66675000
                                                                        66680000
<<check to see if memory contains an image of "SOFTDUMP">>              66685000
<<if this is the case, there is no point in processing  >>              66690000
<<the dump since most of the low core pointers are      >>              66695000
<<invalid.  there are two possible patterns to test for,>>              66700000
<<both starting at address %175000 of bank zero.  the   >>              66705000
<<patterns are as follows ("---" indicates "DON'T CARE")>>              66710000
<<                                                      >>              66715000
<<  address      pattern 1      pattern 2               >>              66720000
<<  -------      ---------      ---------               >>              66725000
<<  %175000       %002005        %002010                >>              66730000
<<  %175001       %000021            ---                >>              66735000
<<  %175002       %000000        %000000                >>              66740000
<<  %175003       %002000        %000000                >>              66745000
<<  %175004           ---            ---                >>              66750000
<<  %175005       %001000        %001000                >>              66755000
<<  %175006       %000000        %000000                >>              66760000
<<  %175007       %002016        %002010                >>              66765000
                                                                        66770000
begin                                                                   66775000
baddump:=false;   <<assume the dump is good>>                           66780000
                                                                        66785000
<<set up the arrays to test for pattern 1   >>                          66790000
<<don't include the "DON'T CARE" locations  >>                          66795000
memory(0):=core(%175000d); softdumppat(0):=%2005;                       66800000
memory(1):=core(%175001d); softdumppat(1):=  %21;                       66805000
memory(2):=core(%175002d); softdumppat(2):=   %0;                       66810000
memory(3):=core(%175003d); softdumppat(3):=%2000;                       66815000
memory(4):=core(%175005d); softdumppat(4):=%1000;                       66820000
memory(5):=core(%175006d); softdumppat(5):=   %0;                       66825000
memory(6):=core(%175007d); softdumppat(6):=%2016;                       66830000
                                                                        66835000
if memory' = softdumppat',(14) then                                     66840000
  baddump:=true                                                         66845000
else                                                                    66850000
  begin                                                                 66855000
  <<set up arrays to test for pattern 2       >>                        66860000
  <<don't include the "DON'T CARE" locations  >>                        66865000
  memory(0):=core(%175000d); softdumppat(0):=%2010;                     66870000
  memory(1):=core(%175002d); softdumppat(1):=   %0;                     66875000
  memory(2):=core(%175003d); softdumppat(2):=   %0;                     66880000
  memory(3):=core(%175005d); softdumppat(3):=%1000;                     66885000
  memory(4):=core(%175006d); softdumppat(4):=   %0;                     66890000
  memory(5):=core(%175007d); softdumppat(5):=%2010;                     66895000
                                                                        66900000
  if memory' = softdumppat',(12) then                                   66905000
    baddump:=true;                                                      66910000
  end;                                                                  66915000
                                                                        66920000
if baddump then                                                         66925000
  begin                                                                 66930000
  blankbuf;                                                             66935000
  printline(outfile);                                                   66940000
  move buf:="THE DUMP TO BE PROCESSED WAS FOUND TO CONTAIN";            66945000
  printline(outfile);                                                   66950000
  move buf:="AN IMAGE OF THE PROGRAM USED TO ACTUALLY TAKE";            66955000
  printline(outfile);                                                   66960000
  move buf:="A DUMP, AND NOT THE CONTENTS OF MEMORY AT THE";            66965000
  printline(outfile);                                                   66970000
  move buf:="TIME THE SYSTEM WAS STOPPED.";                             66975000
  printline(outfile);                                                   66980000
  move buf:="THIS SITUATION TYPICALLY OCCURS IF A PROBLEM";             66985000
  printline(outfile);                                                   66990000
  move buf:="WAS ENCOUNTERED IN TAKING THE DUMP ORIGINALLY,";           66995000
  printline(outfile);                                                   67000000
  move buf:="AND A SECOND ATTEMPT IS MADE.";                            67005000
  printline(outfile);                                                   67010000
  move buf:="THE RESULTING DUMP IS USUALLY OF LITTLE USE.";             67015000
  printline(outfile);                                                   67020000
                                                                        67025000
  end;                                                                  67030000
end;                                                                    67035000
                                                                        67040000
subroutine getmpevers;                                                  67045000
begin                                                                   67050000
  if mpetype >= 2 then                                                  67055000
    begin                                                               67060000
    mpeversion := 5;                                                    67065000
    if mpetype = 3 then new'firmware := true                            67070000
    else new'firmware := false;                                         67075000
    end                                                                 67080000
  else mpeversion := 4;                                                 67085000
end;                                                                    67090000
                                                                        67095000
subroutine check'modify;                                                67100000
begin                                                                   67105000
  lbuf(0):=core(%1400d);                                                67110000
  if lbuf(0).(0:8)=%123 then                                            67115000
    begin                                                               67120000
    blankbuf; printline(outfile);                                       67125000
    move buf:="                **** WARNING ****";                      67130000
    printline(outfile);                                                 67135000
    move buf :=                                                         67140000
      "     -- MEMORY DUMP FILE HAS BEEN MODIFIED --";                  67145000
    printline(outfile);                                                 67150000
    end;                                                                67155000
end;  <<check'modify>>                                                  67160000
                                                                        67165000
subroutine open'old'file(fname, fnum);                                  67170000
integer fnum;                                                           67175000
byte array fname;                                                       67180000
                                                                        67185000
begin                                                                   67190000
fnum:=fopen(fname,%3,%304,4096); << open as old file>>                  67195000
if = then                                                               67200000
   begin   << file exists  >>                                           67205000
   if usetape  then                                                     67210000
      begin   << user inputting from tape, must purge xstng >>          67215000
      printline(outfile);                                               67220000
      if fname = "V" then  << opened virtual file >>                    67225000
        begin                                                           67230000
        move buf := "This tape may contain virtual storage.";           67235000
        printline(outfile);                                             67240000
        end;                                                            67245000
      scan fname until "  ", 1;                                         67250000
      length := tos;                                                    67255000
      length := length - @fname;                                        67260000
      move buf := fname, (length), 2;                                   67265000
      move *   := " already exists - OK to purge? (Y/N) ";              67270000
      printline(outfile);                                               67275000
      fread (infile, lbuf, -20);                                        67280000
      if <> then terminate;                                             67285000
      if buf = "Y" or buf = "y" then                                    67290000
         begin   << user approved the purge >>                          67295000
         fclose (fnum, 4, 0);                                           67300000
         if <> then                                                     67305000
            begin   << purge failed, find out why and leave >>          67310000
            fcheck (fnum, error);                                       67315000
            genmsgu (8, error);                                         67320000
            printerror (22);                                            67325000
            go to errleave;                                             67330000
            end;    << purge failed, find out why and leave >>          67335000
         end     << user approved the purge >>                          67340000
      else                                                              67345000
         begin   << user disallowed the purge >>                        67350000
         printerror (22);                                               67355000
         go to errleave;                                                67360000
         end;    << user disallowed the purge >>                        67365000
      end;    << user inputting from tape, must purge xstng >>          67370000
   end     << file exists >>                                            67375000
else                                                                    67380000
   begin   << can't open file, does it exist? >>                        67385000
   fcheck (fnum, error);                                                67390000
   if 52 <= error <= 53 then                                            67395000
      begin   << no such file, o.k. if texting from tape >>             67400000
      if not usetape then                                               67405000
         if fname = "V" then                                            67410000
            vmfile := 0                                                 67415000
         else                                                           67420000
            begin   << not texting from tape, error >>                  67425000
            printerror (23);                                            67430000
            go to errleave;                                             67435000
            end;     << not texting from tape, error >>                 67440000
      end     << no such file, o.k. if texting from tape >>             67445000
   else                                                                 67450000
      begin   << some other error, report it and leave >>               67455000
      genmsgu (8, error);                                               67460000
      printerror (21);                                                  67465000
      go to errleave;                                                   67470000
      end;    << some other error, report it and leave >>               67475000
   end;    << can't open file, does it exist? >>                        67480000
end; << open'old'file >>                                                67485000
                                                                        67490000
<<  m a i n    b o d y  >>                                              67495000
                                                                        67500000
if not   new'text then                                                  67505000
  begin                                                                 67510000
  fclose(coref,1,0); << save last file before texting new >>            67515000
    if <> then                                                          67520000
      begin                                                             67525000
      fcheck(coref,error);                                              67530000
      genmsgu(8,error);                                                 67535000
      printerror(30);                                                   67540000
                                                                        67545000
errleave:                                                               67550000
                                                                        67555000
      if dmptape <> 0 then                                              67560000
         fclose (dmptape, 0, 0);                                        67565000
      if coref <> 0 then                                                67570000
         fclose (coref, 0, 0);   << leave like we found it. >>          67575000
      new'text := true;          << no text file open.      >>          67580000
      if vmfile <> 0 then                                               67585000
         fclose (vmfile, 0, 0);                                         67590000
      return;                                                           67595000
      end;                                                              67600000
                                                                        67605000
  if ld'in'use then                                                     67610000
    begin                                                               67615000
    fclose(ldfile,4,0);                                                 67620000
    if <> then                                                          67625000
      begin                                                             67630000
      fcheck(ldfile,error);                                             67635000
      genmsgu(8,error);                                                 67640000
      printerror(60);                                                   67645000
      end;                                                              67650000
    ld'in'use:=false;                                                   67655000
    end;                                                                67660000
  new'text := true;                                                     67665000
  end;                                                                  67670000
                                                                        67675000
<< initialize(nullify) system file directory >>                         67680000
l'directory := 0;  move l'directory(1) := l'directory, (127);           67685000
                                                                        67690000
vm'inuse := false;                                                      67695000
use'pseudo'dst := false;                                                67700000
                                                                        67705000
if live'sys then                                                        67710000
  begin                                                                 67715000
  maxmem := 4095d;                                                      67720000
  for i := 0 until 4095 do                                              67725000
    corebuf(i) := core(double(i));                                      67730000
  assemble(pcn);                                                        67735000
  cnmachineid := tos;                                                   67740000
  get'series'type;                                                      67745000
  tos := livenumbanks;  tos := -1;                                      67750000
  maxmem := tos;                                                        67755000
  which'mpe(1);                                                         67760000
  getmpevers;                                                           67765000
  return;                                                               67770000
  end;                                                                  67775000
                                                                        67780000
series2or3 := false;                                                    67785000
old'block'number := -1d; << next call to core will read disc >>         67790000
file'good:=false;                                                       67795000
usetape:=false;                                                         67800000
move dumptape := "DUMPTAPE ";                                           67805000
                                                                        67810000
<<set up to parse the parameters>>                                      67815000
delimiters(0):=",";                                                     67820000
delimiters(1):=cr;                                                      67825000
mycommand(parmstring,delimiters,maxparms,numparms,parms);               67830000
if <> then                                                              67835000
  begin                                                                 67840000
  printerror(0);                                                        67845000
  return;                                                               67850000
  end;                                                                  67855000
                                                                        67860000
if not (0<=numparms <=2) then                                           67865000
  begin                                                                 67870000
  printerror(7);                                                        67875000
  return;                                                               67880000
  end;                                                                  67885000
                                                                        67890000
if numparms = 0 then return;                                            67895000
                                                                        67900000
if numparms = 2 then << should be tape option >>                        67905000
  begin                                                                 67910000
  tos:=parms(1);                                                        67915000
  infoword:=tos;                                                        67920000
  @string:=tos;                                                         67925000
  length := infoword.(0:8);                                             67930000
                                                                        67935000
  if length <> 4 or string <> "TAPE" then                               67940000
    begin                                                               67945000
    printerror(12);                                                     67950000
    return;                                                             67955000
    end;                                                                67960000
                                                                        67965000
  <<need to open tape file>>                                            67970000
  usetape:=true;                                                        67975000
  end;                                                                  67980000
                                                                        67985000
<<get name of disc file to open>>                                       67990000
tos:=parms(0);                                                          67995000
infoword:=tos;                                                          68000000
@string:=tos;                                                           68005000
length := infoword.(0:8);                                               68010000
                                                                        68015000
if length > 35 then                                                     68020000
   begin   << exceeds maximum fname/lock.group.acct.        >>          68025000
   printerror (38);   << "File name is too long."           >>          68030000
   return;   << let file system handle syntax errors.       >>          68035000
   end;    << exceeds maximum fname/lock.group.acct.        >>          68040000
                                                                        68045000
if discfilename = "V"  then                                             68050000
  begin                                                                 68055000
  printerror(80);                                                       68060000
  return;                                                               68065000
  end;                                                                  68070000
                                                                        68075000
move discfilename := string,(length);                                   68080000
discfilename(length) := cr;  << for get'token >>                        68085000
move delimiters := (" ./",cr);                                          68090000
s'len := get'token(discfilename,delimiters,dummy,delim);                68095000
move discfilename := string, (length);  << restore d..name >>           68100000
discfilename(length) := " ";                                            68105000
if s'len > 8  then                                                      68110000
  begin                                                                 68115000
  printerror(38);                                                       68120000
  return;                                                               68125000
  end;                                                                  68130000
if s'len < 8  then                                                      68135000
  move string(1) := discfilename, (length+1);                           68140000
move virtfilename := string,(length+2);                                 68145000
virtfilename := "V";                                                    68150000
                                                                        68155000
open'old'file (discfilename, coref);                                    68160000
                                                                        68165000
<< either have successfully opened existing real memory     >>          68170000
<< dump file or need to open new file                       >>          68175000
                                                                        68180000
<< open tape file if necessary, and copy to disc file.      >>          68185000
if usetape then                                                         68190000
  begin                                                                 68195000
  move tp:="TAPE ";                                                     68200000
  dmptape:=fopen(dumptape,%200,%504,4096,tp);                           68205000
  if <> then                                                            68210000
    begin                                                               68215000
    fcheck(dmptape,error);                                              68220000
    genmsgu(8,error);                                                   68225000
    printerror(21);                                                     68230000
    go to errleave;                                                     68235000
    end;                                                                68240000
                                                                        68245000
  << verify that tape file has correct characteristics >>               68250000
  fgetinfo(dmptape,,,,recsize,devtype,,,,,,,,,blksize);                 68255000
  if <> then                                                            68260000
    begin                                                               68265000
    fcheck(dmptape,error);                                              68270000
    genmsgu(8,error);                                                   68275000
    printerror(21);                                                     68280000
    go to errleave;                                                     68285000
    end;                                                                68290000
                                                                        68295000
  if devtype.(10:6) = tape'type and                                     68300000
      (recsize <> 4096 or blksize <> recsize) then                      68305000
    begin                                                               68310000
    printerror(24);                                                     68315000
    return;                                                             68320000
    end;                                                                68325000
                                                                        68330000
  if devtype.(10:6) = serdisc then                                      68335000
    if recsize <> 4096 then                                             68340000
      begin                                                             68345000
      printerror(24);                                                   68350000
      return;                                                           68355000
      end                                                               68360000
    else fcontrol(dmptape,7,jnk);                                       68365000
                                                                        68370000
<< print progress message to terminal >>                                68375000
  blankbuf;                                                             68380000
  printline(outfile);                                                   68385000
  move buf := "READING REAL MEMORY";                                    68390000
  printline(outfile);                                                   68395000
                                                                        68400000
<< read the first record of the dump from tape >>                       68405000
  tlog := fread( dmptape, corebuf, 4096 );                              68410000
  if <> then       << fread error on first record >>                    68415000
    begin                                                               68420000
    fcheck(dmptape,error);                                              68425000
    genmsgu(8,error);                                                   68430000
    printerror(25);                                                     68435000
    go errleave;                                                        68440000
    end;                                                                68445000
                                                                        68450000
  get'series'type;                                                      68455000
                                                                        68460000
<< get tape version >>                                                  68465000
  tape'version := cntapevers;                                           68470000
                                                                        68475000
<< print sdf tape version >>                                            68480000
  move buf := "SDF TAPE VERSION = ";                                    68485000
  length := ascii(tape'version,10,buf(19));                             68490000
  printline(outfile);                                                   68495000
                                                                        68500000
<< open virtual storage file >>                                         68505000
  if tape'version = 1 then                                              68510000
    open'old'file(virtfilename,vmfile);                                 68515000
                                                                        68520000
<< delineate dst for core procedure >>                                  68525000
  dst'min := corebuf(2);                                                68530000
  dst'max := dst'min + corebuf(dst'min)*4 + 3;                          68535000
                                                                        68540000
<< calc number of 4k records - 1 in real memory dump >>                 68545000
  numrec := integer( maxmem&dlsr(12) );                                 68550000
                                                                        68555000
<< open disk file for real memory dump & system files >>                68560000
  coref:=fopen(discfilename,0,%504,4096,,,,,,                           68565000
               double(numrec+1+sysfilearea),32,1);                      68570000
  if <> then                                                            68575000
    begin                                                               68580000
    fcheck(dmptape,error);                                              68585000
    genmsgu(8,error);                                                   68590000
    printerror(21);                                                     68595000
    go to errleave;                                                     68600000
    end;                                                                68605000
                                                                        68610000
<< copy the first record to the disk file >>                            68615000
  fwritedir( coref, corebuf, 4096, 0d );                                68620000
  if <> then                                                            68625000
    begin                                                               68630000
    print'file'info( coref );                                           68635000
    printerror(26);                                                     68640000
    go errleave;                                                        68645000
    end;                                                                68650000
                                                                        68655000
  while numrec > 0  do                                                  68660000
    begin                                                               68665000
    << copy the rest of the dump file to the core disk file >>          68670000
                                                                        68675000
    << read and check the next record.                  >>              68680000
    tlog := fread'multivol( dmptape, corebuf, 4096 );                   68685000
    if <> then   << fread short >>                                      68690000
      begin                                                             68695000
      incomplete;                                                       68700000
      go to errleave;                                                   68705000
      end;  << fread short >>                                           68710000
                                                                        68715000
    << write the record to the core disk file.          >>              68720000
    fwrite( coref, corebuf, 4096, 0 );                                  68725000
    if <> then                                                          68730000
      begin                                                             68735000
      print'file'info( coref );                                         68740000
      printerror(26);                                                   68745000
      go errleave;                                                      68750000
      end;                                                              68755000
                                                                        68760000
    numrec := numrec - 1;                                               68765000
                                                                        68770000
    end;    << copying loop >>                                          68775000
                                                                        68780000
<< print progress and address range messages >>                         68785000
  move buf := "READING OF REAL MEMORY COMPLETE";                        68790000
  printline(outfile);                                                   68795000
  move buf :=                                                           68800000
  "REAL MEMORY ADDRESS RANGE = 000000 000000 TO        177777";         68805000
  @pbuf := @buf + 45;                                                   68810000
  putnum(memsize-1);                                                    68815000
  blankbuf;  << printline(outfile); >>                                  68820000
                                                                        68825000
<< now go read the remainder of the tape if the    >>                   68830000
<< tape version number is equal to one             >>                   68835000
                                                                        68840000
  if tape'version = 1 then  vers1'tapetodisk                            68845000
  else if tape'version <> 0 then                                        68850000
    begin                                                               68855000
    move lbuf := "INVALID TAPE VERSION NUMBER";                         68860000
    printline(outfile);                                                 68865000
    go to errleave;                                                     68870000
    end;                                                                68875000
                                                                        68880000
                                                                        68885000
  << save tape file on disc, then reopen >>                             68890000
  fclose(coref,9,0);  << return unused disc space >>                    68895000
  if <> then                                                            68900000
    begin                                                               68905000
    fcheck(coref,error);                                                68910000
    genmsgu(8,error);                                                   68915000
    printerror(31);                                                     68920000
    go to errleave;                                                     68925000
    end                                                                 68930000
  else                                                                  68935000
    begin   << no problem closing, try to reopen.          >>           68940000
    coref := fopen (discfilename, 3, 4);                                68945000
    if <> then                                                          68950000
      begin   << couldn't reopen file.                     >>           68955000
      fcheck (coref, error);                                            68960000
      genmsgu (8, error);                                               68965000
      printerror (21);                                                  68970000
      go to errleave;                                                   68975000
      end;    << couldn't reopen file.                     >>           68980000
    end;    << no problem closing, try to reopen.          >>           68985000
  fclose (dmptape, 0, 0);   << done with tape file.        >>           68990000
  end     << texting file from tape.                       >>           68995000
else                                                                    69000000
  begin   << texting from disc.                            >>           69005000
  freaddir (coref, corebuf, 4096, 0d);                                  69010000
  if <> then                                                            69015000
     begin                                                              69020000
     fcheck (coref, error);                                             69025000
     genmsgu (8, error);                                                69030000
     printerror(17);                                                    69035000
     go to errleave;                                                    69040000
     end;                                                               69045000
  get'series'type;                                                      69050000
                                                                        69055000
  << get tape version >>                                                69060000
  tape'version := cntapevers;                                           69065000
                                                                        69070000
  << if the tape version is 1, then check for system files >>           69075000
  << and accomanying virtual storage file                  >>           69080000
                                                                        69085000
  if tape'version = 1  then                                             69090000
    begin                                                               69095000
    << delineate dst for core procedure >>                              69100000
    dst'min := core(2d);                                                69105000
    dst'max := dst'min + core(double(dst'min))*4 + 3;                   69110000
    << get system file directory - if it exists >>                      69115000
    numrec := integer(max'real'mem & dlsr(12)) + 1;                     69120000
    freaddir(coref,corebuf,4096,double(numrec));                        69125000
    if = then                                                           69130000
      begin                                                             69135000
      << check for identification string >>                             69140000
      move lbuf := corebuf(sfd'loc*2), (11);                            69145000
      if buf = sfd, (21)  then   <<"SYSTEM FILE DIRECTORY">>            69150000
        begin                                                           69155000
        << get the directory >>                                         69160000
        move l'directory := corebuf, (128);                             69165000
        max'file := directory(max'file'loc);                            69170000
        chkldmap;                                                       69175000
        << open virt storage file >>                                    69180000
        open'old'file (virtfilename, vmfile);                           69185000
        << check for good vm file >>                                    69190000
        if vmfile <>0  then                                             69195000
          begin                                                         69200000
          if compare'time'stamp  then                                   69205000
            begin                                                       69210000
            vm'min := max'real'mem + 1d;                                69215000
            maxmem := directory(maxmem'loc);                            69220000
            vmrec'min := directory(vmrec'min'loc);                      69225000
            vm'inuse := true;                                           69230000
            use'pseudo'dst := true;                                     69235000
            blankbuf;                                                   69240000
            printline(outfile);                                         69245000
            move buf :=                                                 69250000
              "        *** VIRTUAL STORAGE IN EFFECT ***";              69255000
            printline(outfile);                                         69260000
            end                                                         69265000
          else                                                          69270000
            begin                                                       69275000
            printerror(82);                                             69280000
            blankbuf;                                                   69285000
            printline(outfile);                                         69290000
            move buf :=                                                 69295000
              "        *** VIRTUAL STORAGE DISABLED ***";               69300000
            printline(outfile);                                         69305000
            fclose(vmfile,0,0);                                         69310000
            if <> then                                                  69315000
              begin                                                     69320000
              fcheck(coref,error);                                      69325000
              genmsgu(8,error);                                         69330000
              end;                                                      69335000
            end;                                                        69340000
          end;                                                          69345000
        end;                                                            69350000
      end;                                                              69355000
    end;                                                                69360000
  end;    << texting from disc.                            >>           69365000
                                                                        69370000
check'soft'image;                                                       69375000
init'svregs;  <<save original values of regs from discfile >>           69380000
new'text := false;   << ready to boogie.                   >>           69385000
check'modify;                                                           69390000
which'mpe(1);                                                           69395000
getmpevers;                                                             69400000
                                                                        69405000
end;    << of textfile.                                    >>           69410000
$page "                PROCEDURE FMTREGS"                               69415000
$control segment=formatc                                                69420000
<<*********************************************>>                       69425000
<<  fmtregs                                    >>                       69430000
<<--------------------------------------------->>                       69435000
<< formats and prints register table and the   >>                       69440000
<< first 9 words of fixed low memory           >>                       69445000
<<*********************************************>>                       69450000
                                                                        69455000
procedure fmtregs(prntfile);                                            69460000
   value prntfile;                                                      69465000
   integer prntfile;                                                    69470000
begin                                                                   69475000
                                                                        69480000
<<  this procedure assumes the existence of the following >>            69485000
<< global variables:                                      >>            69490000
<<    all registers and "SAVE" registers                  >>            69495000
<<    machineid                                           >>            69500000
<<    seriesbuf                  procedure putnum         >>            69505000
<<    coref                      corebuf                  >>            69510000
                                                                        69515000
                                                                        69520000
double loccst;                                                <<860213>>69525000
logical dummy;  << dummy return from core call which loads corebuf>>    69530000
                                                                        69535000
byte array temp(0:5);  << for ascii conversions >>                      69540000
                                                                        69545000
logical array outln(0:39);                                              69550000
byte array outlnb(*)=outln;  << line of asterisks for                   69555000
                                "BOXING-IN" table     >>                69560000
logical array head(0:39);                                               69565000
byte array headb(*)=head;  << header of register table >>               69570000
                                                                        69575000
<< bodylines of table>>                                                 69580000
logical array bdyln1(0:39),                                             69585000
              bdyln2(0:39),                                             69590000
              bdyln3(0:39),                                             69595000
              bdyln4(0:39),                                             69600000
              bdyln5(0:39),                                             69605000
              bdyln6(0:39),                                             69610000
              bdyln7(0:39),                                             69615000
              bdyln8(0:39);                                             69620000
                                                                        69625000
byte array bdyln1b(*)=bdyln1,                                           69630000
           bdyln2b(*)=bdyln2,                                           69635000
           bdyln3b(*)=bdyln3,                                           69640000
           bdyln4b(*)=bdyln4,                                           69645000
           bdyln5b(*)=bdyln5,                                           69650000
           bdyln6b(*)=bdyln6,                                           69655000
           bdyln7b(*)=bdyln7,                                           69660000
           bdyln8b(*)=bdyln8;                                           69665000
                                                                        69670000
                                                                        69675000
subroutine init'buffers;                                                69680000
<<-------------------->>                                                69685000
    << initialize buffers that won't change during the >>               69690000
    << course of the procedure                         >>               69695000
begin                                                                   69700000
                                                                        69705000
<< line of asterisks >>                                                 69710000
move outlnb:="*";                                                       69715000
move outlnb(1):=outlnb,(79);                                            69720000
                                                                        69725000
<< header line >>                                                       69730000
move headb:="*   DATA SEGMENT   *";                                     69735000
move headb(20):="  CODE SEGMENT  *";                                    69740000
move headb(37):="MISCELLANEOUS*";                                       69745000
move headb(51):=" STATUS = ";                                           69750000
ascii(stareg,8,headb(61));                                              69755000
move headb(67):="  *";                                                  69760000
                                                                        69765000
<< blank out table lines >>                                             69770000
move bdyln1b:=" ";                                                      69775000
move bdyln1b(1):=bdyln1b,(69);                                          69780000
                                                                        69785000
move bdyln2b := bdyln1b, (70);                                 <<84301>>69790000
                                                                        69795000
move bdyln3b := bdyln1b, (70);                                 <<84301>>69800000
                                                                        69805000
move bdyln4b := bdyln1b, (70);                                 <<84301>>69810000
                                                                        69815000
move bdyln5b := bdyln1b, (70);                                 <<84301>>69820000
                                                                        69825000
move bdyln6b := bdyln1b, (70);                                 <<84301>>69830000
                                                                        69835000
move bdyln6b := bdyln1b, (70);                                 <<84301>>69840000
                                                                        69845000
move bdyln7b := bdyln1b, (70);                                 <<84301>>69850000
                                                                        69855000
move bdyln8b := bdyln1b, (70);                                 <<84301>>69860000
                                                                        69865000
                                                                        69870000
end;   << subroutine init'buffers >>                                    69875000
                                                                        69880000
                                                                        69885000
subroutine load'dataseg;                                                69890000
<<-------------------->>                                                69895000
   << move data segment to output buffers >>                            69900000
begin                                                                   69905000
                                                                        69910000
move bdyln1b:="* DB BANK =";                                   <<84301>>69915000
ascii(dbbankreg,8,bdyln1b(12));                                         69920000
bdyln1b(19) := "*";                                            <<84301>>69925000
if svdbbank <> dbbankreg then bdyln1b(18) := "#";              <<84301>>69930000
                                                                        69935000
move bdyln2b:="* DB      =";                                   <<84301>>69940000
ascii(dbreg,8,bdyln2b(12));                                             69945000
bdyln2b(19) := "*";                                            <<84301>>69950000
if svdbreg <> dbreg then bdyln2b(18) := "#";                   <<84301>>69955000
                                                                        69960000
move bdyln3b:="* S  BANK =";                                   <<84301>>69965000
ascii(zbankreg,8,bdyln3b(12));                                          69970000
bdyln3b(19) := "*";                                            <<84301>>69975000
if svsbank <> zbankreg then bdyln3b(18) := "#";                <<84301>>69980000
                                                                        69985000
move bdyln4b:="* DL      =";                                   <<84301>>69990000
ascii(dlreg,8,bdyln4b(12));                                             69995000
bdyln4b(19) := "*";                                            <<84301>>70000000
if svdlreg <> dlreg then bdyln4b(18) := "#";                   <<84301>>70005000
                                                                        70010000
move bdyln5b:="* Q       =";                                   <<84301>>70015000
ascii(qreg,8,bdyln5b(12));                                              70020000
bdyln5b(19) := "*";                                            <<84301>>70025000
if svqreg <> qreg then bdyln5b(18) := "#";                     <<84301>>70030000
                                                                        70035000
move bdyln6b:="* S       =";                                   <<84301>>70040000
ascii(sreg,8,bdyln6b(12));                                              70045000
bdyln6b(19) := "*";                                            <<84301>>70050000
if svsreg <> sreg then bdyln6b(18) := "#";                     <<84301>>70055000
                                                                        70060000
move bdyln7b:="* Z       =";                                   <<84301>>70065000
ascii(zreg,8,bdyln7b(12));                                              70070000
bdyln7b(19) := "*";                                            <<84301>>70075000
if svzreg <> zreg then bdyln7b(18) := "#";                     <<84301>>70080000
                                                                        70085000
bdyln8b := bdyln8b(19) := "*";                                 <<84301>>70090000
                                                                        70095000
end;  << subroutine load'dataseg >>                                     70100000
                                                                        70105000
                                                                        70110000
subroutine load'codeseg;                                                70115000
<<-------------------->>                                                70120000
  << move code segment to output buffers >>                             70125000
begin                                                                   70130000
                                                                        70135000
move bdyln1b(21) := "PB    =";                                 <<84301>>70140000
ascii(pbreg,8,bdyln1b(29));                                             70145000
bdyln1b(36) := "*";                                            <<84301>>70150000
if svpbreg <> pbreg then bdyln1b(35) := "#";                   <<84301>>70155000
                                                                        70160000
move bdyln2b(21) := "P     =";                                 <<84301>>70165000
ascii(preg,8,bdyln2b(29));                                              70170000
bdyln2b(36) := "*";                                            <<84301>>70175000
if svpreg <> preg then bdyln2b(35) := "#";                    <<850806>>70180000
                                                                        70185000
move bdyln3b(21) := "PL    =";                                 <<84301>>70190000
ascii(plreg,8,bdyln3b(29));                                             70195000
bdyln3b(36) := "*";                                            <<84301>>70200000
if svplreg <> plreg then bdyln3b(35) := "#";                  <<850806>>70205000
                                                                        70210000
move bdyln4b(21) := "PBBANK=";                                 <<84301>>70215000
ascii(pbbankreg,8,bdyln4b(29));                                         70220000
bdyln4b(36) := "*";                                            <<84301>>70225000
if svpbbank <> pbbankreg then bdyln4b(35) := "#";              <<84301>>70230000
                                                                        70235000
move bdyln5b(21) := "(P-PB)=";                                 <<84301>>70240000
ascii((preg-pbreg),8,bdyln5b(29));                                      70245000
bdyln5b(36) := "*";                                            <<84301>>70250000
                                                                        70255000
bdyln6b(36) := bdyln7b(36) := bdyln8b(36) := "*";              <<84301>>70260000
                                                                        70265000
end;  << subroutine load'codeseg >>                                     70270000
                                                                        70275000
                                                                        70280000
subroutine loadnump( bptr, num);                               <<*8993>>70285000
<<--------------------------->>                                <<*8993>>70290000
 << used to move segment no. from status reg. to output buff >><<*8993>>70295000
                                                               <<*8993>>70300000
   value bptr,num;                                             <<*8993>>70305000
   byte pointer bptr;                                          <<*8993>>70310000
   integer      num;                                           <<*8993>>70315000
begin                                                          <<*8993>>70320000
   @pbuf := @bptr;                                             <<*8993>>70325000
   putnump ( num);                                             <<*8993>>70330000
end;      << subroutine loadnump >>                            <<*8993>>70335000
                                                               <<*8993>>70340000
                                                               <<*8993>>70345000
subroutine load'miscregs;                                               70350000
<<--------------------->>                                               70355000
   <<  move miscellaneous registers to output buffers >>                70360000
begin                                                                   70365000
                                                                        70370000
move bdyln1b(38) := "X  =";                                    <<84301>>70375000
ascii(xreg,8,bdyln1b(43));                                              70380000
bdyln1b(50) := "*";                                            <<84301>>70385000
                                                                        70390000
move bdyln2b(38) := "CIR=";                                    <<84301>>70395000
ascii(cirreg,8,bdyln2b(43));                                            70400000
bdyln2b(50) := "*";                                            <<84301>>70405000
                                                                        70410000
case machineid of begin                                                 70415000
 << series ii >> begin                                                  70420000
                 move bdyln3b(37) := "CPX1=";                  <<84301>>70425000
                 ascii(cpx1,8,bdyln3b(43));                             70430000
                 bdyln3b(50) := "*";                           <<84301>>70435000
                                                                        70440000
                 move bdyln4b(37):="MSIZE=";                            70445000
                 ascii(memsize,8,bdyln4b(43));                          70450000
                 bdyln4b(50) := "*";                           <<84301>>70455000
                                                                        70460000
                 end;                                                   70465000
 << series iii>> begin                                                  70470000
                 move bdyln3b(37):="CPX1= ";                            70475000
                 ascii(cpx1,8,bdyln3b(43));                             70480000
                 bdyln3b(50) := "*";                           <<84301>>70485000
                                                                        70490000
                 move bdyln4b(37):="CPX2= ";                            70495000
                 ascii(cpx2,8,bdyln4b(43));                             70500000
                 bdyln4b(50) := "*";                           <<84301>>70505000
                                                                        70510000
                 end;                                                   70515000
                                                                        70520000
 << series 33 >> begin                                                  70525000
                 move bdyln3b(37):=" NIR= ";                            70530000
                 ascii(nir,8,bdyln3b(43));                              70535000
                 bdyln3b(50) := bdyln4b(50) := "*";            <<84301>>70540000
                 end;                                                   70545000
                                                                        70550000
 << series 44 >> begin                                                  70555000
                 move bdyln3b(37):=" NIR= ";                            70560000
                 ascii(nir,8,bdyln3b(43));                              70565000
                 bdyln3b(50) := bdyln4b(50) := "*";            <<84301>>70570000
                 end;                                                   70575000
                                                                        70580000
 << series 55 >> begin                                                  70585000
                 move bdyln3b(37):=" NIR= ";                            70590000
                 ascii(nir,8,bdyln3b(43));                              70595000
                 bdyln3b(50) := "*";                           <<84301>>70600000
                                                                        70605000
                 move bdyln4b(37):="CPX1= ";                            70610000
                 ascii(cpx1,8,bdyln4b(43));                             70615000
                 bdyln4b(50) := "*";                           <<84301>>70620000
                                                                        70625000
                 move bdyln5b(37):="CPX2= ";                            70630000
                 ascii(cpx2,8,bdyln5b(43));                             70635000
                 bdyln5b(50) := "*";                           <<84301>>70640000
                                                                        70645000
                 end;                                                   70650000
                                                                        70655000
                                                               <<*8993>>70660000
<< series 37 >> begin                                          <<*8993>>70665000
                move bdyln3b(37):=" NIR ";                     <<*8993>>70670000
                ascii(nir,8,bdyln3b(43));                      <<*8993>>70675000
                bdyln3b(50) := bdyln4b(50) := "*";             <<*8993>>70680000
                                                               <<*8993>>70685000
                move bdyln6b(37):=" UCODE VER=";               <<*8993>>70690000
                ascii(core(double(%1421)),8,bdyln7b(41));      <<*8993>>70695000
                move bdyln8b(37):=" STOP = 000";               <<*8993>>70700000
               loadnump(bdyln8b(42),core(double(%1422)).(8:8));<<*8993>>70705000
                end;                                           <<*8993>>70710000
                                                               <<*8993>>70715000
    end;   << case >>                                                   70720000
bdyln5b(50) := bdyln6b(50) := bdyln7b(50) :=                   <<84301>>70725000
               bdyln8b(50) := "*";                             <<84301>>70730000
     move bdyln6b(37):=" MAP= ";                                        70735000
     if core(%1220d) then move bdyln6b(42):=" ON"                       70740000
     else move bdyln6b(42):=" OFF";                                     70745000
end;  <<subroutine load'miscregs >>                                     70750000
                                                                        70755000
                                                               <<03013>>70760000
subroutine on'off (bptr, num);                                 <<03013>>70765000
<<--------------------------->>                                <<03013>>70770000
   << loads "ON" or "OFF" to output buffer depending on >>              70775000
   << the value of the number passed to this proc.      >>              70780000
                                                                        70785000
    value bptr,num;                                            <<03013>>70790000
    byte pointer bptr;                                         <<03013>>70795000
    integer      num;                                          <<03013>>70800000
begin                                                          <<03013>>70805000
    if num= 1                                                  <<03013>>70810000
    then move bptr := "ON "                                    <<03013>>70815000
    else move bptr := "OFF";                                   <<03013>>70820000
end;   << subroutine on'off >>                                 <<03013>>70825000
                                                               <<03013>>70830000
                                                                        70835000
subroutine load'status;                                                 70840000
<<------------------->>                                                 70845000
    << move status register to output buffers >>                        70850000
begin                                                                   70855000
                                                                        70860000
move bdyln1b(52) := "MODE      =";                             <<84301>>70865000
if stareg.(0:1)=1                                                       70870000
  then move bdyln1b(64):="PRIV"                                         70875000
  else move bdyln1b(64):="USER";                                        70880000
bdyln1b(69) := "*";                                            <<84301>>70885000
                                                                        70890000
move bdyln2b(52) := "INTERRUPTS=";                             <<84301>>70895000
on'off(bdyln2b(64),stareg.(1:1));                                       70900000
bdyln2b(69) := "*";                                            <<84301>>70905000
                                                                        70910000
move bdyln3b(52) := "TRAPS     =";                             <<84301>>70915000
on'off(bdyln3b(64),stareg.(2:1));                                       70920000
bdyln3b(69) := "*";                                            <<84301>>70925000
                                                                        70930000
move bdyln4b(52) := "STACK OP  =";                             <<84301>>70935000
if stareg.(3:1)=1                                                       70940000
  then move bdyln4b(64):="RGHT"                                         70945000
  else move bdyln4b(64):="LEFT";                                        70950000
bdyln4b(69) := "*";                                            <<84301>>70955000
                                                                        70960000
move bdyln5b(52) := "OVERFLOW  =";                             <<84301>>70965000
on'off(bdyln5b(64),stareg.(4:1));                                       70970000
bdyln5b(69) := "*";                                            <<84301>>70975000
                                                                        70980000
move bdyln6b(52) := "CARRY     =";                             <<84301>>70985000
on'off(bdyln6b(64),stareg.(5:1));                                       70990000
bdyln6b(69) := "*";                                            <<84301>>70995000
                                                                        71000000
move bdyln7b(52) := "COND CODE =";                             <<84301>>71005000
case stareg.(6:2) of                                                    71010000
    begin                                                               71015000
 << 0 >> move bdyln7b(64):="CCG";                                       71020000
 << 1 >> move bdyln7b(64):="CCL";                                       71025000
 << 2 >> move bdyln7b(64):="CCE";                                       71030000
    end;  << case >>                                                    71035000
bdyln7b(69) := "*";                                            <<84301>>71040000
                                                                        71045000
move bdyln8b(52) := "SEGMENT # =";                             <<84301>>71050000
loadnump(bdyln8b(64-3),seg);                                            71055000
loccst:=getdstaddr(1);                                        <<860213>>71060000
if pbbankreg=core(loccst+double(seg*4+2)) and                 <<860213>>71065000
   pbreg=core(loccst+double(seg*4+3)) then bdyln8b(67):="P"   <<860213>>71070000
else bdyln8b(67):="L";                                        <<860213>>71075000
dummy:=core(0d);       << reload corebuf >>                   <<860214>>71080000
bdyln8b(69) := "*";                                            <<84301>>71085000
                                                                        71090000
end; << subroutine load'status >>                                       71095000
                                                                        71100000
                                                                        71105000
subroutine prnt'regs'table;                                             71110000
<<---------------------->>                                              71115000
   << prints register table >>                                          71120000
begin                                                                   71125000
                                                                        71130000
<< clear out buffer >>                                                  71135000
buf:=" ";                                                      <<84301>>71140000
move buf(1):=buf,(69);                                                  71145000
                                                                        71150000
<< print table headings >>                                              71155000
move buf(18):="*****   REGISTERS   *****", 2;                  <<84301>>71160000
dummy := tos - @buf;                                           <<84301>>71165000
write'rec (prntfile, lbuf, -dummy, %40);                                71170000
if ctrly then go p'ctrl'y;                                    <<850830>>71175000
write'rec (prntfile, lbuf, 0, %40);                                     71180000
if ctrly then go p'ctrl'y;                                    <<850830>>71185000
                                                                        71190000
buf:=" ";                                                      <<84301>>71195000
move buf(1):=buf,(69);                                                  71200000
                                                                        71205000
move buf(22):="MPE ";                                            <<nsf>>71210000
ascii(mpeversion,10,buf(26));                                    <<nsf>>71215000
getcore(double(%1114),3,lbuf);                                   <<nsf>>71220000
move buf(28):="( .  .  ) (BASE  .  .  )";                        <<nsf>>71225000
move buf(29):=buf(5),(1);                                        <<nsf>>71230000
move buf(31):=buf(0),(2);                                        <<nsf>>71235000
move buf(34):=buf(2),(2);                                        <<nsf>>71240000
getcore(double(core(%1377d)+%1074),3,lbuf);                      <<nsf>>71245000
move buf(44):=buf(1),(1);                                        <<nsf>>71250000
move buf(46):=buf(2),(2);                                        <<nsf>>71255000
move buf(49):=buf(4),(2);                                        <<nsf>>71260000
move buf(0):=" ";                                                <<nsf>>71265000
move buf(1):=buf,(10);                                           <<nsf>>71270000
                                                                        71275000
move buf(54):="** SERIES ";                                             71280000
move buf(64):=seriesbuf(0),(3);                                         71285000
move buf(67):=" **";                                                    71290000
                                                                        71295000
getdate;                                                         <<nsf>>71300000
write'rec(prntfile,lbuf,-70,%40);                                       71305000
if ctrly then go p'ctrl'y;                                    <<850830>>71310000
                                                                        71315000
<< print the table >>                                                   71320000
write'rec(prntfile,outln,-70,%40);                                      71325000
if ctrly then go p'ctrl'y;                                    <<850830>>71330000
write'rec(prntfile,head,-70,%40);                                       71335000
if ctrly then go p'ctrl'y;                                    <<850830>>71340000
write'rec(prntfile,outln,-70,%40);                                      71345000
if ctrly then go p'ctrl'y;                                    <<850830>>71350000
write'rec(prntfile,bdyln1,-70,%40);                                     71355000
if ctrly then go p'ctrl'y;                                    <<850830>>71360000
write'rec(prntfile,bdyln2,-70,%40);                                     71365000
if ctrly then go p'ctrl'y;                                    <<850830>>71370000
write'rec(prntfile,bdyln3,-70,%40);                                     71375000
if ctrly then go p'ctrl'y;                                    <<850830>>71380000
write'rec(prntfile,bdyln4,-70,%40);                                     71385000
if ctrly then go p'ctrl'y;                                    <<850830>>71390000
write'rec(prntfile,bdyln5,-70,%40);                                     71395000
if ctrly then go p'ctrl'y;                                    <<850830>>71400000
write'rec(prntfile,bdyln6,-70,%40);                                     71405000
if ctrly then go p'ctrl'y;                                    <<850830>>71410000
write'rec(prntfile,bdyln7,-70,%40);                                     71415000
if ctrly then go p'ctrl'y;                                    <<850830>>71420000
write'rec(prntfile,bdyln8,-70,%40);                                     71425000
if ctrly then go p'ctrl'y;                                    <<850830>>71430000
write'rec(prntfile,outln,-70,%40);                                      71435000
if ctrly then go p'ctrl'y;                                    <<850830>>71440000
                                                                        71445000
<< clear buffer >>                                                      71450000
buf:=" ";                                                      <<84301>>71455000
move buf(1):=buf,(69);                                                  71460000
                                                                        71465000
<< print a comment concerning the shown values of regs. >>              71470000
move buf(6):="# - SIGNIFIES THAT VALUE SHOWN IS DIFFERENT", 2; <<84301>>71475000
dummy := tos - @buf;                                           <<84301>>71480000
write'rec (prntfile, lbuf, -dummy, %40);                                71485000
if ctrly then go p'ctrl'y;                                    <<850830>>71490000
                                                                        71495000
buf:=" ";                                                      <<84301>>71500000
move buf(1):=buf,(69);                                                  71505000
                                                                        71510000
move buf(10) := "FROM ORIGINAL VALUE OF REGISTER.", 2;         <<84301>>71515000
dummy := tos - @buf;                                           <<84301>>71520000
write'rec (prntfile, lbuf, -dummy, %40);                                71525000
if ctrly then go p'ctrl'y;                                    <<850830>>71530000
                                                                        71535000
end; <<subroutine prnt'regs'table >>                                    71540000
                                                                        71545000
subroutine overunder;                                                   71550000
<<----------------->>                                                   71555000
begin                                                                   71560000
if m25isr.(11:1) = 1 then begin                                         71565000
move bdyln4b(38) :="* == OVERFLOW ==";                                  71570000
end else                                                                71575000
move bdyln4b(38) :="* == UNDERFLOW ==";                                 71580000
end;                                                                    71585000
                                                                        71590000
subroutine ser'ii'iii;                                                  71595000
<<------------------>>                                                  71600000
begin                                                                   71605000
                                                                        71610000
move headb(0) := "*";                                                   71615000
move headb(35):= "C P X 1";                                             71620000
move headb(77):= "*";                                                   71625000
move bdyln1b(0) := "* INTEGER OVERFL";                                  71630000
move bdyln1b(25):= "=";                                                 71635000
move bdyln1b(38):= "* EXTERNAL INTERRUPT";                              71640000
move bdyln1b(63):= "=";                                                 71645000
move bdyln1b(77):= "*";                                                 71650000
                                                                        71655000
move bdyln2b(0) := "* BOUNDS VIOLATION";                                71660000
move bdyln2b(25):= "=";                                                 71665000
move bdyln2b(38):= "* POWER FAIL INT.";                                 71670000
move bdyln2b(63):= "=";                                                 71675000
move bdyln2b(77):= "*";                                                 71680000
                                                                        71685000
move bdyln3b(0) := "* ILLEGAL ADDRESS";                                 71690000
move bdyln3b(25):= "=";                                                 71695000
move bdyln3b(38):= "*";                                                 71700000
move bdyln3b(77):= "*";                                                 71705000
                                                                        71710000
move bdyln4b(0) := "* CPU TIMER";                                       71715000
move bdyln4b(25):= "=";                                                 71720000
move bdyln4b(38):= "* ICS FLAG";                                        71725000
move bdyln4b(63):= "=";                                                 71730000
move bdyln4b(77):= "*";                                                 71735000
                                                                        71740000
                                                                        71745000
move bdyln5b(0) := "* SYS. PARITY ERROR";                               71750000
move bdyln5b(25):= "=";                                                 71755000
move bdyln5b(38):= "* DISPATCHER FLAG";                                 71760000
move bdyln5b(63):= "=";                                                 71765000
move bdyln5b(77):= "*";                                                 71770000
                                                                        71775000
move bdyln6b(0) := "* ADDR. PARITY ERROR";                              71780000
move bdyln6b(25):= "=";                                                 71785000
move bdyln6b(38):= "* EMULATOR";                                        71790000
move bdyln6b(63):= "=";                                                 71795000
move bdyln6b(77):= "*";                                                 71800000
                                                                        71805000
move bdyln7b(0) := "* DATA PARITY ERROR";                               71810000
move bdyln7b(25):= "=";                                                 71815000
move bdyln7b(38):= "* I/O TIMER";                                       71820000
move bdyln7b(63):= "=";                                                 71825000
move bdyln7b(77):= "*";                                                 71830000
                                                                        71835000
move bdyln8b(0) := "* MODULE INTERRUPT";                                71840000
move bdyln8b(25):= "=";                                                 71845000
move bdyln8b(38):= "* OPTION PRESENT";                                  71850000
move bdyln8b(63):= "=";                                                 71855000
move bdyln8b(77):= "*";                                                 71860000
                                                                        71865000
dummy:=core(0d);      << ensure corebuf is loaded right >>    <<860214>>71870000
on'off (bdyln1b(27),m25isr.(0:1));                                      71875000
on'off (bdyln1b(65),m25isr.(8:1));                                      71880000
on'off (bdyln2b(27),m25isr.(1:1));                                      71885000
on'off (bdyln2b(65),m25isr.(9:1));                                      71890000
on'off (bdyln3b(27),m25isr.(2:1));                                      71895000
on'off (bdyln4b(27),m25isr.(3:1));                                      71900000
on'off (bdyln4b(65),m25isr.(11:1));                                     71905000
on'off (bdyln5b(27),m25isr.(4:1));                                      71910000
on'off (bdyln5b(65),m25isr.(12:1));                                     71915000
on'off (bdyln6b(27),m25isr.(5:1));                                      71920000
on'off (bdyln6b(65),m25isr.(13:1));                                     71925000
on'off (bdyln7b(27),m25isr.(6:1));                                      71930000
on'off (bdyln7b(65),m25isr.(14:1));                                     71935000
on'off (bdyln8b(27),m25isr.(7:1));                                      71940000
on'off (bdyln8b(65),m25isr.(15:1));                                     71945000
                                                                        71950000
end;                                                                    71955000
                                                                        71960000
                                                                        71965000
                                                                        71970000
subroutine fmt'isr'cpx;                                                 71975000
<<------------------->>                                                 71980000
   << formats and prints the isr/sir/cpx1/cpx2 >>                       71985000
   << depending on machine type >>                                      71990000
begin                                                                   71995000
move head(0)  := "  ";       << blank out display >>                    72000000
move head(1)  := head(0),(38);                                          72005000
move bdyln1   := head(0),(39);                                          72010000
move bdyln2   := head(0),(39);                                          72015000
move bdyln3   := head(0),(39);                                          72020000
move bdyln4   := head(0),(39);                                          72025000
move bdyln5   := head(0),(39);                                          72030000
move bdyln6   := head(0),(39);                                          72035000
move bdyln7   := head(0),(39);                                          72040000
move bdyln8   := head(0),(39);                                          72045000
                                                                        72050000
case machineid of begin                                                 72055000
<< s ii  >> begin                                                       72060000
                                                                        72065000
            ser'ii'iii;                                                 72070000
                                                                        72075000
            end;                                                        72080000
<< s iii >> begin                                                       72085000
                                                                        72090000
            ser'ii'iii;                                                 72095000
                                                                        72100000
            end;                                                        72105000
<< s 33  >> begin                                                       72110000
                                                                        72115000
move headb(0) := "*";                                                   72120000
move headb(35):= "I S R";                                               72125000
move headb(77):= "*";                                                   72130000
move bdyln1b(0) := "* I/O REQUEST INT.";                                72135000
move bdyln1b(25):= "=";                                                 72140000
move bdyln1b(38):= "* HALT FLIPFLOP";                                   72145000
move bdyln1b(63):= "=";                                                 72150000
move bdyln1b(77):= "*";                                                 72155000
                                                                        72160000
move bdyln2b(0) := "* CHANNEL SERVICE REQ.";                            72165000
move bdyln2b(25):= "=";                                                 72170000
move bdyln2b(38):= "* DISABLE ATTN. FLAG";                              72175000
move bdyln2b(63):= "=";                                                 72180000
move bdyln2b(77):= "*";                                                 72185000
                                                                        72190000
move bdyln3b(0) := "* NON RESPOND. DEVICE ";                            72195000
move bdyln3b(25):= "=";                                                 72200000
move bdyln3b(38):= "* STKOVERFL. INDICATOR";                            72205000
move bdyln3b(63):= "=";                                                 72210000
move bdyln3b(77):= "*";                                                 72215000
                                                                        72220000
move bdyln4b(0) := "* PARITY ERROR";                                    72225000
move bdyln4b(25):= "=";                                                 72230000
move bdyln4b(38):= "* OVERFLOW/UNDERFLOW";                              72235000
move bdyln4b(63):= "=";                                                 72240000
move bdyln4b(77):= "*";                                                 72245000
                                                                        72250000
move bdyln5b(0) := "* POWER FAIL";                                      72255000
move bdyln5b(25):= "=";                                                 72260000
move bdyln5b(38):= "* BOUNDS VIOLATION";                                72265000
move bdyln5b(63):= "=";                                                 72270000
move bdyln5b(77):= "*";                                                 72275000
                                                                        72280000
move bdyln6b(0) := "* POWER ON";                                        72285000
move bdyln6b(25):= "=";                                                 72290000
move bdyln6b(38):= "*                 ";                                72295000
move bdyln6b(63):= "=";                                                 72300000
move bdyln6b(77):= "*";                                                 72305000
                                                                        72310000
move bdyln7b(0) := "* SRST,SYSTEM RESET";                               72315000
move bdyln7b(25):= "=";                                                 72320000
move bdyln7b(38):= "* DISPATCHER FLAG";                                 72325000
move bdyln7b(63):= "=";                                                 72330000
move bdyln7b(77):= "*";                                                 72335000
                                                                        72340000
move bdyln8b(0) := "* CPU DONE, IMB FF";                                72345000
move bdyln8b(25):= "=";                                                 72350000
move bdyln8b(38):= "* ICS FLAG";                                        72355000
move bdyln8b(63):= "=";                                                 72360000
move bdyln8b(77):= "*";                                                 72365000
                                                                        72370000
dummy:=core(0d);    << ensure corebuf is loaded right >>      <<860214>>72375000
case m25isr.(12:2) of begin                                             72380000
<< 0 >> begin                                                           72385000
        on'off (bdyln5b(65),m25isr.(12:1));                             72390000
        end;                                                            72395000
<< 1 >> begin                                                           72400000
on'off (bdyln5b(65),m25isr.(13:1));                                     72405000
move bdyln6b(38) :="* == STCK STACK ERROR ==";                          72410000
overunder;                                                              72415000
        end;                                                            72420000
                                                                        72425000
<< 2 >> begin                                                           72430000
on'off (bdyln5b(65),m25isr.(12:1));                                     72435000
move bdyln6b(38) :="* == DRCK/SRCK DATA ERROR ==";                      72440000
overunder;                                                              72445000
        end;                                                            72450000
                                                                        72455000
<< 3 >> begin                                                           72460000
on'off (bdyln5b(65),m25isr.(13:1));                                     72465000
move bdyln6b(38) :="* == PRCK PROGRAM ERROR ==";                        72470000
overunder;                                                              72475000
        end;                                                            72480000
end;  << end case >>                                                    72485000
                                                                        72490000
on'off (bdyln1b(27),m25isr.(0:1));                                      72495000
if m25isr.(8:1) = 0 then move bdyln1b(65):="RUN"              <<860214>>72500000
else move bdyln1b(65):="HALT";                                <<860214>>72505000
on'off (bdyln2b(27),m25isr.(1:1));                                      72510000
on'off (bdyln2b(65),m25isr.(9:1));                                      72515000
on'off (bdyln3b(27),m25isr.(2:1));                                      72520000
on'off (bdyln3b(65),m25isr.(10:1));                                     72525000
on'off (bdyln4b(27),m25isr.(3:1));                                      72530000
on'off (bdyln5b(27),m25isr.(4:1));                                      72535000
on'off (bdyln6b(27),m25isr.(5:1));                                      72540000
on'off (bdyln7b(27),m25isr.(6:1));                                      72545000
on'off (bdyln7b(65),m25isr.(14:1));                                     72550000
on'off (bdyln8b(27),m25isr.(7:1));                                      72555000
on'off (bdyln8b(65),m25isr.(15:1));                                     72560000
                                                                        72565000
            end;                                                        72570000
<< s 44  >> begin                                                       72575000
                                                                        72580000
dummy:=core(0d);     << ensure corebuf is loaded right >>     <<860214>>72585000
move headb(0) := "*";                                                   72590000
move headb(30):= "S I R =";                                   <<860214>>72595000
ascii(m25isr,8,headb(38));                                    <<860214>>72600000
move headb(77):= "*";                                                   72605000
move bdyln1b(0) := "* SYSTEM RESET";                                    72610000
move bdyln1b(25):= "=";                                                 72615000
move bdyln1b(38):= "* NON RESPOND. DEVICE";                             72620000
move bdyln1b(63):= "=";                                                 72625000
move bdyln1b(77):= "*";                                                 72630000
                                                                        72635000
move bdyln2b(0) := "* SYSTEM CLOCK";                                    72640000
move bdyln2b(25):= "=";                                                 72645000
move bdyln2b(38):= "* RUN/HALT FOR CMP";                                72650000
move bdyln2b(63):= "=";                                                 72655000
move bdyln2b(77):= "*";                                                 72660000
                                                                        72665000
move bdyln3b(0) := "* CHANNEL SERVICE REQ.";                            72670000
move bdyln3b(25):= "=";                                                 72675000
move bdyln3b(38):= "* DISABLE ATTN. FLAG";                              72680000
move bdyln3b(63):= "=";                                                 72685000
move bdyln3b(77):= "*";                                                 72690000
                                                                        72695000
move bdyln4b(0) := "* EXTERNAL INTERRUPT";                              72700000
move bdyln4b(25):= "=";                                                 72705000
move bdyln4b(38):= "* DATA NOT VALID ON IMB";                           72710000
move bdyln4b(63):= "=";                                                 72715000
move bdyln4b(77):= "*";                                                 72720000
                                                                        72725000
move bdyln5b(0) := "* POWER ON";                                        72730000
move bdyln5b(25):= "=";                                                 72735000
move bdyln5b(38):= "* DISPATCHER FLAG";                       <<860213>>72740000
move bdyln5b(63):= "=";                                                 72745000
move bdyln5b(77):= "*";                                                 72750000
                                                                        72755000
move bdyln6b(0) := "* POWER FAIL WARNING";                              72760000
move bdyln6b(25):= "=";                                                 72765000
move bdyln6b(38):= "* ICS FLAG";                              <<860213>>72770000
move bdyln6b(63):= "=";                                                 72775000
move bdyln6b(77):= "*";                                                 72780000
                                                                        72785000
move bdyln7b(0) := "* INTEGER OVERFLOW";                                72790000
move bdyln7b(25):= "=";                                                 72795000
move bdyln7b(38):= "* SPLIT STACK MODE";                                72800000
move bdyln7b(63):= "=";                                                 72805000
move bdyln7b(77):= "*";                                                 72810000
                                                                        72815000
move bdyln8b(0) := "* MEMORY PARITY ERROR";                             72820000
move bdyln8b(25):= "=";                                                 72825000
move bdyln8b(38):= "* RUN/HALT";                                        72830000
move bdyln8b(63):= "=";                                                 72835000
move bdyln8b(77):= "*";                                                 72840000
                                                                        72845000
on'off (bdyln1b(27),m25isr.(0:1));                                      72850000
on'off (bdyln1b(65),m25isr.(8:1));                                      72855000
on'off (bdyln2b(27),m25isr.(1:1));                                      72860000
on'off (bdyln2b(65),m25isr.(9:1));                                      72865000
on'off (bdyln3b(27),m25isr.(2:1));                                      72870000
on'off (bdyln3b(65),m25isr.(10:1));                                     72875000
on'off (bdyln4b(27),m25isr.(3:1));                                      72880000
on'off (bdyln4b(65),m25isr.(11:1));                                     72885000
on'off (bdyln5b(27),m25isr.(4:1));                                      72890000
if m25isr.(12:1) = 1 then on'off(bdyln5b(65),0)               <<860213>>72895000
else on'off(bdyln5b(65),1);  <<negative logic>>               <<860213>>72900000
on'off (bdyln6b(27),m25isr.(5:1));                                      72905000
if m25isr.(13:1) = 1 then on'off(bdyln6b(65),0)               <<860213>>72910000
else on'off(bdyln6b(65),1);  <<negative logic>>               <<860213>>72915000
on'off (bdyln7b(27),m25isr.(6:1));                                      72920000
if m25isr.(14:1) = 1 then on'off(bdyln7b(65),0)               <<860213>>72925000
else on'off(bdyln7b(65),1);   <<negative logic>>              <<860213>>72930000
on'off (bdyln8b(27),m25isr.(7:1));                                      72935000
if m25isr.(15:1) = 0 then move bdyln8b(65):="RUN"             <<860213>>72940000
else move bdyln8b(65):="HALT";                                <<860213>>72945000
                                                                        72950000
                                                                        72955000
            end;                                                        72960000
<< s 55  >> begin                                                       72965000
                                                                        72970000
move headb(0)  :="*";  <<  header line  >>                              72975000
move headb(15) :="CPX1";                                                72980000
move headb(38) :="*";                                                   72985000
move headb(50) :="CPX2";                                                72990000
move headb(77) :="*";                                                   72995000
move bdyln1b(0) :="*";  << display lines >>                             73000000
move bdyln1b(19):="* DCU-INT.   =     ";                                73005000
move bdyln1b(38):="* POWER ON   =     ";                                73010000
move bdyln1b(57):="* VIRT.PAGE FL=     ";                               73015000
move bdyln1b(77):="*";                                                  73020000
                                                                        73025000
move bdyln2b(0) :="* OVERFLOW   =     ";                                73030000
move bdyln2b(19):="* MSG-INT.   =     ";                                73035000
move bdyln2b(38):="*";                                                  73040000
move bdyln2b(57):="* CACHE ERROR =     ";                               73045000
move bdyln2b(77):="*";                                                  73050000
                                                                        73055000
move bdyln3b(0) :="* BOUNDS VIOL=     ";                                73060000
move bdyln3b(19):="* CBI-INT.   =     ";                                73065000
move bdyln3b(38):="* PAUSE      =     ";                                73070000
move bdyln3b(57):="* RUN MODE DIS=     *";                              73075000
                                                                        73080000
move bdyln4b(0) :="* WCS PAR.ERR=     ";                                73085000
move bdyln4b(19):="* BREAKP.INT.=     ";                                73090000
move bdyln4b(38):="* ICS        =     ";                                73095000
move bdyln4b(57):="* CACHE BACK  =     *";                              73100000
                                                                        73105000
move bdyln5b(0) :="* RUN/HALT   =     ";                                73110000
move bdyln5b(19):="* PFW        =     ";                                73115000
move bdyln5b(38):="* DIAG.MINSTR=     ";                                73120000
move bdyln5b(57):="* CACHE DIAGN.=     *";                              73125000
                                                                        73130000
move bdyln6b(0) :="* LUT PAR.ERR=     ";                                73135000
move bdyln6b(19):="*";                                                  73140000
move bdyln6b(38):="*";                                                  73145000
move bdyln6b(57):="*";                                                  73150000
move bdyln6b(77):="*";                                                  73155000
                                                                        73160000
move bdyln7b(0) :="* SYSCLCK INT=     ";                                73165000
move bdyln7b(19):="*";                                                  73170000
move bdyln7b(38):="* RUN MODE EN=     ";                                73175000
move bdyln7b(57):="* PF DISABLE  =     *";                              73180000
                                                                        73185000
move bdyln8b(0) :="* CPUCLCK INT=     ";                                73190000
move bdyln8b(19):="*";                                                  73195000
move bdyln8b(38):="* DISPATCHER =     ";                                73200000
move bdyln8b(57):="* DEFERRED INT=     *";                              73205000
                                                                        73210000
<< set on/off in display >>                                             73215000
                                                                        73220000
dummy:=core(0d);      << ensure corebuf is loaded right >>    <<860214>>73225000
on'off (bdyln2b(15),cpx1.(1:1));                                        73230000
on'off (bdyln3b(15),cpx1.(2:1));                                        73235000
on'off (bdyln4b(15),cpx1.(3:1));                                        73240000
on'off (bdyln5b(15),cpx1.(4:1));                                        73245000
on'off (bdyln6b(15),cpx1.(5:1));                                        73250000
on'off (bdyln7b(15),cpx1.(6:1));                                        73255000
on'off (bdyln8b(15),cpx1.(7:1));                                        73260000
on'off (bdyln1b(34),cpx1.(8:1));                                        73265000
on'off (bdyln2b(34),cpx1.(9:1));                                        73270000
on'off (bdyln3b(34),cpx1.(10:1));                                       73275000
on'off (bdyln4b(34),cpx1.(11:1));                                       73280000
on'off (bdyln5b(34),cpx1.(12:1));                                       73285000
                                                                        73290000
on'off (bdyln1b(53),cpx2.(0:1));                                        73295000
on'off (bdyln3b(53),cpx2.(2:1));                                        73300000
on'off (bdyln4b(53),cpx2.(3:1));                                        73305000
on'off (bdyln5b(53),cpx2.(4:1));                                        73310000
on'off (bdyln6b(53),cpx2.(5:1));                                        73315000
on'off (bdyln7b(53),cpx2.(6:1));                                        73320000
on'off (bdyln8b(53),cpx2.(7:1));                                        73325000
on'off (bdyln1b(73),cpx2.(8:1));                                        73330000
on'off (bdyln2b(73),cpx2.(9:1));                                        73335000
on'off (bdyln3b(73),cpx2.(10:1));                                       73340000
on'off (bdyln4b(73),cpx2.(11:1));                                       73345000
on'off (bdyln5b(73),cpx2.(12:1));                                       73350000
on'off (bdyln7b(73),cpx2.(14:1));                                       73355000
on'off (bdyln8b(73),cpx2.(15:1));                                       73360000
                                                                        73365000
                                                                        73370000
end;                                                                    73375000
                                                                        73380000
<< s 37 >>  begin                                             <<860213>>73385000
                                                              <<860213>>73390000
end;                                                          <<860213>>73395000
                                                                        73400000
end;     <<  end case  >>                                               73405000
                                                                        73410000
<< print cpx1/cpx2/isr/sir- table   >>                                  73415000
write'rec(prntfile,outln,-78,%40);                                      73420000
if ctrly then go p'ctrl'y;                                    <<850830>>73425000
write'rec(prntfile,head,-78,%40);                                       73430000
if ctrly then go p'ctrl'y;                                    <<850830>>73435000
write'rec(prntfile,outln,-78,%40);                                      73440000
if ctrly then go p'ctrl'y;                                    <<850830>>73445000
write'rec(prntfile,bdyln1,-78,%40);                                     73450000
if ctrly then go p'ctrl'y;                                    <<850830>>73455000
write'rec(prntfile,bdyln2,-78,%40);                                     73460000
if ctrly then go p'ctrl'y;                                    <<850830>>73465000
write'rec(prntfile,bdyln3,-78,%40);                                     73470000
if ctrly then go p'ctrl'y;                                    <<850830>>73475000
write'rec(prntfile,bdyln4,-78,%40);                                     73480000
if ctrly then go p'ctrl'y;                                    <<850830>>73485000
write'rec(prntfile,bdyln5,-78,%40);                                     73490000
if ctrly then go p'ctrl'y;                                    <<850830>>73495000
write'rec(prntfile,bdyln6,-78,%40);                                     73500000
if ctrly then go p'ctrl'y;                                    <<850830>>73505000
write'rec(prntfile,bdyln7,-78,%40);                                     73510000
if ctrly then go p'ctrl'y;                                    <<850830>>73515000
write'rec(prntfile,bdyln8,-78,%40);                                     73520000
if ctrly then go p'ctrl'y;                                    <<850830>>73525000
write'rec(prntfile,outln,-78,%40);                                      73530000
if ctrly then go p'ctrl'y;                                    <<850830>>73535000
                                                                        73540000
end;   << subroutine fmt'isr'cpx >>                                     73545000
                                                                        73550000
subroutine fmt'flm;                                                     73555000
<<--------------->>                                                     73560000
   << formats and prints the first %11 words of fixed >>                73565000
   << low memory.                                     >>                73570000
begin                                                                   73575000
                                                                        73580000
dummy:=core(0d);  <<use core to load corebuf, used frequently>>         73585000
                                                                        73590000
<< line 1 (blank) >>                                                    73595000
buf:=" ";                                                      <<84301>>73600000
move buf(1):=buf,(69);                                                  73605000
write'rec (prntfile, lbuf, 0, %40);                                     73610000
if ctrly then go p'ctrl'y;                                    <<850830>>73615000
                                                                        73620000
<< line 2 >>                                                            73625000
buf:=" ";                                                      <<84301>>73630000
move buf(1):=buf,(69);                                                  73635000
move buf := "***** FIXED LOW MEMORY *****", 2;                 <<84301>>73640000
dummy := tos - @buf;                                           <<84301>>73645000
write'rec (prntfile, lbuf, -dummy, %40);                                73650000
if ctrly then go p'ctrl'y;                                    <<850830>>73655000
                                                                        73660000
                                                                        73665000
<< line 3 >>                                                            73670000
buf := " ";                                                    <<84301>>73675000
move buf(1) := buf, (69);                                      <<84301>>73680000
move buf(2) := "(@% 0) CST  PTR";                              <<84301>>73685000
ascii(corebuf(0),8,buf(24));                                            73690000
move buf(37) := "(@% 5) ICS QI";                               <<84301>>73695000
ascii(corebuf(5),8,buf(64));                                            73700000
write'rec(prntfile,lbuf,-70,%40);                                       73705000
if ctrly then go p'ctrl'y;                                    <<850830>>73710000
                                                                        73715000
<< line 4 >>                                                            73720000
buf := " ";                                                    <<84301>>73725000
move buf(1) := buf, (69);                                      <<84301>>73730000
move buf(2) := "(@% 1) XCST PTR";                              <<84301>>73735000
ascii(corebuf(1),8,buf(24));                                            73740000
move buf(37) := "(@% 6) ICS ZI";                               <<84301>>73745000
ascii(corebuf(6),8,buf(64));                                            73750000
write'rec(prntfile,lbuf,-70,%40);                                       73755000
if ctrly then go p'ctrl'y;                                    <<850830>>73760000
                                                                        73765000
<< line 5 >>                                                            73770000
buf := " ";                                                    <<84301>>73775000
move buf(1) := buf, (69);                                      <<84301>>73780000
move buf(2) := "(@% 2) DST  PTR";                              <<84301>>73785000
ascii(corebuf(2),8,buf(24));                                            73790000
move buf(37) := "(@% 7) INTERRUPT MASK";                       <<84301>>73795000
ascii(corebuf(7),8,buf(64));                                            73800000
write'rec(prntfile,lbuf,-70,%40);                                       73805000
if ctrly then go p'ctrl'y;                                    <<850830>>73810000
                                                                        73815000
<< line 6 >>                                                            73820000
buf := " ";                                                    <<84301>>73825000
move buf(1) := buf, (69);                                      <<84301>>73830000
if mpeve then                                                           73835000
move buf(2) := "(@% 3) NOT USED(MPEVE)"                                 73840000
else                                                                    73845000
move buf(2) := "(@% 3) PCB BASE";                              <<84301>>73850000
ascii(corebuf(3),8,buf(24));                                            73855000
move buf(37) := "(@%10) DRT BANK";                             <<84301>>73860000
ascii(corebuf(%10),8,buf(64));                                          73865000
write'rec(prntfile,lbuf,-70,%40);                                       73870000
if ctrly then go p'ctrl'y;                                    <<850830>>73875000
                                                                        73880000
<< line 7 >>                                                            73885000
buf := " ";                                                    <<84301>>73890000
move buf(1) := buf, (69);                                      <<84301>>73895000
if mpeve then                                                           73900000
move buf(2) := "(@% 4) CPCB INDEX REL"                                  73905000
else                                                                    73910000
move buf(2) := "(@% 4) CPCB PTR";                              <<84301>>73915000
ascii(corebuf(4),8,buf(24));                                            73920000
move buf(37) := "(@%11) DRT ADDR";                             <<84301>>73925000
ascii(corebuf(%11),8,buf(64));                                          73930000
write'rec(prntfile,lbuf,-70,%40);                                       73935000
if ctrly then go p'ctrl'y;                                    <<850830>>73940000
                                                                 <<nsf>>73945000
                                                                        73950000
end;  << subroutine fmt'flm >>                                          73955000
                                                                        73960000
subroutine fmt'sysgl;                                                   73965000
                                                                        73970000
                                                                        73975000
                                                                        73980000
   << formats and prints the first %11 words of       >>                73985000
   << sysglobal.                                      >>                73990000
begin                                                                   73995000
                                                                        74000000
dummy:=core(0d);  <<use core to load corebuf, used frequently>>         74005000
                                                                        74010000
<< line 1 (blank) >>                                                    74015000
move buf:=" ";                                                          74020000
move buf(1):=buf,(69);                                                  74025000
write'rec(prntfile,lbuf,-70,%40);                                       74030000
if ctrly then go p'ctrl'y;                                    <<850830>>74035000
                                                                        74040000
<< line 2 >>                                                            74045000
move buf:=" ";                                                          74050000
move buf(1):=buf,(69);                                                  74055000
move buf:="***** SYSGLOB (%1000)  *****";                               74060000
write'rec(prntfile,lbuf,-70,%40);                                       74065000
if ctrly then go p'ctrl'y;                                    <<850830>>74070000
                                                                        74075000
                                                                        74080000
<< line 3 >>                                                            74085000
move buf:=("  (+%0) SGLOB-SBASE",7(" "));                               74090000
ascii(corebuf(%1000),8,buf(24));                                        74095000
move buf(30):=(7(" "),"(+% 5) IOQBASE-REL",8(" "));                     74100000
ascii(corebuf(%1005),8,buf(64));                                        74105000
write'rec(prntfile,lbuf,-70,%40);                                       74110000
if ctrly then go p'ctrl'y;                                    <<850830>>74115000
                                                                        74120000
<< line 4 >>                                                            74125000
move buf:=("  (+%1) CST BASE-REL",6(" "));                              74130000
ascii(corebuf(%1001),8,buf(24));                                        74135000
move buf(30):=(7(" "),"(+% 6) SBUF-REL",11(" "));                       74140000
ascii(corebuf(%1006),8,buf(64));                                        74145000
write'rec(prntfile,lbuf,-70,%40);                                       74150000
if ctrly then go p'ctrl'y;                                    <<850830>>74155000
                                                                        74160000
<< line 5 >>                                                            74165000
move buf:=("  (+%2) DST BASE-REL",6(" "));                              74170000
ascii(corebuf(%1002),8,buf(24));                                        74175000
move buf(30):=(7(" "),"(+% 7) ICS-QI REL",9(" "));                      74180000
ascii(corebuf(%1007),8,buf(64));                                        74185000
write'rec(prntfile,lbuf,-70,%40);                                       74190000
if ctrly then go p'ctrl'y;                                    <<850830>>74195000
                                                                        74200000
<< line 6 >>                                                            74205000
move buf:=("  (+%3) PCB BASE-REL",6(" "));                              74210000
ascii(corebuf(%1003),8,buf(24));                                        74215000
move buf(30):=(7(" "),"(+%10) LPDT BASE-REL",7(" "));                   74220000
ascii(corebuf(%1010),8,buf(64));                                        74225000
write'rec(prntfile,lbuf,-70,%40);                                       74230000
if ctrly then go p'ctrl'y;                                    <<850830>>74235000
                                                                        74240000
<< line 7 >>                                                            74245000
if mpeve then                                                           74250000
move buf:=("  (+%4) SWAPTAB BASE-REL  ")                                74255000
else                                                                    74260000
move buf:=("  (+%4) ARSBM BASE-REL",4(" "));                            74265000
ascii(corebuf(%1004),8,buf(24));                                        74270000
if mpeve then                                                           74275000
move buf(30):=(7(" "),"(+%11) SMON  BASE-REL",5(" "))                   74280000
else                                                                    74285000
move buf(30):=(7(" "),"(+%11) STOPS BASE-REL",5(" "));                  74290000
ascii(corebuf(%1011),8,buf(64));                                        74295000
write'rec(prntfile,lbuf,-70,%40);                                       74300000
if ctrly then go p'ctrl'y;                                    <<850830>>74305000
                                                                        74310000
end;  << subroutine fmt'sysgl >>                                        74315000
                                                                        74320000
subroutine fmt'imb;                                              <<nsf>>74325000
<<------------------>>                                           <<nsf>>74330000
begin                                                            <<nsf>>74335000
                                                                 <<nsf>>74340000
case machineid of begin                                          <<nsf>>74345000
                                                                 <<nsf>>74350000
  << series  ii >>  ;                                            <<nsf>>74355000
  << series iii >>  ;                                            <<nsf>>74360000
  << series  33 >>  ;                                            <<nsf>>74365000
  << series  44 >>  ;                                            <<nsf>>74370000
  << series  64 >>  begin                                        <<nsf>>74375000
                                                                 <<nsf>>74380000
     move buf:=" ";                                              <<nsf>>74385000
     move buf(1):=buf,(69);                                      <<nsf>>74390000
     write'rec(prntfile,lbuf,0,%40);                             <<nsf>>74395000
if ctrly then go p'ctrl'y;                                    <<850830>>74400000
                                                                 <<nsf>>74405000
     move buf:=("  (@%32) IMB-0   ",7(" "));                     <<nsf>>74410000
     ascii(corebuf(%32),8,buf(24));                              <<nsf>>74415000
     write'rec(prntfile,lbuf,-70,%40);                           <<nsf>>74420000
if ctrly then go p'ctrl'y;                                    <<850830>>74425000
                                                                 <<nsf>>74430000
     move buf:=("  (@%33) IMB-1   ",7(" "));                     <<nsf>>74435000
     ascii(corebuf(%33),8,buf(24));                              <<nsf>>74440000
     write'rec(prntfile,lbuf,-70,%40);                           <<nsf>>74445000
if ctrly then go p'ctrl'y;                                    <<850830>>74450000
                                                                 <<nsf>>74455000
     move buf:=("  (@%34) IMB-2   ",7(" "));                     <<nsf>>74460000
     ascii(corebuf(%34),8,buf(24));                              <<nsf>>74465000
     write'rec(prntfile,lbuf,-70,%40);                           <<nsf>>74470000
if ctrly then go p'ctrl'y;                                    <<850830>>74475000
                                                                 <<nsf>>74480000
     move buf:=("  (@%35) IMB-3   ",7(" "));                     <<nsf>>74485000
     ascii(corebuf(%35),8,buf(24));                              <<nsf>>74490000
     write'rec(prntfile,lbuf,-70,%40);                           <<nsf>>74495000
if ctrly then go p'ctrl'y;                                    <<850830>>74500000
                                                                 <<nsf>>74505000
     end;                                                        <<nsf>>74510000
  end;  << case >>                                               <<nsf>>74515000
                                                                 <<nsf>>74520000
end;  << fmt'imb >>                                              <<nsf>>74525000
                                                                 <<nsf>>74530000
<<---------------------->>                                              74535000
<< mainline for fmtregs >>                                              74540000
<<---------------------->>                                              74545000
                                                                        74550000
init'buffers;  << initialize specific buffers >>                        74555000
                                                                        74560000
load'dataseg;  << prepare data regs for printing >>                     74565000
                                                                        74570000
load'codeseg;  << prepare code regs. for printing >>                    74575000
                                                                        74580000
load'miscregs; << prepare other regs. for printing >>                   74585000
                                                                        74590000
load'status;   << prepare status for printing >>                        74595000
                                                                        74600000
prnt'regs'table;<< print register table >>                              74605000
                                                                        74610000
fmt'isr'cpx;    << print isr/sir/cpx1/cpx2 table >>                     74615000
                                                                        74620000
if stop'print then return;                                              74625000
                                                                        74630000
fmt'flm;        << prints 1st 9 words of fixed low memory >>            74635000
                                                                        74640000
fmt'sysgl;      << prints 1st 9 words of sysglobal >>                   74645000
                                                                        74650000
fmt'imb;        << prints imb-0 through imb-3 >>                        74655000
                                                                        74660000
go reg'done;                                                  <<850830>>74665000
                                                              <<850830>>74670000
p'ctrl'y:                                                     <<850830>>74675000
                                                              <<850830>>74680000
move buf:=" <CONTROL-Y>";                                     <<850830>>74685000
write'rec(prntfile,lbuf,0,0);                                 <<850830>>74690000
write'rec(prntfile,lbuf,-12,%60);                             <<850830>>74695000
                                                              <<850830>>74700000
reg'done:                                                     <<850830>>74705000
end; <<fmtregs>>                                                        74710000
$page "                         PROCEDURE GET'TOKEN"           <<*nth*>>74715000
$control segment=idat4                                                  74720000
<<********************************************************>>   <<*nth*>>74725000
<<  get'token                                             >>   <<*nth*>>74730000
<<-------------------------------------------------------->>   <<*nth*>>74735000
<<  get the next token, its length, and its delimiter     >>   <<*nth*>>74740000
<<  given the input line and a set of delimiters.         >>   <<*nth*>>74745000
<<********************************************************>>   <<*nth*>>74750000
integer procedure get'token(line,delimiters,tknline,delim);    <<*nth*>>74755000
  byte array line,delimiters,tknline;                          <<*nth*>>74760000
  byte delim;                                                  <<*nth*>>74765000
                                                               <<*nth*>>74770000
begin                                                          <<*nth*>>74775000
  integer delim'indx,delims'len,line'len,i;                    <<*nth*>>74780000
  logical found;                                               <<*nth*>>74785000
                                                               <<*nth*>>74790000
  line'len := 0;  << find line length and upshift >>           <<*nth*>>74795000
  while line(line'len) <> cr and line'len < 300 do             <<*nth*>>74800000
    begin                                                      <<*nth*>>74805000
    if line(line'len) >= "a" and line(line'len) <= "z" then    <<*nth*>>74810000
      line(line'len) := line(line'len) - 32;                   <<*nth*>>74815000
    line'len := line'len + 1;                                  <<*nth*>>74820000
    end;                                                       <<*nth*>>74825000
  line(line'len) := cr;   << guarantee terminated input >>     <<*nth*>>74830000
  i := 0;  << strip leading spaces >>                          <<*nth*>>74835000
  while line(i) = " " and i < line'len do i := i + 1;          <<*nth*>>74840000
  line'len := line'len - i;                                    <<*nth*>>74845000
  move line := line(i), (line'len+1);                          <<*nth*>>74850000
  delims'len := 0;  << find delimiter buffer length >>         <<*nth*>>74855000
  while delimiters(delims'len) <> cr and delims'len < 31 do    <<*nth*>>74860000
    begin                                                      <<*nth*>>74865000
    if delims'len = 31 then delimiters(31) := cr;              <<*nth*>>74870000
    delims'len := delims'len + 1;                              <<*nth*>>74875000
    end;                                                       <<*nth*>>74880000
  delims'len := delims'len + 1;   << include cr >>             <<*nth*>>74885000
  i := 0;  << look for a delimiter in the line >>              <<*nth*>>74890000
  found := false;                                              <<*nth*>>74895000
  while not found do                                           <<*nth*>>74900000
    begin                                                      <<*nth*>>74905000
    delim'indx := 0;                                           <<*nth*>>74910000
    while delim'indx < delims'len and not found do             <<*nth*>>74915000
      begin                                                    <<*nth*>>74920000
      if line(i) = delimiters(delim'indx) then found := true;  <<*nth*>>74925000
      delim'indx := delim'indx + 1;                            <<*nth*>>74930000
      end;                                                     <<*nth*>>74935000
    i := i + 1;                                                <<*nth*>>74940000
    end;                                                       <<*nth*>>74945000
  delim := delimiters(delim'indx - 1);                         <<*nth*>>74950000
  i := i - 1;                                                  <<*nth*>>74955000
  move tknline := line, (i);                                   <<*nth*>>74960000
  move line := line(i+1), (line'len - i);                      <<*nth*>>74965000
<< strip trailing spaces >>                                    <<*nth*>>74970000
  while tknline(i-1) = " " and i > 0  do i := i - 1;           <<*nth*>>74975000
  get'token := i;                                              <<*nth*>>74980000
end;                                                           <<*nth*>>74985000
                                                               <<*nth*>>74990000
$page "                       PROCEDURE FIND"                  <<*nth*>>74995000
<<*******************************************************>>    <<*nth*>>75000000
<<  find                                                 >>    <<*nth*>>75005000
<<------------------------------------------------------->>    <<*nth*>>75010000
<<  parse and execute the find command.                  >>    <<*nth*>>75015000
<<*******************************************************>>    <<*nth*>>75020000
procedure find(parmstring);                                    <<*nth*>>75025000
   byte array parmstring;                                      <<*nth*>>75030000
                                                               <<*nth*>>75035000
begin                                                          <<*nth*>>75040000
   equate octal'mode =  0,                                     <<*nth*>>75045000
          dump'all   = 1,                                               75050000
          esc        = 27;                                     <<*nth*>>75055000
   byte delim;                                                 <<*nth*>>75060000
   byte array delimiters(0:31),str2(0:10),tknbuf(0:79);        <<*nth*>>75065000
   integer indx,len,lnlen,i,j;                                 <<*nth*>>75070000
   logical good,found;                                         <<*nth*>>75075000
   logical array numbers(0:31);                                <<*nth*>>75080000
   double memaddr,startaddr,endaddr,foundaddr;                 <<*nth*>>75085000
                                                               <<*nth*>>75090000
                                                               <<*nth*>>75095000
logical subroutine binary8(str,len);                           <<*nth*>>75100000
 << convert octal ascii to binary and set syntax error flag >> <<*nth*>>75105000
   value len;                                                  <<*nth*>>75110000
   byte array str;                                             <<*nth*>>75115000
   integer len;                                                <<*nth*>>75120000
begin                                                          <<*nth*>>75125000
   str2 := "%";                                                <<*nth*>>75130000
   move str2(1) := str,(len);                                  <<*nth*>>75135000
   binary8 := binary(str2,len+1);                              <<*nth*>>75140000
   if <> then good := false;  << syntax error >>               <<*nth*>>75145000
end;                                                           <<*nth*>>75150000
                                                               <<*nth*>>75155000
                                                               <<*nth*>>75160000
logical subroutine str'search(buf,length,startaddr,            <<*nth*>>75165000
    endaddr,foundaddr);                                        <<*nth*>>75170000
 << find a string of words in the dump (or live system) >>     <<*nth*>>75175000
  value length;                                                <<*nth*>>75180000
  array buf;                                                   <<*nth*>>75185000
  integer length;                                              <<*nth*>>75190000
  double startaddr,endaddr,foundaddr;                          <<*nth*>>75195000
begin                                                          <<*nth*>>75200000
  ctrly := false;                                              <<*nth*>>75205000
  found := false;                                              <<*nth*>>75210000
  memaddr := startaddr-1d;                                     <<*nth*>>75215000
  while (memaddr:=memaddr+1d) <= endaddr-double(length-1)      <<*nth*>>75220000
      and not found and not ctrly do                           <<*nth*>>75225000
  begin                                                        <<*nth*>>75230000
    if core(memaddr) = buf(0) then                             <<*nth*>>75235000
    begin                                                      <<*nth*>>75240000
      i := length;                                             <<*nth*>>75245000
      found := true;                                           <<*nth*>>75250000
      while (i:=i-1) > 0 and found do                          <<*nth*>>75255000
        if core(memaddr + double(i)) <> buf(i) then            <<*nth*>>75260000
          found := false;                                      <<*nth*>>75265000
    end;                                                       <<*nth*>>75270000
  end;                                                         <<*nth*>>75275000
  foundaddr := memaddr-1d;                                     <<*nth*>>75280000
  str'search := found;                                         <<*nth*>>75285000
  ctrly := false;                                              <<*nth*>>75290000
end;                                                           <<*nth*>>75295000
                                                               <<*nth*>>75300000
<<  m a i n  >>                                                <<*nth*>>75305000
   move delimiters := (",I",cr);                               <<*nth*>>75310000
   indx := 0;                                                  <<*nth*>>75315000
   good := true;                                               <<*nth*>>75320000
   do                                                          <<*nth*>>75325000
      begin                                                    <<*nth*>>75330000
      len := get'token(parmstring,delimiters,tknbuf,delim);    <<*nth*>>75335000
      numbers(indx) := binary8(tknbuf,len);                    <<*nth*>>75340000
      indx := indx + 1;                                        <<*nth*>>75345000
      end                                                      <<*nth*>>75350000
   until delim = "I" or delim = cr;                            <<*nth*>>75355000
   if delim = "I" then                                         <<*nth*>>75360000
      begin    << delim = "I" >>                               <<*nth*>>75365000
      move delimiters := (".+/A",cr);                          <<*nth*>>75370000
      len := get'token(parmstring,delimiters,tknbuf,delim);    <<*nth*>>75375000
      if delim = "A" then                                      <<*nth*>>75380000
         begin                                                 <<*nth*>>75385000
         startaddr := 0d;                                      <<*nth*>>75390000
         endaddr := max'real'mem;                                       75395000
         end                                                   <<*nth*>>75400000
      else                                                     <<*nth*>>75405000
         begin   << delim not "A" >>                           <<*nth*>>75410000
         j := 0;                                               <<*nth*>>75415000
         while tknbuf(j) < "0" or tknbuf(j) > "7" do           <<*nth*>>75420000
            j := j + 1;                                        <<*nth*>>75425000
         tos := binary8(tknbuf(j),len-j);  << starting bank >> <<*nth*>>75430000
         if delim = "." or delim = "+" then                    <<*nth*>>75435000
            begin                                              <<*nth*>>75440000
            len := get'token(parmstring,delimiters,tknbuf,     <<*nth*>>75445000
                  delim);                                      <<*nth*>>75450000
            tos := binary8(tknbuf,len);  << starting displ >>  <<*nth*>>75455000
            end                                                <<*nth*>>75460000
         else                                                  <<*nth*>>75465000
            tos := 0;  << starting displ >>                    <<*nth*>>75470000
         startaddr := tos;                                     <<*nth*>>75475000
         if delim <> "/" then good := false                    <<*nth*>>75480000
         else                                                  <<*nth*>>75485000
            begin   << delim = "/" >>                          <<*nth*>>75490000
            len := get'token(parmstring,delimiters,tknbuf,     <<*nth*>>75495000
                  delim);                                      <<*nth*>>75500000
            tos := binary8(tknbuf,len);  << ending bank >>     <<*nth*>>75505000
            if delim = "." or delim = "+" then                 <<*nth*>>75510000
               begin                                           <<*nth*>>75515000
               len := get'token(parmstring,delimiters,tknbuf,  <<*nth*>>75520000
                     delim);                                   <<*nth*>>75525000
               tos := binary8(tknbuf,len);  << ending displ >> <<*nth*>>75530000
               end                                             <<*nth*>>75535000
            else                                               <<*nth*>>75540000
               tos := %177777;  << ending displ >>             <<*nth*>>75545000
            endaddr := tos;                                    <<*nth*>>75550000
            end;   << delim = "/" >>                           <<*nth*>>75555000
         end;   << delim not "A" >>                            <<*nth*>>75560000
      end    << delim = "I" >>                                 <<*nth*>>75565000
   else                                                        <<*nth*>>75570000
      begin   << delim not "I" >>                              <<*nth*>>75575000
      startaddr := 0d;                                         <<*nth*>>75580000
      endaddr := max'real'mem;                                          75585000
      end;    << delim not "I" >>                              <<*nth*>>75590000
   if good then                                                <<*nth*>>75595000
      begin   << good >>                                       <<*nth*>>75600000
      do                                                       <<*nth*>>75605000
         begin   << search >>                                  <<*nth*>>75610000
         found := str'search(numbers,indx,startaddr,endaddr,   <<*nth*>>75615000
               foundaddr);                                     <<*nth*>>75620000
         if found then                                         <<*nth*>>75625000
            begin                                              <<*nth*>>75630000
            octaldump(outfile,foundaddr,                       <<*nth*>>75635000
                 foundaddr+double(indx-1),octal'mode,dump'all);         75640000
            startaddr := foundaddr + 1d;                       <<*nth*>>75645000
            move buf := "Continue? ";                          <<*nth*>>75650000
            write'rec(outfile,lbuf,-10,%320);                           75655000
            len := fread(infile,lbuf,-1);                      <<*nth*>>75660000
            move buf(2) := (esc,"A",esc,"K");                  <<*nth*>>75665000
            write'rec(outfile,lbuf(1),-4,0);                            75670000
            end;                                               <<*nth*>>75675000
         end   << search >>                                    <<*nth*>>75680000
      until not found or buf = "n" or buf = "N" or             <<*nth*>>75685000
            foundaddr + double(indx) > endaddr;                <<*nth*>>75690000
      if not found then                                        <<*nth*>>75695000
         begin                                                 <<*nth*>>75700000
         if indx = 1 then move buf := "** WORD NOT FOUND **",2 <<*nth*>>75705000
         else move buf := "** STRING NOT FOUND **",2;          <<*nth*>>75710000
         lnlen := tos - @buf;                                  <<*nth*>>75715000
         write'rec(outfile,lbuf,-lnlen,0);                              75720000
         end;                                                  <<*nth*>>75725000
      end   << good >>                                         <<*nth*>>75730000
   else printerror(12);  << syntax error >>                    <<*nth*>>75735000
end;                                                           <<*nth*>>75740000
$page "                       PROCEDURE PUTNUM"                         75745000
                                                                        75750000
<<             put number                                         >>    75755000
<<    this procedure converts a number into an ascii              >>    75760000
<<    representation of octal and stores it into the print buffer >>    75765000
<<    at the current pointer and advances the pointer.            >>    75770000
<<    the number always occupies a seven position field with a    >>    75775000
<<    trailing blank.  putnum does not suppress leading zeros.    >>    75780000
<<    putnump suppresses leading zeros and does not alter the     >>    75785000
<<    locations where they would have been put.  the numbers are  >>    75790000
<<    right justified in the field (except for the trailing blanks>>    75795000
<<                                                                >>    75800000
procedure putnum(num);                                                  75805000
      value num; integer num;                                           75810000
      begin                                                             75815000
         integer i:=5;                                                  75820000
         logical flag:=false;                                           75825000
         entry putnump;                                                 75830000
         flag:=true;                                                    75835000
putnump:                                                                75840000
        tos:=num;                                                       75845000
        tos:=tos&csl(1);                                                75850000
        tos:=s0.(15:1);                                                 75855000
loop:                                                                   75860000
        if <> or flag or i=0 then begin                                 75865000
           pbuf:=tos+"0";                                               75870000
           flag:=true;                                                  75875000
        end else begin                                                  75880000
           del; end;                                                    75885000
        @pbuf:=@pbuf+1;                                                 75890000
        i:=i-1;                                                         75895000
        if < then begin                                                 75900000
           pbuf:=" ";                                                   75905000
           @pbuf:=@pbuf+1;                                              75910000
           return; end;                                                 75915000
        tos:=tos&csl(3);                                                75920000
        tos:=s0.(13:3);                                                 75925000
        go loop;                                                        75930000
     end;  << procedure putnum >>                                       75935000
$page "                  PROCEDURE PUTDNUM"                    <<*nth*>>75940000
                                                               <<*nth*>>75945000
<<             put double number                            >> <<*nth*>>75950000
<<    this procedure converts a double word number into an  >> <<*nth*>>75955000
<<    ascii representation of octal and stores it into the  >> <<*nth*>>75960000
<<    print buffer at the current pointer and advances the  >> <<*nth*>>75965000
<<    pointer                                               >> <<*nth*>>75970000
                                                               <<*nth*>>75975000
procedure putdnum(dnum);                                       <<*nth*>>75980000
      value dnum;                                              <<*nth*>>75985000
      double dnum;                                             <<*nth*>>75990000
      begin                                                    <<*nth*>>75995000
         logical flag:=false;                                  <<*nth*>>76000000
         integer i:=10;                                        <<*nth*>>76005000
         entry putdnump;                                       <<*nth*>>76010000
         flag:=true;                                           <<*nth*>>76015000
putdnump:                                                      <<*nth*>>76020000
           tos:=dnum;                                          <<*nth*>>76025000
           tos:=tos&dcsl(1);<<get low order bit>>              <<*nth*>>76030000
           tos:=s0.(15:1);                                     <<*nth*>>76035000
           if <> then                                          <<*nth*>>76040000
           begin                                               <<*nth*>>76045000
              pbuf:="-"; del;                                  <<*nth*>>76050000
              @pbuf:=@pbuf+1;                                  <<*nth*>>76055000
              tos:=tos&dcsr(1);                                <<*nth*>>76060000
              tos:=-tos;                                       <<*nth*>>76065000
              if s0=0 then s1:=-s1                             <<*nth*>>76070000
              else s1:=-s1-1;                                  <<*nth*>>76075000
              tos:=tos&dcsl(1);                                <<*nth*>>76080000
           end else del;                                       <<*nth*>>76085000
           tos:=tos&dcsl(1);<<get next low order bit>>         <<*nth*>>76090000
           tos:=s0.(15:1);                                     <<*nth*>>76095000
loop:                                                          <<*nth*>>76100000
           if <> or flag or i=0 then                           <<*nth*>>76105000
           begin                                               <<*nth*>>76110000
              pbuf:=tos+"0";                                   <<*nth*>>76115000
              flag:=true;                                      <<*nth*>>76120000
              @pbuf:=@pbuf+1;                                  <<*nth*>>76125000
           end else del;                                       <<*nth*>>76130000
           i:=i-1;                                             <<*nth*>>76135000
           if < then                                           <<*nth*>>76140000
           begin                                               <<*nth*>>76145000
              pbuf:=" ";                                       <<*nth*>>76150000
              @pbuf:=@pbuf+1;                                  <<*nth*>>76155000
              return;                                          <<*nth*>>76160000
           end;                                                <<*nth*>>76165000
           tos:=tos&dcsl(3);                                   <<*nth*>>76170000
           tos:=s0.(13:3);                                     <<*nth*>>76175000
           go loop;                                            <<*nth*>>76180000
        end;<<putdnum/putdnump>>                               <<*nth*>>76185000
$page "                  PROCEDURE SET'REG"                             76190000
<<**********************************************>>                      76195000
<<  set'reg                                     >>                      76200000
<<---------------------------------------------->>                      76205000
<< sets register to specified value or resets   >>                      76210000
<< one or all regs. to original value           >>                      76215000
<<**********************************************>>                      76220000
procedure set'reg(parmstring);                                          76225000
  byte array parmstring;                                                76230000
begin                                                                   76235000
  << allows db,dl,q,s,z,&pb registers (and respective >>                76240000
  << banks) to be set to any value.  a command without>>                76245000
  << an address sets the register back to its value at>>                76250000
  << time of dump.                                    >>                76255000
                                                                        76260000
  << this procedure assumes the existence of the follow->>              76265000
  <<ing global variables:                               >>              76270000
  <<   procedure printerror              cr             >>              76275000
  <<   all registers and "SAVE" registers               >>              76280000
                                                                        76285000
equate maxparms = 2;                                                    76290000
                                                                        76295000
equate set'db     = 0,                                                  76300000
       set'dl     = 1,                                                  76305000
       set'q      = 2,                                                  76310000
       set's      = 3,                                                  76315000
       set'z      = 4,                                                  76320000
       set'pb     = 5,                                                  76325000
       set'p      = 6,                                           <<nsf>>76330000
       set'pl     = 7,                                           <<nsf>>76335000
       set'all    = 8,                                           <<nsf>>76340000
       invalid    = 9;                                           <<nsf>>76345000
                                                                        76350000
define length = infoword.(0:8)#;                                        76355000
                                                                        76360000
byte array delimiters(0:1);                                             76365000
                                                                        76370000
byte array temp(0:9);                                                   76375000
                                                                        76380000
byte pointer string;                                                    76385000
                                                                        76390000
integer numparms,reg'option;                                            76395000
                                                                        76400000
logical infoword,bank,base;                                             76405000
                                                                        76410000
double array parms(0:maxparms);                                         76415000
                                                                        76420000
                                                                        76425000
subroutine set'base(parm);                                              76430000
<<--------------------------->>                                         76435000
value parm;                                                             76440000
double parm;                                                            76445000
<< set address of register specified >>                                 76450000
begin                                                                   76455000
<< point string to actual parameter >>                                  76460000
   tos:=parm;                                                           76465000
   infoword:=tos;                                                       76470000
   @string:=tos;                                                        76475000
                                                                        76480000
   if string=cr then << nothing specified >>                            76485000
      begin                                                             76490000
      printerror(12);                                                   76495000
      go exit'proc;                                                     76500000
      end                                                               76505000
   else << move new address to register >>                              76510000
   begin                                                                76515000
      if string(0)="#" then << decimal numbered entered >>              76520000
      base:=binary(string(1),length-1)                                  76525000
      else                                                              76530000
         begin                                                          76535000
         move temp:=string(0),(length);                                 76540000
         move string(1):=temp,(length);                                 76545000
         move string(0):="%";<<needed for binary intrinsic>>            76550000
         base:=binary(string,length+1);                                 76555000
         end;                                                           76560000
                                                                        76565000
      case reg'option of                                                76570000
         begin                                                          76575000
         << db >> dbreg:=base;                                          76580000
         << dl >> dlreg:=base;                                          76585000
         << q  >> qreg :=base;                                          76590000
         << s  >> sreg :=base;                                          76595000
         << z  >> zreg :=base;                                          76600000
         << pb >> pbreg:=base;                                          76605000
         << p  >> preg:=base;                                    <<nsf>>76610000
         << pl >> plreg:=base;                                   <<nsf>>76615000
         end; << case >>                                                76620000
                                                                        76625000
   end;  << move new address to register >>                             76630000
                                                                        76635000
end; << subroutine set'base >>                                          76640000
                                                                        76645000
<<  main body of set'reg >>                                             76650000
                                                                        76655000
<< set up to parse the parameters >>                                    76660000
delimiters(0):="=";                                                     76665000
delimiters(1):=cr;                                                      76670000
mycommand(parmstring,delimiters,maxparms,numparms,parms);               76675000
  if <> then                                                            76680000
    begin                                                               76685000
    printerror(0);                                                      76690000
    return;                                                             76695000
    end;                                                                76700000
                                                                        76705000
if not (0<=numparms<=2) then                                            76710000
  begin                                                                 76715000
  printerror(7);                                                        76720000
  return;                                                               76725000
  end;                                                                  76730000
                                                                        76735000
if numparms = 0 then return; << nothing specified >>                    76740000
                                                                        76745000
<< put first parameter on stack >>                                      76750000
tos:=parms(0);                                                          76755000
infoword:=tos;                                                          76760000
@string:=tos;                                                           76765000
                                                                        76770000
<< determine the register that needs to be changed.>>                   76775000
reg'option:=                                                            76780000
          if string = "DB"     then set'db                              76785000
          else                                                          76790000
          if string = "DL"     then set'dl                              76795000
          else                                                          76800000
          if string = "Q"      then set'q                               76805000
          else                                                          76810000
          if string = "S"      then set's                               76815000
          else                                                          76820000
          if string = "Z"      then set'z                               76825000
          else                                                          76830000
          if string = "PB"     then set'pb                              76835000
          else                                                          76840000
          if string = "PL"     then set'pl                       <<nsf>>76845000
          else                                                   <<nsf>>76850000
          if string = "P"      then set'p                        <<nsf>>76855000
          else                                                   <<nsf>>76860000
          if string = "ALL"    then set'all                             76865000
          else                                                          76870000
          invalid;                                                      76875000
                                                                        76880000
<< invalid register >>                                                  76885000
if reg'option = invalid then                                            76890000
  begin                                                                 76895000
  printerror(28);                                                       76900000
  return;                                                               76905000
  end;                                                                  76910000
                                                                        76915000
if numparms = 1 then  << reset option >>                                76920000
  begin  << replace reg. with original value >>                         76925000
  case  reg'option  of                                                  76930000
    begin                                                               76935000
    << db >> begin                                                      76940000
             dbbankreg:=svdbbank;                                       76945000
             dbreg:=svdbreg;                                            76950000
             end;                                                       76955000
    << dl >> begin                                                      76960000
             dlreg:=svdlreg;                                            76965000
             zbankreg:=svsbank;                                         76970000
             end;                                                       76975000
    << q  >> begin                                                      76980000
             qreg:=svqreg;                                              76985000
             zbankreg:=svsbank;                                         76990000
             end;                                                       76995000
    << s  >> begin                                                      77000000
             sreg:=svsreg;                                              77005000
             zbankreg:=svsbank;                                         77010000
             end;                                                       77015000
    << z  >> begin                                                      77020000
             zreg:=svzreg;                                              77025000
             zbankreg:=svsbank;                                         77030000
             end;                                                       77035000
    << pb >> begin                                                      77040000
             pbbankreg:=svpbbank;                                       77045000
             pbreg:=svpbreg;                                            77050000
             end;                                                       77055000
    << p  >> begin                                               <<nsf>>77060000
             preg:=svpreg;                                       <<nsf>>77065000
             pbbankreg:=svpbbank;                                <<nsf>>77070000
             end;                                                <<nsf>>77075000
    << pl >> begin                                               <<nsf>>77080000
             plreg:=svplreg;                                     <<nsf>>77085000
             pbbankreg:=svpbbank;                                <<nsf>>77090000
             end;                                                <<nsf>>77095000
    << all>> begin                                                      77100000
             dbbankreg:=svdbbank;                                       77105000
             dbreg:=svdbreg;                                            77110000
             dlreg:=svdlreg;                                            77115000
             qreg:=svqreg;                                              77120000
             sreg:=svsreg;                                              77125000
             zreg:=svzreg;                                              77130000
             zbankreg:=svsbank;                                         77135000
             pbbankreg:=svpbbank;                                       77140000
             pbreg:=svpbreg;                                            77145000
             end;                                                       77150000
    end; << case >>                                                     77155000
                                                                        77160000
    exit'proc:  return;                                                 77165000
  end  << number of parms = 1 (reset option) >>                         77170000
                                                                        77175000
else  << set reg. or reg. and bank to new address >>                    77180000
  begin                                                                 77185000
                                                                        77190000
  << load rest of parms >>                                              77195000
  tos:=parms(1);                                                        77200000
  infoword:=tos;                                                        77205000
  @string:=tos;                                                         77210000
                                                                        77215000
  string(length):=cr; << needed for mycommand >>                        77220000
                                                                        77225000
  << set up to parse parameter >>                                       77230000
  delimiters(0):=",";                                                   77235000
  delimiters(1):=cr;                                                    77240000
  mycommand(string,delimiters,maxparms,numparms,parms);                 77245000
    if <> then                                                          77250000
      begin                                                             77255000
      printerror(0);                                                    77260000
      return;                                                           77265000
      end;                                                              77270000
                                                                        77275000
  if not (0<=numparms<=2)  then                                         77280000
    begin                                                               77285000
    printerror(7);                                                      77290000
    return;                                                             77295000
    end;                                                                77300000
                                                                        77305000
  if numparms = 1 then  << change only reg, not bank >>                 77310000
    begin                                                               77315000
    set'base(parms(0));                                                 77320000
    return;                                                             77325000
    end;                                                                77330000
                                                                        77335000
  << number of parms must be 2 >>                                       77340000
  set'base(parms(1));  << change register >>                            77345000
                                                                        77350000
  << load parm containing bank >>                                       77355000
   tos:=parms(0);                                                       77360000
   infoword:=tos;                                                       77365000
   @string:=tos;                                                        77370000
   if string(0)="#" then << decimal number entered >>                   77375000
      base:=binary(string(1),length-1)                                  77380000
   else                                                                 77385000
      begin                                                             77390000
      move temp:=string,(length);                                       77395000
      move string(1):=temp,(length);                                    77400000
      move string(0):="%"; << needed for the binary intrinsic >>        77405000
      bank:=binary(string,length+1)                                     77410000
      end;                                                              77415000
                                                                        77420000
   case reg'option of   << change reg bank>>                            77425000
   begin                                                                77430000
   << db  >> dbbankreg:=bank;                                           77435000
   << dl  >> zbankreg:=bank;                                            77440000
   << q   >> zbankreg:=bank;                                            77445000
   << s   >> zbankreg:=bank;                                            77450000
   << z   >> zbankreg:=bank;                                            77455000
   << pb  >> pbbankreg:=bank;                                           77460000
   << p   >> pbbankreg:=bank;                                    <<nsf>>77465000
   << pl  >> pbbankreg:=bank;                                    <<nsf>>77470000
   end; << case >>                                                      77475000
                                                                        77480000
  end;  << setting register to new value >>                             77485000
                                                                        77490000
end;  << procedure set'reg >>                                           77495000
$page "                     OUTER BLOCK"                                77500000
                                                                        77505000
<<*********************************************>>                       77510000
<<  outer block                                >>                       77515000
<<*********************************************>>                       77520000
                                                                        77525000
                                                                        77530000
welcome; << send message to user >>                                     77535000
init;   << initialize >>                                                77540000
if info'len>53 then info'len:=53;                                <<nsf>>77545000
if info'len<1 then begin                                         <<nsf>>77550000
  move buf:="        ";                                          <<nsf>>77555000
  end                                                            <<nsf>>77560000
else begin                                                       <<nsf>>77565000
  move buf:=info'ptr,(info'len);                                 <<nsf>>77570000
  outchar:=1;                                                    <<nsf>>77575000
  squeez(0):="T";                                                <<nsf>>77580000
  for inchar:=0 until info'len-1 do begin                        <<nsf>>77585000
    if buf(inchar) <> " " then begin                             <<nsf>>77590000
      squeez(outchar):=buf(inchar);                              <<nsf>>77595000
      outchar:=outchar+1;                                        <<nsf>>77600000
    end;                                                         <<nsf>>77605000
  end;                                                           <<nsf>>77610000
  if outchar > 2 then begin                                      <<nsf>>77615000
    move buf:=squeez,(outchar);                                  <<nsf>>77620000
    buf(outchar):=cr;                                            <<nsf>>77625000
    auto'text:=true;                                             <<nsf>>77630000
  end;                                                           <<nsf>>77635000
end;                                                             <<nsf>>77640000
ci;    << command interpretor >>                                        77645000
                                                                        77650000
end.                                                                    77655000
