$CONTROL MAP,CODE,USLINIT                                               00010000
<< abortdump -- module 58 >>                                   <<01070>>00015000
<< hp32002c mpe source c.00.00 >>                                       00020000
$copyright     "(C) COPYRIGHT HEWLETT-PACKARD CO. 1980. ",            & 00025000
$     "THIS PROGRAM MAY BE USED WITH ONE COMPUTER SYSTEM AT A ",      & 00030000
$     "TIME AND SHALL NOT OTHERWISE BE RECORDED, TRANSMITTED OR ",    & 00035000
$     "STORED IN A RETRIEVAL SYSTEM.  COPYING OR OTHER REPRODUCTION ",& 00040000
$     "OF THIS PROGRAM EXCEPT FOR ARCHIVAL PURPOSES IS PROHIBITED ",  & 00045000
$     "WITHOUT THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY."   00050000
$thirty                                                                 00055000
$control main=abortdump,segment=abortdump                      <<00652>>00060000
$control privileged                                                     00065000
          << >>                                                         00070000
          << a b o r t    apr 15,1976 >>                                00075000
          <<trap mechanism and abort interface intrinsics>>             00080000
          << >>                                                         00085000
begin                                                                   00090000
$include inclpcb5                                              <<06643>>00095000
equate                                                                  00100000
         dstb      =2,                                                  00105000
         systemsl  =0,                                                  00110000
         ccg       =0,                                                  00115000
         ccl       =1,                                                  00120000
         cce       =2;                                                  00125000
integer s0 = s-0;                                              <<06097>>00130000
integer  status    =q-1,                                                00135000
         deltap    =q-2,                                       <<06097>>00140000
         x         =x;                                                  00145000
logical  pointer dstl'=dstb,                                            00150000
                 pcbl'=syspcbindex;                            <<06643>>00155000
integer pointer dsti'=dstb;                                    <<00652>>00160000
integer pointer                                                         00165000
   pcbi' = syspcbindex;                                        <<06643>>00170000
define   f         =absolute#,                                          00175000
         log       =logical#,                                  <<03046>>00180000
         asmb      =assemble#,                                          00185000
         duplicate =asmb(dup)#,                                         00190000
         triplicate=asmb(dup,dup)#,                                     00195000
        pix       = (curprc)#,                                 <<06643>>00200000
         trapsoff  =push(status);tos.(2:1)_0;set(status)#,              00205000
         disable   =asmb(sed 0)#,                                       00210000
         pdisable  =asmb(psdb)#,                               <<06097>>00215000
         penable   =asmb(pseb)#,                               <<06097>>00220000
       systemflag=(6:1)#,                                      <<01549>>00225000
         lbite     =( 0: 8)#,                                           00230000
         rbite     =( 8: 8)#,                                           00235000
         trapfld   =( 2: 1)#,                                           00240000
         ccfld     =( 6: 2)#,                                           00245000
         cstfield  =( 8: 8)#;                                           00250000
define ccode = status.ccfld#;                                  <<06097>>00255000
<<trap definitions>>                                           <<06097>>00260000
<<logical mapping information>>                                <<06097>>00265000
define logicalmapping=absolute(%1220)#,                        <<06097>>00270000
       mapflag=(1:1)#; <<mapflag in stack marker>>             <<06097>>00275000
equate progsegtype=14; <<seg type from logicalcst>>            <<06097>>00280000
$page                                                                   00285000
array qarray(*) = q+0;                                         <<*7758>>00290000
$include inclpxdl                                              <<*7758>>00295000
$include inclpxgt                                              <<*7758>>00300000
$include inclpxft                                              <<*7758>>00305000
$include inclldt5                                              <<07052>>00310000
          << >>                                                         00315000
          <<external procedures>>                                       00320000
          << >>                                                         00325000
                                                               <<01549>>00330000
integer procedure convextlabeltodeltap(extlabel);              <<01549>>00335000
value extlabel;                                                <<01549>>00340000
integer extlabel;                                              <<01549>>00345000
option external;                                               <<01549>>00350000
                                                               <<01549>>00355000
logical procedure resetbreakbits(a,b);                         <<00.eb>>00360000
   value      a,b;                                                      00365000
   integer    a,b;                                                      00370000
   option     external;                                                 00375000
logical procedure iocontrol(ldev,func);                                 00380000
   value      ldev,func;                                                00385000
   integer    ldev,func;                                                00390000
   option     external;                                                 00395000
integer procedure cstconv(csten,pinx);                         <<06097>>00400000
  value csten,pinx;                                            <<06097>>00405000
  integer csten,pinx;                                          <<06097>>00410000
  option external;                                             <<06097>>00415000
procedure set'psif(pinx,flag);                                          00420000
   value      pinx,flag;                                                00425000
   integer    pinx;                                                     00430000
   logical    flag;                                                     00435000
   option     external;                                                 00440000
procedure clear'psif(pinx,flag);                                        00445000
   value      pinx,flag;                                                00450000
   integer    pinx;                                                     00455000
   logical    flag;                                                     00460000
   option     external;                                                 00465000
procedure help;                                                         00470000
   option     external;                                                 00475000
procedure freeze(en,type,pinx);                                         00480000
   value      en,type,pinx;                                             00485000
   integer    en,type,pinx;                                             00490000
   option     external;                                                 00495000
procedure unfreeze(en,type,pinx);                                       00500000
   value      en,type,pinx;                                             00505000
   integer    en,type,pinx;                                             00510000
  option external;                                                      00515000
          << >>                                                         00520000
procedure terminate;                                                    00525000
  option external;                                                      00530000
          << >>                                                         00535000
procedure suddendeath(n);                                               00540000
  value n;logical n;option external;                                    00545000
          << >>                                                         00550000
logical procedure exchangedb(ix);                                       00555000
  value ix;logical ix;option external;                                  00560000
          << >>                                                         00565000
logical procedure setsysdb;     option external;                        00570000
          << >>                                                         00575000
procedure resetdb(ix);                                                  00580000
  value ix;logical ix;option external;                                  00585000
          << >>                                                         00590000
procedure resumesoftint;                                       <<03046>>00595000
   option external;                                            <<03046>>00600000
             << >>                                             <<03046>>00605000
logical procedure setcritical;                                          00610000
  option external;                                                      00615000
          << >>                                                         00620000
procedure resetcritical(c);                                             00625000
  value c;logical c;option external;                                    00630000
          << >>                                                         00635000
procedure erroron;         option external;                             00640000
          << >>                                                         00645000
procedure errorexit(i,e,p);                                             00650000
  value i,e,p;logical i,e,p;option external;                            00655000
          << >>                                                         00660000
double procedure chek(int,fl,parm,capm,ovm);                            00665000
  value   int,fl,parm,capm,ovm;                                         00670000
  logical int,fl,ovm;                                                   00675000
  double  parm,capm;                                                    00680000
  option external,variable;                                             00685000
         << >>                                                 <<06097>>00690000
double procedure chek'noabort(int,fl,parm,capm,ovm);           <<06097>>00695000
  value int,fl,parm,capm,ovm;                                  <<06097>>00700000
  logical int,fl,ovm;                                          <<06097>>00705000
  double parm,capm;                                            <<06097>>00710000
  option external,variable;                                    <<06097>>00715000
         << >>                                                 <<06097>>00720000
logical procedure system(plabel);                              <<06097>>00725000
  value plabel; integer plabel;                                <<06097>>00730000
  option external;                                             <<06097>>00735000
          << >>                                                         00740000
logical procedure getjcw;                                      <<u.rao>>00745000
option external;                                               <<u.rao>>00750000
          << >>                                                         00755000
procedure setjcw(w);                                                    00760000
  value w;logical w;option external;                                    00765000
          << >>                                                         00770000
procedure procfile(pin,b);                                              00775000
  value pin;logical pin;byte array b;option external;                   00780000
          << >>                                                         00785000
double procedure logicalcst'(seg'nr,pinx);                     <<06875>>00790000
  value seg'nr,pinx;                                           <<06097>>00795000
  integer seg'nr,pinx;                                         <<06097>>00800000
  option external;                                             <<06097>>00805000
          << >>                                                         00810000
integer procedure genmsg(setno,msgno,mask,a,b,c,d,e,           <<02.eb>>00815000
      dest,reply,buff,dst,iotype);                             <<02.eb>>00820000
   value setno,msgno,mask,a,b,c,d,e,dest,reply,buff,           <<02.eb>>00825000
      dst,iotype;                                              <<02.eb>>00830000
   logical setno,msgno,mask,a,b,c,d,e,dest,reply,buff,         <<02.eb>>00835000
      dst,iotype;                                              <<02.eb>>00840000
   option variable,external;                                   <<02.eb>>00845000
procedure stackdump(fl,id,flags,selec);                        <<c0.00>>00850000
byte array fl;logical flags;integer id;double array selec;     <<c0.00>>00855000
option forward,variable;                                       <<00652>>00860000
                                                               <<c0.00>>00865000
procedure marker(p,boutb);                                     <<c0.00>>00870000
value p;integer p;byte array boutb;                            <<c0.00>>00875000
option forward;                                                <<00652>>00880000
                                                               <<c0.00>>00885000
procedure regist(sx,boutb);                                    <<c0.00>>00890000
value sx;integer sx;byte array boutb;                          <<c0.00>>00895000
option forward;                                                <<00652>>00900000
                                                               <<c0.00>>00905000
integer procedure physicalcst(p,s);                            <<c0.00>>00910000
value p,s;integer p,s;    option external;                     <<c0.00>>00915000
integer procedure mappedcsttophycst(mapcst,pinx);              <<06097>>00920000
  value mapcst,pinx;                                           <<06097>>00925000
  integer mapcst,pinx;                                         <<06097>>00930000
  option external;                                             <<06097>>00935000
                                                               <<c0.00>>00940000
procedure debug;    option external;                           <<c0.00>>00945000
logical procedure dmove'(ds,di,n,loc,d,nu);                    <<00652>>00950000
value ds,di,n,loc,d,nu;                                        <<00652>>00955000
logical ds,d; integer di,n,loc,nu;                             <<00652>>00960000
option external;                                               <<00652>>00965000
                                                               <<00652>>00970000
logical procedure pxdseg(func,parm);                           <<00652>>00975000
value func,parm; logical func,parm;                            <<00652>>00980000
option external;                                               <<00652>>00985000
                                                               <<00652>>00990000
intrinsic ascii,fopen,fclose,fgetinfo,fwrite;                  <<00652>>00995000
intrinsic fcheck,fcontrol,print;                               <<00652>>01000000
                                                               <<00652>>01005000
$page                                                                   01010000
            << >>                                                       01015000
            << abort routine >>                                         01020000
            << >>                                                       01025000
<<mode.(0:8) = number of markers to be deleted.           >>   <<u.rao>>01030000
<<mode.(8:8) = type of abort                              >>   <<u.rao>>01035000
<<   0 = internal interrupt, hardware or simulated.       >>   <<u.rao>>01040000
<<       code = type of internal interrupt.               >>   <<u.rao>>01045000
<<          0 = ?                                         >>   <<u.rao>>01050000
<<          1 = integer overflow                          >>   <<u.rao>>01055000
<<          2 = floating point overflow                   >>   <<u.rao>>01060000
<<          3 = floating point underflow                  >>   <<u.rao>>01065000
<<          4 = integer divide by zero                    >>   <<u.rao>>01070000
<<          5 = floating point divide by zero             >>   <<u.rao>>01075000
<<          6 = privileged mode instruction trap          >>   <<u.rao>>01080000
<<          7 = unimplemented instruction trap            >>   <<u.rao>>01085000
<<          8 = extended precision overflow               >>   <<u.rao>>01090000
<<          9 = extended precision underflow              >>   <<u.rao>>01095000
<<         10 = extended precision divide by zero         >>   <<u.rao>>01100000
<<         11 = decimal overflow                          >>   <<u.rao>>01105000
<<         12 = invalid ascii digit in decimal instruction>>   <<u.rao>>01110000
<<         13 = invalid decimal digit                     >>   <<u.rao>>01115000
<<         14 = invalid source word count                 >>   <<u.rao>>01120000
<<         15 = invalid decimal operand length            >>   <<u.rao>>01125000
<<         16 = decimal divide by zero                    >>   <<u.rao>>01130000
<<         17 = stt uncallable                            >>   <<u.rao>>01135000
<<         18 unused                                      >>   <<u.rao>>01140000
<<         19 unused                                      >>   <<u.rao>>01145000
<<         20 = stack overflow                            >>   <<u.rao>>01150000
<<         21 unused                                      >>   <<u.rao>>01155000
<<         22 = bad stack marker                          >>   <<u.rao>>01160000
<<         23 = illegal address (no such memory address)  >>   <<u.rao>>01165000
<<         24 = bounds violation (typically user error)   >>   <<u.rao>>01170000
<<         25 = non-responding module                     >>   <<u.rao>>01175000
<<         26 unused                                      >>   <<u.rao>>01180000
<<         27 unused                                      >>   <<u.rao>>01185000
<<         28 unused                                      >>   <<u.rao>>01190000
<<         29 = stack underflow                           >>   <<u.rao>>01195000
<<         30 = cst violation                             >>   <<u.rao>>01200000
<<         31 = stt violation                             >>   <<u.rao>>01205000
<<mode.(8:8) = 1 => intrinsic error                           ><<u.rao>>01210000
<<   code = intrinexit, defined as                            ><<u.rao>>01215000
<<         10:6 = number of parameter words                   ><<u.rao>>01220000
<<         0:10 = intrinsic number                            ><<u.rao>>01225000
<<   param = type of error                                    ><<u.rao>>01230000
<<         1 = illegal db register (split stack not allowed   ><<u.rao>>01235000
<<         2 = illegal capability (insufficient capability)   ><<u.rao>>01240000
<<         3 = omitted parameter (required parm for opt. var.)><<u.rao>>01245000
<<         4 = incorrect s register (not enough stack)        ><<u.rao>>01250000
<<         5 = parameter address violation                    ><<u.rao>>01255000
<<         6 = parameter end address violation                ><<u.rao>>01260000
<<         7 = illegal parameter (?)                          ><<u.rao>>01265000
<<         8 = parameter value invalid                        ><<u.rao>>01270000
<<         9 = incorrect q register                           ><<u.rao>>01275000
<<mode.(8:8) = 2 => quit call                                 ><<u.rao>>01280000
<<   code = 0                                                 ><<u.rao>>01285000
<<   param = user supplied quit number                        ><<u.rao>>01290000
<<   mapped into internal interrupt msg 18, process quit>>     <<u.rao>>01295000
<<mode.(8:8) = 3 => quitprog call                             ><<u.rao>>01300000
<<   code = 0                                                 ><<u.rao>>01305000
<<   param = user supplied quit number                        ><<u.rao>>01310000
<<   mapped into internal interrupt msg 19, program quit>>     <<u.rao>>01315000
<<mode.(8:8) = 4 => stack overflow in dataseg                 ><<u.rao>>01320000
<<   code & param ignored.                                    ><<u.rao>>01325000
<<   mapped into internal interrupt msg 20, stack overflow>>   <<u.rao>>01330000
<<mode.(8:8) = 5 => hard kill from abortprog (:abort, etc.)   ><<u.rao>>01335000
<<   code & param ignored.                                    ><<u.rao>>01340000
<<   mapped into internal interrupt msg 21, program killed>>   <<u.rao>>01345000
            << abort:process loc:library loc:message  >>                01350000
            <<  cr  :sysproc loc:library loc:message  >>                01355000
            << >>                                                       01360000
procedure abort(mode,code,param);                                       01365000
  value   mode,code,param;                                              01370000
  logical mode,code,param;                                              01375000
  option  privileged,uncallable;                                        01380000
  begin                                                                 01385000
                                                               <<02.eb>>01390000
          equate                                                        01395000
                     pcblink=5,                                         01400000
                     pcbsys =9 ,                                        01405000
                     sml   =pcbsys-pcblink,                             01410000
                     librx=0,      <<loc>>                              01415000
                     procx=4,                                           01420000
                     pv  =1,                                            01425000
                     cstl=2,                                            01430000
                     typl=3,                                            01435000
                     progn=3,                                           01440000
                     stop ="..",   <<spec char>>                        01445000
                     colon="::",                                        01450000
                     aster="**",                                        01455000
                     quest="??",                                        01460000
                     percent="%%",                                      01465000
                     pcb2 = 2,                                          01470000
                     blank="  ",                               <<02.eb>>01475000
                     miscset=3,                                <<02.eb>>01480000
                     pgmerrset=4,                              <<02.eb>>01485000
                     intrinset=5,                              <<02.eb>>01490000
                     runtimeset=6,                             <<02.eb>>01495000
                     fsysset=8,                                <<02.eb>>01500000
                     loadset=9,                                <<02.eb>>01505000
                     createset=10,                             <<02.eb>>01510000
                     activateset=11,                           <<02.eb>>01515000
                     suspendset=12,                            <<02.eb>>01520000
                     mycommandset=13,                          <<02.eb>>01525000
                     lockglorinset=14,                         <<02.eb>>01530000
                     paramsg=15,                               <<02.eb>>01535000
                     fs=fsysset,                               <<02.eb>>01540000
                     l=loadset,                                <<02.eb>>01545000
                     c=createset,                              <<02.eb>>01550000
                     a=activateset,                            <<02.eb>>01555000
                     s=suspendset,                             <<02.eb>>01560000
                     m=mycommandset,                           <<02.eb>>01565000
                     lk=lockglorinset;                         <<02.eb>>01570000
          define     signfld=(0:1)#,                                    01575000
                     ifld=(0:10)#,     <<parameters>>                   01580000
                     rsofld=(3:1)#,                                     01585000
                     pcbdstf=(1:10)#,  <<pcb>>                          01590000
                     pcbfthf=(0:8)#,                                    01595000
                     pcbsysf=(6:1)# ,                                   01600000
                     pcbsomf=(6:3)#,                                    01605000
                     pfld=(2:14)#;     <<sm>>                           01610000
                                                               <<03046>>01615000
          define     instr'trap= type=0 and ((code>16 land     <<03046>>01620000
                                 code<>20) or code = 6 or      <<03046>>01625000
                                 code=7) #,                    <<03046>>01630000
                     arith'trap= type=0 and code<=16 and       <<03046>>01635000
                                 code<>6 and code <>7 #;       <<03046>>01640000
          byte array libr(0:11)=pb_"SYSLPUSLGRSL";                      01645000
          << >>                                                         01650000
          double dbvalue;                                               01655000
         integer pcbpt;                                        <<06643>>01660000
         logical progflag,critflag',dbfixed;                   <<06643>>01665000
          integer i,j,k,bp,wp,ln,type;                                  01670000
          integer jmin,phy,cstx,px,t,ppp,ltyp;                          01675000
          integer dbsave,plab,statx,xx;                                 01680000
          integer pin,pinx,cnt,libx;                           <<06664>>01685000
integer pxglob=t;                                              <<06097>>01690000
          integer array stak(*)=db+0;                                   01695000
          integer array stack(*)=q+0;                                   01700000
          array qarray(*) = q+0;                               <<06664>>01705000
          logical pxfixedloc;                                  <<06664>>01710000
          logical index;                                       <<06664>>01715000
          integer pcbglobloc;                                  <<06664>>01720000
          array error(0:5)=q;                                           01725000
          array loc(0: 7)=q;                                            01730000
          array msg(0:50)=q;                                            01735000
          byte array bmsg(*)=msg;                                       01740000
          byte array name(*)=msg(20);                                   01745000
$page                                                                   01750000
<<variables for user traps>>                                   <<06097>>01755000
integer stk'position = j;                                      <<06097>>01760000
integer num'parms = k;                                         <<06097>>01765000
integer code' = wp;                                            <<06097>>01770000
                                                               <<06097>>01775000
<<variables for stack marker trace>>                           <<06097>>01780000
integer loc'position = k;                                      <<06097>>01785000
                                                               <<c0.00>>01790000
<<variable for stack abort>>                                   <<c0.00>>01795000
array pcbx(*)=q+0;                                             <<c0.00>>01800000
logical stdf,jobtype=critflag',rwf=progflag;                   <<06643>>01805000
integer dbgcst=wp,dbgdp=ln;                                    <<c0.00>>01810000
logical syscst;                                                <<c0.00>>01815000
integer base=pin,qin=cnt,inx=jmin;                             <<c0.00>>01820000
double array dump(*)=msg(0);                                   <<c0.00>>01825000
integer bases;                                                 <<c0.00>>01830000
array wdump(*)=msg(0);                                         <<c0.00>>01835000
<<variables for abort message>>                                <<c+.09>>01840000
integer                                                        <<02.eb>>01845000
   param' = i,                                                 <<02.eb>>01850000
   intrindex = j,                                              <<02.eb>>01855000
   tableno = k,                                                <<02.eb>>01860000
   msgno = bp;                                                 <<02.eb>>01865000
                                                                        01870000
byte array intrin(*) = pb :=                                   <<02.eb>>01875000
                                                               <<02.eb>>01880000
<<      0  1  2  3  4  5  6  7  8  9  >>                       <<02.eb>>01885000
                                                               <<02.eb>>01890000
<< 0 >> 0,fs,fs,fs,fs,fs,fs,fs, 0,fs,                          <<02.eb>>01895000
<<10 >>fs,fs,fs,fs,fs,fs,fs,fs,fs,fs,                          <<02.eb>>01900000
<<20 >>fs, 0, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01905000
<<30 >> 0, 0, 0, 0,lk, 0, 0, 0, 0, 0,                          <<02.eb>>01910000
<<40 >> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01915000
<<50 >> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01920000
<<60 >> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01925000
<<70 >> 0, m, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01930000
<<80 >> l, l, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01935000
<<90 >> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01940000
<<100>> c, 0, 0, s, a, 0, 0, 0, 0, 0,                          <<02.eb>>01945000
<<110>> 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,                          <<02.eb>>01950000
<<120>> c;                                                     <<02.eb>>01955000
                                                               <<02.eb>>01960000
array intrin'(*) = intrin;                                     <<02.eb>>01965000
                                                               <<02.eb>>01970000
                                                               <<06097>>01975000
          << >>                                                         01980000
          <<init buffer and byte pointer>>                              01985000
    subroutine initbuf;                                                 01990000
      begin                                                             01995000
          msg _ blank;                                                  02000000
          move msg(1) _ msg,(40);                                       02005000
          bp_2;                                                         02010000
      end;                                                              02015000
                                                                        02020000
                                                                        02025000
          <<format special character>>                                  02030000
    subroutine char(ch);                                                02035000
      value    ch;                                                      02040000
      logical  ch;                                                      02045000
      begin                                                             02050000
          bmsg(bp)_ch;                                                  02055000
          bp := bp + 1;                                                 02060000
      end;                                                              02065000
          <<convert/format octal number>>                               02070000
    subroutine formoct(n);                                              02075000
      value    n;                                                       02080000
      integer  n;                                                       02085000
      begin                                                             02090000
          char(percent);                                                02095000
          ln_ascii(n, 8,bmsg(bp));                                      02100000
          if ln=0 then ln_1;                                            02105000
          move bmsg(bp)_bmsg(bp+6-ln),(6);                              02110000
          bp := bp + ln;                                                02115000
      end;                                                              02120000
          <<format   (seg #).(p-pb loc) >>                              02125000
    subroutine formloc(ix);                                             02130000
      value    ix;                                                      02135000
      logical  ix;                                                      02140000
      begin                                                             02145000
<<if marker info exists for progfile or>>                      <<06097>>02150000
<<not executing program then insert    >>                      <<06097>>02155000
<<log seg # else ?                     >>                      <<06097>>02160000
<<if delta p info exists then insert it>>                      <<06097>>02165000
          char(stop);                                                   02170000
          if loc(ix)<>0 or not progflag                                 02175000
               then  formoct(loc(ix+cstl))                              02180000
               else  char(quest);                                       02185000
          char(stop);                                                   02190000
          if loc(ix)<>0                                                 02195000
               then  formoct(loc(ix+pv)-1)                              02200000
               else  char(quest);                                       02205000
      end;                                                              02210000
          <<format process location  :(file).(seg #).(p-pb loc) >>      02215000
    subroutine procloc;                                                 02220000
      begin                                                             02225000
<<insert progfile name, seg #, and delta p >>                  <<06097>>02230000
          char(colon);                                                  02235000
          move bmsg(bp) _ name,(cnt);                                   02240000
          name _ blank;                                                 02245000
          move name(1) _ name,(cnt);                                    02250000
          bp := bp + cnt;                                               02255000
          formloc(procx);                                               02260000
      end;                                                              02265000
                                                                        02270000
                                                                        02275000
          <<format procreated process  :*xlib.(seg #).(p-pb loc)  >>    02280000
                                                                        02285000
    subroutine prcrloc;                                                 02290000
      begin                                                             02295000
<<insert * sl type, seg #, and delta p>>                       <<06097>>02300000
          char(colon);                                                  02305000
          char(aster);                                                  02310000
          move bmsg(bp)_libr(loc(procx+typl)&lsl(2)),(4);               02315000
          bp := bp + 4;                                                 02320000
          formloc(procx);                                               02325000
      end;                                                              02330000
                                                                        02335000
                                                                        02340000
          <<format library location  : slib.(seg #).(p-pb loc) >>       02345000
                                                                        02350000
    subroutine librloc;                                                 02355000
      begin                                                             02360000
<<insert sl type, seg #, and delta p>>                         <<06097>>02365000
          if loc(librx)=0 then return;                                  02370000
          char(colon);                                                  02375000
          move bmsg(bp)_libr(loc(librx+typl)&lsl(2)),(4);               02380000
          bp := bp + 4;                                                 02385000
          formloc(librx);                                               02390000
      end;                                                              02395000
                                                                        02400000
                                                                        02405000
          <<kill program process structure>>                            02410000
                                                                        02415000
   subroutine killprog;                                                 02420000
     begin                                                              02425000
         if (integer(procstate).ptypefield) = 0 then           <<06643>>02430000
          begin                                                         02435000
           tos := fatherinfo/pcbsize;                          <<06643>>02440000
dadl:      pcbpt := tos * pcbsize;                             <<06643>>02445000
           tos := fatherinfo/pcbsize;                          <<06643>>02450000
           if integer(procstate).ptypefield <> 1 then          <<06643>>02455000
            goto dadl;           <<not user son of main>>               02460000
           del;                                                         02465000
           set'psif(pcbpt,%40);                                <<06643>>02470000
          end;                                                          02475000
    end <<killprog>> ;                                                  02480000
                                                                        02485000
integer subroutine nextset(setno,msgno);                       <<02.eb>>02490000
   value setno,msgno;                                          <<02.eb>>02495000
   integer setno,msgno;                                        <<02.eb>>02500000
begin << extracts byte from intrin array for intrinsics >>     <<02.eb>>02505000
                                                               <<02.eb>>02510000
nextset := if setno = intrinset then                           <<02.eb>>02515000
   if logical(msgno) then intrin'(msgno &lsr(1)).(8:8)         <<02.eb>>02520000
   else intrin'(msgno &lsr(1)).(0:8) else                      <<02.eb>>02525000
      << get left or right byte from array >>                  <<02.eb>>02530000
   if setno = loadset then fsysset else                        <<02.eb>>02535000
   if setno = createset then loadset else 0;                   <<02.eb>>02540000
                                                               <<02.eb>>02545000
end; << nextset >>                                             <<02.eb>>02550000
                                                                        02555000
$page                                                                   02560000
     << >>                                                     <<06097>>02565000
     trapsoff;                                                 <<06097>>02570000
         pinx := pcbpt := curprc;                              <<06643>>02575000
     pinx := pix;                                              <<06097>>02580000
         if procstate.systemprocflag then                      <<06643>>02585000
      suddendeath(310);     <<system process>>                 <<06097>>02590000
         if (critflag' := setcritical) then                    <<06643>>02595000
      suddendeath(311);     <<critical abort>>                 <<06097>>02600000
                                                               <<06097>>02605000
     dbfixed := false;                                         <<06097>>02610000
         if dbxdsinfo.absdbflag then                           <<06643>>02615000
       begin                                                   <<06097>>02620000
         dbfixed := 1;                                         <<06097>>02625000
         push( db );   dbvalue := tos;                         <<06097>>02630000
         resetdb(-1);                                          <<06097>>02635000
       end;                                                    <<06097>>02640000
     dbsave := exchangedb( 0 );  << set db to stack >>         <<06097>>02645000
                                                               <<06097>>02650000
     <<get pcbx info & stack bound>>                           <<06097>>02655000
     pxfixed;    <<db relative pxfixed>>                       <<06664>>02660000
     tos := pxfxqreg;               <<initial q>>              <<06664>>02665000
     push(q);                                                  <<06097>>02670000
     jmin := tos-tos+8;             <<qi-q+8>>                 <<06097>>02675000
     <<get error message indices>>                             <<06097>>02680000
     error := 0;                                               <<06097>>02685000
     move error(1) := error,(5);                               <<06097>>02690000
     pxfxerrlevel:=0;                                          <<06664>>02695000
      index := 0;                                              <<07361>>02700000
      while (index := index+1)<=6 do                           <<07361>>02705000
       begin                                                   <<06097>>02710000
         tos:=pxfxintrerr;                                     <<06664>>02715000
         if = then                                             <<06097>>02720000
           begin                                               <<06097>>02725000
             del;                                              <<06097>>02730000
             go to prl;                                        <<06097>>02735000
           end;                                                <<06097>>02740000
         pxfxintrerr:=0;                                       <<06664>>02745000
          error(index-1):=tos;                                 <<07361>>02750000
       end;                                                    <<06097>>02755000
prl:                                                           <<06097>>02760000
    initbuf;                                                   <<06097>>02765000
    type:=mode.rbite;    <<get trap type>>                     <<06097>>02770000
    if type > 1 then go to abort'pin;                          <<06097>>02775000
                                                               <<06097>>02780000
    <<type=0 arithmetic trap >>                                <<06097>>02785000
    <<type=1 system trap     >>                                <<06097>>02790000
                                                               <<06097>>02795000
    <<check if user trap armed>>                               <<06097>>02800000
    if type=1 then plab:=pxfxstrpplbl                          <<06664>>02805000
    else if arith'trap then plab:=pxfxatrpplbl                 <<06664>>02810000
         else plab:=pxfxcodeplbl;                              <<06664>>02815000
    if plab = 0 then go to abort'pin;                          <<06097>>02820000
    <<trap label exists>>                                      <<06097>>02825000
    cstx:=logical(plab) land %100377; <<mapflag,cst #>>        <<06097>>02830000
    if type = 0 then                                           <<06097>>02835000
      begin << set up parm to user trap procedure >>           <<06097>>02840000
        if instr'trap then code':=code                         <<06097>>02845000
        else if arith'trap then                                <<06097>>02850000
               begin << is code one of traps specified >>      <<06097>>02855000
                     << in arith. mask?                >>      <<06097>>02860000
                 if code < 6 then                              <<06097>>02865000
                   i:=%40&lsr(code)                            <<06097>>02870000
                 else                                          <<06097>>02875000
                   i:=%40&lsl(code-8);                         <<06097>>02880000
                 code':=logical(i) land                        <<06097>>02885000
                      pxfxatrpmask;                            <<06664>>02890000
                 if = then go to abort'pin;                    <<06097>>02895000
               end                                             <<06097>>02900000
             else go to abort'pin;                             <<06097>>02905000
      end;                                                     <<06097>>02910000
                                                               <<06097>>02915000
    <<valid arithmetic trap or systrap>>                       <<06097>>02920000
    <<skip specified number of stack markers>>                 <<06097>>02925000
    stk'position:=i:=0;                                        <<06097>>02930000
    while (i:=i+1) <= integer(mode.lbite)                      <<06097>>02935000
      do stk'position:=stk'position-stack(stk'position);       <<06097>>02940000
                                                               <<06097>>02945000
    <<check stack marker>>                                     <<06097>>02950000
    k:=stack(stk'position-1).rbite; <<cst #>>                  <<06097>>02955000
    k.(0:1):=stack(stk'position-2).mapflag; <<map flag>>       <<06097>>02960000
    mappedcsttophycst(k,pinx);                                 <<06097>>02965000
    if < then go to abort'pin; <<invalid cst #>>               <<06097>>02970000
    if system(k) then go abort'pin; <<trap in system seg>>     <<06097>>02975000
                                                               <<06097>>02980000
    <<trap in non-system seg>>                                 <<06097>>02985000
                                                               <<06097>>02990000
    <<check if armed trap and trapped seg >>                   <<06097>>02995000
    <<are in proper mode                  >>                   <<06097>>03000000
    <<invalid if trapped seg is priv and  >>                   <<06097>>03005000
    <<mode flag is normal                 >>                   <<06097>>03010000
    if stack(stk'position-1) < 0 then                          <<06097>>03015000
      begin       <<trapped seg privileged>>                   <<06097>>03020000
        if type = 1                                            <<06664>>03025000
          then tos:= pxfxsystrp                                <<06664>>03030000
          else if arith'trap then tos:=pxfxarithtrp            <<06664>>03035000
          else tos:=pxfxcodetrp;                               <<06664>>03040000
        if tos = 1 then go abort'pin; <<non-priv mode trap>>   <<06097>>03045000
      end;                                                     <<06097>>03050000
                                                               <<06097>>03055000
    <<trapped seg and trap procedure in proper mode>>          <<06097>>03060000
                                                               <<06097>>03065000
    <<move trapped seg's stack marker to make room>>           <<06097>>03070000
    <<for parameters to be passed to trap procedure>>          <<06097>>03075000
    if type = 0                                                <<06097>>03080000
      then num'parms:=1 <<ari trap>>                           <<06097>>03085000
      else num'parms:=8;<<sys trap>>                           <<06097>>03090000
    i:=0;                                                      <<06097>>03095000
    while (i:=i+1) <= 4 do                                     <<06097>>03100000
      begin                                                    <<06097>>03105000
        stack(stk'position+num'parms):=stack(stk'position);    <<06097>>03110000
        stk'position:=stk'position-1;                          <<06097>>03115000
      end;                                                     <<06097>>03120000
    <<insert passed parameters>>                               <<06097>>03125000
    if type = 0                                                <<06097>>03130000
      then stack(stk'position+1):=code'                        <<06097>>03135000
      else begin                                               <<06097>>03140000
             stack(stk'position+1):=code;                      <<06097>>03145000
             stack(stk'position+2):=param;                     <<06097>>03150000
             i:=2;                                             <<06097>>03155000
             while (i:=i+1) <= num'parms                       <<06097>>03160000
               do stack(stk'position+i):=error(i-3);           <<06097>>03165000
           end;                                                <<06097>>03170000
                                                               <<06097>>03175000
    <<adjust trapped seg stack marker info>>                   <<06097>>03180000
    xx:=stack(-3);           <<xreg from abort marker>>        <<06097>>03185000
    stk'position:=stk'position+num'parms+3; <<to moved marker>><<06097>>03190000
    tos:=stack(stk'position); <<get status reg>>               <<06097>>03195000
    tos.ccfld:=ccl;           <<adjust status >>               <<06097>>03200000
    duplicate;                                                 <<06097>>03205000
    stack(x):=tos;            <<store adjusted status>>        <<06097>>03210000
    tos.rsofld:=0;            <<construct status for trap seg>><<06097>>03215000
    tos.rbite:=cstx.rbite;    << . clear right stack op>>      <<06097>>03220000
    statx:=tos;               << . insert trap seg cst #>>     <<06097>>03225000
    stack(x):=stack(stk'position+1)+num'parms;<<adjust deltaq>><<06097>>03230000
    <<adjust deltaq in call to abort marker>>                  <<06097>>03235000
    <<in case we abort before exit marker  >>                  <<06097>>03240000
    <<is constructed below                 >>                  <<06097>>03245000
    stack(0):=-x;                                              <<06097>>03250000
                                                               <<06097>>03255000
    <<get delta p for trap procedure>>                         <<06097>>03260000
         resetcritical(critflag');                             <<06643>>03265000
    px:=convextlabeltodeltap(plab);                            <<06097>>03270000
    if logicalmapping                                          <<06097>>03275000
      then px.mapflag:=cstx.(0:1); <<insert map flag>>         <<06097>>03280000
                                                               <<06097>>03285000
    <<build exit marker                                        <<06097>>03290000
    stk'position:=stk'position+2;                              <<06097>>03295000
    stack(stk'position):=xx;      <<xreg>>                     <<06097>>03300000
    stack(x:=x+1):=px;            <<delta p>>                  <<06097>>03305000
    stack(x:=x+1):=statx;         <<status>>                   <<06097>>03310000
    stack(x:=x+1):=4;             <<delta q>>                  <<06097>>03315000
    <<adjust q reg>>                                           <<06097>>03320000
    push(q);                                                   <<06097>>03325000
    tos:=tos+x;                                                <<06097>>03330000
    set(q);                                                    <<06097>>03335000
                                                               <<06097>>03340000
    <<exit into user's trap procedure>>                        <<06097>>03345000
    assemble(exit 0);                                          <<06097>>03350000
                                                               <<06097>>03355000
                                                               <<06097>>03360000
abort'pin:                                                     <<06097>>03365000
    <<abort the pin --- no trap>>                              <<06097>>03370000
                                                               <<06097>>03375000
    clear'psif(pinx,%40);                                      <<06097>>03380000
    pxfxerrlevel:=1;                                           <<06664>>03385000
    pxfxaip:=1;                                                <<06664>>03390000
    libx:=pxfxinitcst;                                         <<06664>>03395000
    libx.(0:1):=pxfxcstexpbit;                                 <<06664>>03400000
    progflag:=false;          <<init flag>>                    <<06097>>03405000
    pin:=pinx/pcbsize;                                         <<06097>>03410000
    procfile(pin,name);  <<get name of prog being executed>>   <<06097>>03415000
    if = then                                                  <<06097>>03420000
      begin   <<user program found>>                           <<06097>>03425000
        progflag:=true;                                        <<06097>>03430000
        scan name until %6440,1;                               <<06097>>03435000
        cnt:=tos-@name;                                        <<06097>>03440000
        libx:=0;  <<initial cst is in program>>                <<06097>>03445000
      end;                                                     <<06097>>03450000
                                                               <<06097>>03455000
    <<skip stack markers>>                                     <<06097>>03460000
    stk'position:=k:=i:=0;                                     <<06097>>03465000
    while (i:=i+1) <= integer(mode.lbite)                      <<06097>>03470000
      do stk'position:=stk'position-stack(stk'position);       <<06097>>03475000
                                                               <<06097>>03480000
    k:=stack(stk'position-1).rbite;    <<get cst #>>           <<06097>>03485000
    k.(0:1):=stack(stk'position-2).mapflag; <<map flag>>       <<06097>>03490000
    syscst:=system(k);                 <<get system flag>>     <<06097>>03495000
                                                               <<06097>>03500000
    <<get stack marker info from 1st non-system lib seg>>      <<06097>>03505000
    <<and for first program seg                        >>      <<06097>>03510000
    cstx:=px:=0;                                               <<06097>>03515000
    loc(librx):=loc(procx):=0;                                 <<06097>>03520000
    loc'position:=librx;                                       <<06097>>03525000
next:                                                          <<06097>>03530000
    ppp:=stack(stk'position-2).pfld;      <<delta p>>          <<06097>>03535000
    phy:=stack(stk'position-1).rbite;     <<cst #>>            <<06097>>03540000
    phy.(0:1):= if logicalmapping                              <<06097>>03545000
                  then stack(stk'position-2).mapflag           <<06097>>03550000
                  else 1;                                      <<06097>>03555000
    <<save marker info in array loc>>                          <<06097>>03560000
    loc(loc'position):=stk'position;                           <<06097>>03565000
    loc(x:=x+1):=ppp;                <<delta p>>               <<06097>>03570000
    tos:=logicalcst'(phy,pinx);                                <<06875>>03575000
    loc(x:=x+1):=tos;                <<log seg #>>             <<06097>>03580000
    duplicate;                                                 <<06097>>03585000
    loc(x:=x+1):=tos;                <<lib source>>            <<06097>>03590000
    ltyp:=tos;                       <<lib slurce>>            <<06097>>03595000
    if phy <> cstx then                                        <<06097>>03600000
      begin                                                    <<06097>>03605000
        <<save phy and ppp if phy has changed since>>          <<06097>>03610000
        <<last trip thru this code                 >>          <<06097>>03615000
        cstx:=phy;                                             <<06097>>03620000
        px:=ppp;                                               <<06097>>03625000
      end;                                                     <<06097>>03630000
    if type > 3 and   <<stkoverflow or hardkill trap>>         <<06097>>03635000
       system(phy)    <<marker is for system seg  >>           <<06097>>03640000
      then go bump'stk'position; <<skip marker>>               <<06097>>03645000
                                                               <<06097>>03650000
    if progflag and   <<pin executing program>>                <<06097>>03655000
       ltyp = progsegtype <<marker is for prog seg>>           <<06097>>03660000
      then go cont;   <<stop scanning markers>>                <<06097>>03665000
                                                               <<06097>>03670000
    if phy = libx     <<marker is same as initial cst>>        <<06097>>03675000
      then go cont;   <<stop scanning markers>>                <<06097>>03680000
                                                               <<06097>>03685000
    loc'position:=procx; <<adjust position in array>>          <<06097>>03690000
                                                               <<06097>>03695000
bump'stk'position:                                             <<06097>>03700000
    t:=stk'position-stack(stk'position);                       <<06097>>03705000
    if t >= stk'position or                                    <<06097>>03710000
       t < jmin                                                <<06097>>03715000
      then go to outm;  <<get out if current marker is blown>> <<06097>>03720000
    stk'position:=t;                                           <<06097>>03725000
    go next;                                                   <<06097>>03730000
                                                               <<06097>>03735000
outm:                                                          <<06097>>03740000
    <<blown marker--use info already gathered>>                <<06097>>03745000
    if loc'position = 0   <<during scan for lib seg>>          <<06097>>03750000
      then loc(loc'position+pv):=px; <<delta p>>               <<06097>>03755000
    loc'position:=procx;                                       <<06097>>03760000
    loc(loc'position):=0; <<no progfile info>>                 <<06097>>03765000
    if not progflag then                                       <<06097>>03770000
      begin             <<not executing program>>              <<06097>>03775000
        <<use initial cst info>>                               <<06097>>03780000
        tos:=logicalcst'(libx,pinx);                           <<06875>>03785000
        loc(x:=x+2):=tos;          <<log seg #>>               <<06097>>03790000
        loc(x:=x+1):=tos;          <<lib source>>              <<06097>>03795000
      end;                                                     <<06097>>03800000
    go printmsg;                                               <<06097>>03805000
    help;                                                      <<06097>>03810000
                                                               <<06097>>03815000
cont:                                                          <<06097>>03820000
    if loc'position <> 0                                       <<06097>>03825000
      then go printmsg;  <<found aborted seg>>                 <<06097>>03830000
    <<found prog seg marker during scan for lib seg>>          <<06097>>03835000
    move loc(procx):=loc(librx),(procx);                       <<06097>>03840000
    loc(librx):=0;       <<no lib info>>                       <<06097>>03845000
                                                               <<06097>>03850000
printmsg:                                                      <<06097>>03855000
                                                               <<06097>>03860000
<<  build & print abort message >>                             <<02.eb>>03865000
                                                               <<02.eb>>03870000
move bmsg := "ABORT ";                                         <<02.eb>>03875000
bp := 6;                                                       <<02.eb>>03880000
if progflag then procloc else prcrloc;                         <<02.eb>>03885000
librloc;                                                       <<02.eb>>03890000
bmsg(bp) := 0;                                                 <<02.eb>>03895000
print(msg,0,0);                                                <<02.eb>>03900000
genmsg(-1,@bmsg); << print abort: ed.mpe.%0.%0 >>              <<02.eb>>03905000
if type = 3 then killprog;                                     <<02.eb>>03910000
param' := param;                                               <<02.eb>>03915000
intrindex := if type = 1 then 0 else 6;                        <<02.eb>>03920000
tableno := if type = 1 then intrinset else pgmerrset;          <<02.eb>>03925000
msgno := if type = 0 then code else if type = 1 then code.     <<02.eb>>03930000
   (0:10) else type +16;                                       <<02.eb>>03935000
if type=1 then  <<intrinsic error>>                            <<u.rao>>03940000
   setjcw(%140000 lor logical(msgno+1000))<<lor intrinsic no.>><<u.rao>>03945000
else if type = 0 then  <<internal int. error>>                 <<u.rao>>03950000
   setjcw(%140000 lor logical(msgno))   <<mask lor error no.>> <<u.rao>>03955000
else if type = 5 then   <<program killed, no number>>          <<u.rao>>03960000
   setjcw(%140000)                                             <<u.rao>>03965000
else   <<type is quit or quitprog>>                            <<u.rao>>03970000
   setjcw(%100000 lor param);  <<mask lor user param>>         <<u.rao>>03975000
do begin                                                       <<02.eb>>03980000
   genmsg(miscset,tableno,%10000,msgno,,,,,,,,,%100000);       <<02.eb>>03985000
   genmsg(tableno,msgno,,,,,,,,,,,if param' <> 0 then          <<02.eb>>03990000
      %100000 else 0);                                         <<02.eb>>03995000
   if param' <> 0 then genmsg(miscset,paramsg,%10000,          <<02.eb>>04000000
      param'); << print param = >>                             <<02.eb>>04005000
   tableno := nextset(tableno,msgno);                          <<02.eb>>04010000
   param' := error(intrindex).(0:8); << intrin param >>        <<02.eb>>04015000
   msgno :=  error(intrindex).(8:8); << next msgno >>          <<02.eb>>04020000
   if msgno < 20 then tableno := runtimeset;                   <<02.eb>>04025000
   intrindex := intrindex +1;                                  <<02.eb>>04030000
end until (error(intrindex -1) = 0 or intrindex > 5);          <<02.eb>>04035000
resetcritical(0);                                              <<02.eb>>04040000
                                                               <<02.eb>>04045000
                                                               <<06097>>04050000
<<  abort stack dump mechanism  >>                             <<06097>>04055000
                                                               <<06097>>04060000
<<get flags from pxfixed area>>                                <<06097>>04065000
pxfixed;                                                       <<06664>>04070000
rwf:=not pxfxrw;                       <<read/write access>>   <<06664>>04075000
qin:=pxfxqreg;                         <<q initial>>           <<06664>>04080000
                                                               <<06097>>04085000
<<get flags from pxglob area>>                                 <<06097>>04090000
pxglobal;                                                      <<06664>>04095000
stdf:=pxg'stkdumpflags;                <<stack dump flags>>    <<06664>>04100000
jobtype:=pxg'interactive;              <<interactive flag>>    <<06664>>04105000
                                                               <<06097>>04110000
<<do stack dump analysis if --         >>                      <<06097>>04115000
<< .not hard kill                      >>                      <<06097>>04120000
<< .stack dump armed                   >>                      <<06097>>04125000
<< .aborting seg not system seg        >>                      <<06097>>04130000
if (type<=4) land stdf.(10:1) land not syscst then             <<06097>>04135000
  begin                        <<armed>>                       <<06097>>04140000
    <<output header=title,registers,markers>>                  <<06097>>04145000
                                                               <<06097>>04150000
    <<header>>                                                 <<06097>>04155000
    initbuf;                                                   <<06097>>04160000
    move bmsg:="*** ABORT STACK ANALYSIS ***";                 <<06097>>04165000
    print(msg,-28,0); initbuf;                                 <<06097>>04170000
    print(msg,0,%201);                                         <<06097>>04175000
                                                               <<06097>>04180000
    <<skip specified # stack markers>>                         <<06097>>04185000
    push(q);                                                   <<06097>>04190000
    stk'position:=tos;                                         <<06097>>04195000
    i:=0;                                                      <<06097>>04200000
    while (i:=i+1) <= integer(mode.lbite)                      <<06097>>04205000
      do stk'position:=stk'position-stak(stk'position);        <<06097>>04210000
                                                               <<06097>>04215000
                                                               <<06097>>04220000
    base:=stk'position; <<starting marker position>>           <<06097>>04225000
    bases:=base-4;      <<ending parameter position>>          <<06097>>04230000
                                                               <<06097>>04235000
    <<registers>>                                              <<06097>>04240000
    regist(stk'position,bmsg);                                 <<06097>>04245000
    print(msg,-34,0);                                          <<06097>>04250000
    initbuf;                                                   <<06097>>04255000
                                                               <<06097>>04260000
    <<markers>>                                                <<06097>>04265000
    marker(stk'position,bmsg);                                 <<06097>>04270000
    print(msg,-62,0);                                          <<06097>>04275000
    initbuf;                                                   <<06097>>04280000
    while (stk'position:=                                      <<06097>>04285000
               stk'position-stak(stk'position) ) > qin do      <<s7913>>04290000
      begin                                                    <<06097>>04295000
        marker(stk'position,bmsg);                             <<06097>>04300000
        if < or stak(x)<4 then                                 <<06097>>04305000
          begin                                                <<06097>>04310000
            initbuf;                                           <<06097>>04315000
            move bmsg:="INVALID MARKER";                       <<06097>>04320000
            stk'position:=-1;                                  <<06097>>04325000
          end;                                                 <<06097>>04330000
        print(msg,-62,0);                                      <<06097>>04335000
        initbuf;                                               <<06097>>04340000
      end;                                                     <<06097>>04345000
                                                               <<06097>>04350000
    <<check if further stack dump analysis can be done>>       <<06097>>04355000
    <<no -- if aborting seg is system seg             >>       <<06097>>04360000
                                                               <<06097>>04365000
    t:=stak(base-1).(8:8);  <<cst #>>                          <<06097>>04370000
    t.(0:1):=stak(base-2).mapflag; <<mapflag>>                 <<06097>>04375000
    tos:=logicalcst'(t,pix);                                   <<06875>>04380000
    assemble(del);                                             <<06097>>04385000
    if tos=0 then go out;        <<system sl>>                 <<06097>>04390000
                                                               <<06097>>04395000
    <<check if debug should be called>>                        <<06097>>04400000
    <<yes -- if have read/write access to prog file>>          <<06097>>04405000
    <<       and interactive                       >>          <<06097>>04410000
    if rwf land jobtype then                                   <<06097>>04415000
      begin                        <<ok let's go>>             <<06097>>04420000
        pxfixed;                                               <<06664>>04425000
        pxfxerrlevel:=0;              <<turn off error bit>>   <<06664>>04430000
        dbgcst:=logical(@debug) land %100377; <<mapflag,cst#>> <<06097>>04435000
        dbgdp _ convextlabeltodeltap(@debug);                  <<06097>>04440000
        if logicalmapping                                      <<06097>>04445000
          then dbgdp.mapflag:=dbgcst.(0:1); <<insert mapflag>> <<06097>>04450000
        tos:=base;                                             <<06097>>04455000
        push(q);                                               <<06097>>04460000
        x:=tos-tos;                                            <<06097>>04465000
                                                               <<06097>>04470000
        exchangedb(dbsave);   << restore environment >>        <<06097>>04475000
        if dbfixed then                                        <<06097>>04480000
          begin                                                <<06097>>04485000
            setsysdb;                                          <<06097>>04490000
            tos := dbvalue;                                    <<06097>>04495000
            set( db );                                         <<06097>>04500000
          end;                                                 <<06097>>04505000
                                                               <<06097>>04510000
        stack(x+1):=0;     <<x>>                               <<06097>>04515000
        stack(x+1):=dbgdp;           <<delta p>>               <<06097>>04520000
        stack(x+1):=%140000+dbgcst.rbite; <<status>>           <<06097>>04525000
        stack(x+1):=4;     <<delta q>>                         <<06097>>04530000
                                                               <<06097>>04535000
        disable;                                               <<06097>>04540000
        push( q );                                             <<06097>>04545000
        tos := tos + x;   << offset to exit marker >>          <<06097>>04550000
        set( q );                                              <<06097>>04555000
        assemble( exit 0 );                                    <<06097>>04560000
      end;                                                     <<06097>>04565000
                                                               <<06097>>04570000
    <<check if stack data areas should be dumped>>             <<06097>>04575000
    <<no -- if do not have read/write access to >>             <<06097>>04580000
    <<      progfile or dump not specified      >>             <<06097>>04585000
    pxfixed;                                                   <<06664>>04590000
    if not rwf then go out;                                    <<06097>>04595000
    if stdf.(13:3)=0 then go out;      <<nothing to dump>>     <<06097>>04600000
    pxfxstkdmpenv:=mode&lsr(8)+1;                              <<06664>>04605000
    <<prepare parameters for stackdump>>                       <<06097>>04610000
    j:=2;                                                      <<06097>>04615000
    tos:=-1;             <<stopper>>                           <<06097>>04620000
    tos:=0;                                                    <<06097>>04625000
    if stdf.(13:2)<>0 then                                     <<06097>>04630000
      begin                                                    <<06097>>04635000
        j:=j+2;                                                <<06097>>04640000
        if stdf.(14:1) then                                    <<06097>>04645000
          begin              <<qin to s>>                      <<06097>>04650000
            tos:=bases-qin+1;                                  <<06097>>04655000
            tos:=qin;          <<address>>                     <<06097>>04660000
          end else                                             <<06097>>04665000
          begin              <<q-63 to s>>                     <<06097>>04670000
            tos:=stak(base-stak(base));                        <<06097>>04675000
            assemble(dup);                                     <<06097>>04680000
            if tos>63 then                                     <<06097>>04685000
              begin                                            <<06097>>04690000
                assemble(del);                                 <<06097>>04695000
                tos:=63;                                       <<06097>>04700000
                tos:=bases-x;                                  <<06097>>04705000
                assemble(add);                                 <<06097>>04710000
                tos:=x-63;                                     <<06097>>04715000
              end else                                         <<06097>>04720000
              begin                                            <<06097>>04725000
                tos:=bases-x;                                  <<06097>>04730000
                assemble(add);                                 <<06097>>04735000
                tos:=x-stak(x);                                <<06097>>04740000
              end;                                             <<06097>>04745000
          end;                                                 <<06097>>04750000
      end;                                                     <<06097>>04755000
                                                               <<06097>>04760000
    if stdf then                                               <<06097>>04765000
      begin              <<dl to qin>>                         <<06097>>04770000
        j:=j+2;                                                <<06097>>04775000
        push(dl);                                              <<06097>>04780000
        assemble(dup);                                         <<06097>>04785000
        tos:=tos-qin;                                          <<06097>>04790000
        assemble(neg,xch);                                     <<06097>>04795000
      end;                                                     <<06097>>04800000
                                                               <<06097>>04805000
    i:=-1;                                                     <<06097>>04810000
    while (i:=i+1)<=j do wdump(i):=tos;                        <<06097>>04815000
    stdf:=(stdf&lsr(3)) xor 1;                                 <<s8763>>04820000
    stackdump(,,stdf,dump(0));                                 <<06097>>04825000
                                                               <<06097>>04830000
  end;                                                         <<06097>>04835000
                                                               <<06097>>04840000
out:                                                           <<06097>>04845000
    terminate;                                                 <<06097>>04850000
                                                               <<06097>>04855000
  end;                                                         <<06097>>04860000
$page                                                                   04865000
            << >>                                                       04870000
<<********************************************************>>            04875000
<<******  callable - capability 0 -   traps       ********>>            04880000
<<********************************************************>>            04885000
            <<user process abort . (type=2)                             04890000
               num = quit identification for user          >>           04895000
<<********************************************************>>            04900000
            << >>                                                       04905000
procedure quit(num);                                                    04910000
  value   num;                                                          04915000
  integer num;                                                          04920000
  option  privileged;                                                   04925000
  begin                                                                 04930000
          equate type=2, mark=1, mode=[8/mark,8/type];                  04935000
          << >>                                                         04940000
          abort(mode,0,num);                                            04945000
  end;                                                                  04950000
$page                                                                   04955000
            << >>                                                       04960000
<<********************************************************>>            04965000
<<******  callable - capability 0 -   traps       ********>>            04970000
<<********************************************************>>            04975000
            <<user program abort . (type=3)                             04980000
               num = quitprog identification for user       >>          04985000
<<********************************************************>>            04990000
            << >>                                                       04995000
procedure quitprog(num);                                                05000000
  value   num;                                                          05005000
  integer num;                                                          05010000
  option  privileged;                                                   05015000
  begin                                                                 05020000
          equate type=3, mark=1, mode=[8/mark,8/type];                  05025000
          << >>                                                         05030000
          abort(mode,0,num);                                            05035000
  end;                                                                  05040000
$page                                                                   05045000
                                                                        05050000
<<********************************************************>>            05055000
<<******  callable - capability 0 -   traps       ********>>            05060000
<<********************************************************>>            05065000
          <<enable/disable hardware arithmetic trap internal            05070000
               interrupt.                                               05075000
                                                                        05080000
               state = true  enable traps                               05085000
                     = false disable traps                              05090000
                                                                        05095000
               code: cc=0 ok. disabled originally                       05100000
                     cc>0 ok. enabled originally                        05105000
                     cc<0 (null)                           >>           05110000
<<********************************************************>>            05115000
            << >>                                                       05120000
procedure aritrap(state);                                               05125000
  value   state;                                                        05130000
  logical state;                                                        05135000
  option  privileged;                                                   05140000
  begin                                                                 05145000
          equate errn=51,exitn=1;                                       05150000
          equate errex=[10/errn,6/exitn];                               05155000
          << >>                                                         05160000
          erroron;                                                      05165000
          tos _ status; duplicate;                                      05170000
          tos.ccfld _ tos.trapfld&lsl(1)+cce;                           05175000
          tos.trapfld _ state;                                          05180000
          tos.(4:1) _ 0;               <<overflow bit>>                 05185000
          status _ tos;                                                 05190000
          errorexit(errex,0,0);                                         05195000
  end;                                                                  05200000
$page                                                          <<03046>>05205000
procedure xdsntrap (plabel,oldplabel);                         <<06873>>05210000
                                                               <<06873>>05215000
comment                                                        <<06873>>05220000
   set pxfixed word pxfxdstrap with plabel for ds cleanup use  <<06873>>05225000
   returns oldplabel in second parameter                       <<06873>>05230000
   cce    trap enabled                                         <<06873>>05235000
   ccg    trap disabled                                        <<06873>>05240000
   pcal to cleanup routine takes place in morgue               <<06873>>05245000
   ;  <<end comment>>                                          <<06873>>05250000
                                                               <<06873>>05255000
value plabel;                                                  <<06873>>05260000
integer plabel,oldplabel;                                      <<06873>>05265000
option privileged,uncallable;                                  <<06873>>05270000
begin                                                          <<06873>>05275000
logical pxfixedloc;                                            <<06873>>05280000
array qarray(*) = q+0;                                         <<06873>>05285000
integer status = q-1;                                          <<06873>>05290000
integer s0 = s-0;                                              <<06873>>05295000
                                                               <<06873>>05300000
pxfixed;  <<point to pxfixed area>>                            <<06873>>05305000
oldplabel := pxfxdstrap;                                       <<06873>>05310000
tos := plabel;                                                 <<06873>>05315000
if <> then                                                     <<06873>>05320000
   status.ccfld := cce      << trap enabled  >>                <<06873>>05325000
else                                                           <<06873>>05330000
   status.ccfld := ccg;     << trap disabled >>                <<06873>>05335000
pxfxdstrap := tos;                                             <<06873>>05340000
end;                                                           <<06873>>05345000
logical procedure checktraplabel(plabel,userstackmarker);      <<03046>>05350000
value plabel,userstackmarker;                                           05355000
                                                                        05360000
<<function                                                              05365000
  checks that the user's label meets all the rules for plabels.         05370000
  interrupt procedure rules.                                            05375000
                                                                        05380000
  caller's code domain     interrupt procedure requirements             05385000
  --------------------     --------------------------------             05390000
  nonpriv program seg      nonpriv; prog, group sl, acct sl             05395000
                                                                        05400000
  priv; prog, group sl     priv or nonpriv; prog, group sl,             05405000
  acct sl                  acct sl                                      05410000
                                                                        05415000
  priv or nonpriv,         priv or nonpriv; in any non-mpe              05420000
  non-mpe system sl        system sl>>                                  05425000
                                                                        05430000
<<input>>                                                               05435000
  integer                                                               05440000
    plabel,              <<user trap procedure's plabel>>               05445000
    userstackmarker;     <<# words from caller's stack marker to        05450000
                           the user's stack marker.  this stack         05455000
                           marker is used to determine the              05460000
                           permissible range of the plabel.>>           05465000
                                                                        05470000
<<output                                                                05475000
   checktraplabel         the trap procedure mode.                      05480000
                                  0 - procedure may execute in          05485000
                                      privileged mode.                  05490000
                                  1 - procedure may only execute        05495000
                                      in user mode.                     05500000
    conditioncode          cce - valid plabel                           05505000
                           ccl - illegal plabel                         05510000
                           ccg - not returned.>>                        05515000
                                                                        05520000
option privileged,uncallable;                                           05525000
                                                                        05530000
begin                                                                   05535000
logical                                                                 05540000
  status=q-1;                                                           05545000
define                                                                  05550000
  returncondcode     = status.(6:2)#;                                   05555000
equate                                                                  05560000
  systemsl           = 0,                                               05565000
  programseg         = 3,                                               05570000
  cce                = 2,                                               05575000
  ccl                = 1;                                               05580000
integer array                                                           05585000
  stackmarker(*)=q+0;                                                   05590000
integer                                                                 05595000
  callerstatus,callertype,proceduretype,callercstn,procedurecstn,       05600000
  pcbpt,pin,traplogicalcst,segid;                                       05605000
integer callermap,trapmap;                                     <<06097>>05610000
                                                                        05615000
subroutine checkexit(conditioncode);                                    05620000
value conditioncode;                                                    05625000
integer conditioncode;                                                  05630000
  begin                                                                 05635000
  returncondcode:=conditioncode;                                        05640000
  assemble(exit 2);                                                     05645000
  end;  <<checkexit>>                                                   05650000
<<initialization>>                                                      05655000
pin := (pcbpt := curprc)/pcbsize;                              <<06643>>05660000
callerstatus:=stackmarker(-stackmarker-userstackmarker-1);              05665000
callermap:=stackmarker(x-1).(1:1);                             <<06097>>05670000
callercstn:=callerstatus.(8:8);                                <<06097>>05675000
callercstn.(0:1):=if logicalmapping then callermap else 1;     <<06097>>05680000
tos:=logicalcst'(callercstn,0);                                <<06875>>05685000
del; callertype:=tos;                                                   05690000
tos:=logicalcst'(plabel,0);                                    <<06875>>05695000
if < then checkexit(ccl);                                      <<*8529>>05700000
procedurecstn:=plabel;                                         <<06097>>05705000
traplogicalcst:=tos;                                                    05710000
proceduretype:=tos;                                                     05715000
checktraplabel:=1;                                             <<06097>>05720000
<<check label validity>>                                                05725000
if callertype = programseg then                                         05730000
   begin  <<program>>                                                   05735000
   traplogicalcst.(0:4):=proceduretype;                        <<06097>>05740000
   physicalcst(pin,traplogicalcst);                                     05745000
   if <> then checkexit(ccl);                                           05750000
   end                                                                  05755000
else if callertype = systemsl then                                      05760000
   begin  <<system sl>>                                                 05765000
   if not system(callercstn) and system(procedurecstn) then             05770000
      checkexit(ccl);                                                   05775000
   checktraplabel:=0;                                          <<06097>>05780000
   end                                                                  05785000
else                                                                    05790000
   begin  <<user-prog, gsl, psl>>                                       05795000
   if proceduretype = systemsl then checkexit(ccl);                     05800000
   if callerstatus < 0 then                                             05805000
      checktraplabel:=0                                        <<06097>>05810000
   else                                                                 05815000
      begin  <<caller is nonpriv, therefore trap proc must be nonpriv>> 05820000
      if log(dstl'(cstconv(procedurecstn,0)).(1:1)) then       <<06097>>05825000
        checkexit(ccl);  <<mode error>>                                 05830000
      checktraplabel := 1;                                     <<06097>>05835000
      end;                                                              05840000
   end;                                                                 05845000
                                                                        05850000
checkexit(cce);                                                         05855000
end;  <<checktraplabel>>                                                05860000
$page                                                          <<03046>>05865000
logical procedure traplabel(n,mask,plab,xmask,xplab,mode);     <<06097>>05870000
   value n,plab,mask;                                          <<06097>>05875000
   integer n,plab,mask,xmask,xplab,mode;                       <<06097>>05880000
   option privileged,uncallable;                               <<06097>>05885000
                                                               <<06097>>05890000
<<********************************************************>>   <<06097>>05895000
<< set up trap mechanism :                                >>   <<06097>>05900000
<<                                                        >>   <<06097>>05905000
<<   - check the validity of plabel.                      >>   <<06097>>05910000
<<   - put plabel and mask in pcbx.                       >>   <<06097>>05915000
<<   - check trap procedure executing mode and put the    >>   <<06097>>05920000
<<     mode in pcbx(6).                                   >>   <<06097>>05925000
<<   - return the old trap label and mask word.           >>   <<06097>>05930000
<<                                                        >>   <<06097>>05935000
<< input :                                                >>   <<06097>>05940000
<<                                                        >>   <<06097>>05945000
<<   n     : trap type.   15 = arith trap.                >>   <<06097>>05950000
<<                        16 = lib trap.                  >>   <<06097>>05955000
<<                        17 = sys trap.                  >>   <<06097>>05960000
<<                        18 = ctl-y trap.                >>   <<06097>>05965000
<<                        22 = insert horizon cleanup plab>>   <<06874>>05970000
<<                        63 = code trap.                 >>   <<06097>>05975000
<<   mask  : mask word for arith trap.                    >>   <<06097>>05980000
<<   plab  : trap procedure label.                        >>   <<06097>>05985000
<<             =  0 -- disarm trap.                       >>   <<06097>>05990000
<<             <> 0 -- arm trap.                          >>   <<06097>>05995000
<<                                                        >>   <<06097>>06000000
<< output :                                               >>   <<06097>>06005000
<<                                                        >>   <<06097>>06010000
<<   xmask : old mask word extracted from pcbx.           >>   <<06097>>06015000
<<   xplab : old trap procedure label extracted from pcbx.>>   <<06097>>06020000
<<   mode  : non-priv/priv mode of trap procedure         >>   <<06097>>06025000
<<   condcode : cce = trap armed.                         >>   <<06097>>06030000
<<              ccg = trap disarmed.                      >>   <<06097>>06035000
<<              ccl = illegal plabel.                     >>   <<06097>>06040000
<<                                                        >>   <<06097>>06045000
<< special note :                                         >>   <<06097>>06050000
<<     debug calls this routine with n=19 mainly for      >>   <<06097>>06055000
<<     checking the validity of plabel. if n=19 is true   >>   <<06097>>06060000
<<     then pcbx updating code should be bypassed.        >>   <<06097>>06065000
<<********************************************************>>   <<06097>>06070000
                                                               <<06097>>06075000
begin                                                          <<06097>>06080000
                                                               <<06097>>06085000
   equate  debuglab   = -1;                                    <<06664>>06090000
   logical pxfixedloc;                                         <<06664>>06095000
   integer array stak(*) = q+0;                                <<06664>>06100000
   logical array qarray(*) = q+0;                              <<06664>>06105000
   integer pointer p;                                          <<06097>>06110000
   integer callstatus,                                         <<06097>>06115000
           callplabel,                                         <<06097>>06120000
           calllcst,                                           <<06097>>06125000
           calltype,                                           <<06097>>06130000
           traplcst,                                           <<06097>>06135000
           traptype,                                           <<06097>>06140000
           callmap,                                            <<06097>>06145000
           ccerr,                                              <<06097>>06150000
           index;                                              <<06097>>06155000
                                                               <<06097>>06160000
   <<*****************************************>>               <<06097>>06165000
   << get caller plabel                       >>               <<06097>>06170000
   <<*****************************************>>               <<06097>>06175000
                                                               <<06097>>06180000
   ccerr:=cce;                                                 <<06097>>06185000
   callstatus:=stak(-stak(0)-1);                               <<06097>>06190000
   if logicalmapping then                                      <<06097>>06195000
      callmap:=stak(-stak(0)-2).mapflag                        <<06097>>06200000
   else                                                        <<06097>>06205000
      callmap:=1;  <<sign bit is 1 for external label>>        <<06097>>06210000
   callplabel:=callstatus.rbite;                               <<06097>>06215000
   callplabel.(0:1):=callmap;                                  <<06097>>06220000
                                                               <<06097>>06225000
   <<*********************************************>>           <<06097>>06230000
   << process arm/disarm traps                    >>           <<06097>>06235000
   <<*********************************************>>           <<06097>>06240000
                                                               <<06097>>06245000
   if n=pxaplab and mask=0 or plab=0 then   << disarm trap >>  <<06664>>06250000
      begin                                                    <<06097>>06255000
         ccerr:=ccg;                                           <<06097>>06260000
         mask:=0;                                              <<06097>>06265000
      end                                                      <<06097>>06270000
   else                                       << arm trap    >><<06097>>06275000
      begin                                                    <<06097>>06280000
         <<***************************************>>           <<06097>>06285000
         << get caller segment info               >>           <<06097>>06290000
         <<***************************************>>           <<06097>>06295000
                                                               <<06097>>06300000
         tos:=logicalcst'(callplabel,pix);                     <<06875>>06305000
         if < then                                             <<06097>>06310000
            begin                                              <<06097>>06315000
err:                                                           <<06097>>06320000
               ccerr:=ccl;                                     <<06097>>06325000
               go to fin;                                      <<06097>>06330000
            end;                                               <<06097>>06335000
         calllcst:=tos;                                        <<06097>>06340000
         calltype:=tos;                                        <<06097>>06345000
                                                               <<06097>>06350000
         <<********************************************>>      <<06097>>06355000
         << get trap segment info                      >>      <<06097>>06360000
         <<********************************************>>      <<06097>>06365000
                                                               <<06097>>06370000
         tos:=logicalcst'(logical(plab) land %100377,pix);     <<06875>>06375000
         if < then                                             <<06097>>06380000
            go to err;                                         <<06097>>06385000
         traplcst:=tos;                                        <<06097>>06390000
         traptype:=tos;                                        <<06097>>06395000
                                                               <<06097>>06400000
         <<********************************************>>      <<06097>>06405000
         << if caller seg is in system sl then         >>      <<06097>>06410000
         <<  - mpe seg can trap to any sys sl seg      >>      <<06097>>06415000
         <<  - non-mpe seg can trap to non-mpe seg only>>      <<06097>>06420000
         <<********************************************>>      <<06097>>06425000
                                                               <<06097>>06430000
         mode:=1;                   <<set trap nonpriv >>      <<06097>>06435000
         if calltype = 0 then          <<sys sl seg    >>      <<06097>>06440000
            if system(callplabel) then <<mpe seg       >>      <<06097>>06445000
               mode:=0                 <<set trap priv >>      <<06097>>06450000
            else                       <<non-mpe seg   >>      <<06097>>06455000
               if system(plab) then    <<non-mpe to mpe>>      <<06097>>06460000
                  go err                                       <<06097>>06465000
               else                    <<ok            >>      <<06097>>06470000
         else                          <<prog/gsl/psl  >>      <<06097>>06475000
            if traptype=0 then         <<trap to sys sl>>      <<06097>>06480000
               go err                                          <<06097>>06485000
            else                                               <<06097>>06490000
               if callstatus < 0 then  <<caller prived >>      <<06097>>06495000
                  mode:=0              <<set trap priv >>      <<06097>>06500000
               else                    <<caller nonpriv>>      <<06097>>06505000
                  begin                                        <<06097>>06510000
                     index:=cstconv(plab,pix);                 <<06097>>06515000
                     if index = 0 then                         <<06097>>06520000
                        go err;        <<bad plabel    >>      <<06097>>06525000
                     if dstl'(index).(1:1) then                <<06097>>06530000
                        go err;        <<trap to priv  >>      <<06097>>06535000
                  end;                                         <<06097>>06540000
      end;                                                     <<06097>>06545000
                                                               <<06097>>06550000
   <<**********************************>>                      <<06097>>06555000
   << update pcbx                      >>                      <<06097>>06560000
   <<**********************************>>                      <<06097>>06565000
                                                               <<06097>>06570000
   if n=debuglab then                                          <<06097>>06575000
      go fin;                                                  <<06097>>06580000
                                                               <<06097>>06585000
   pxfixed;                                                    <<06664>>06590000
   if n = pxhplab then                                         <<06874>>06595000
      begin    << insert horizon cleanup plabel >>             <<06874>>06600000
      xplab := pxfxhorzplbl;                                   <<06874>>06605000
      pxfxhorzplbl := plab;                                    <<06874>>06610000
      go fin;                                                  <<06874>>06615000
      end;                                                     <<06874>>06620000
                                                               <<06874>>06625000
                                                               <<06097>>06630000
   case n-15 of                                                <<06664>>06635000
      begin                                                    <<06664>>06640000
         <<0>>  begin                                          <<06664>>06645000
                   pxfxarithtrp:=mode;                         <<06664>>06650000
                   xplab:=pxfxatrpplbl;                        <<06664>>06655000
                   pxfxatrpplbl:=plab;                         <<06664>>06660000
                   xmask:=pxfxatrpmask;                        <<06664>>06665000
                   pxfxatrpmask := mask;                       <<07306>>06670000
                end;                                           <<06664>>06675000
                                                               <<06664>>06680000
         <<1>>  begin                                          <<06664>>06685000
                   pxfxlibtrp:=mode;                           <<06664>>06690000
                   xplab:=pxfxltrpplbl;                        <<06664>>06695000
                   pxfxltrpplbl:=plab;                         <<06664>>06700000
                end;                                           <<06664>>06705000
                                                               <<06664>>06710000
         <<2>>  begin                                          <<06664>>06715000
                   pxfxsystrp:=mode;                           <<06664>>06720000
                   xplab:=pxfxstrpplbl;                        <<06664>>06725000
                   pxfxstrpplbl:=plab;                         <<06664>>06730000
                end;                                           <<06664>>06735000
                                                               <<06664>>06740000
         <<3>>  begin                                          <<06664>>06745000
                   pxfxctlytrp:=mode;                          <<06664>>06750000
                   xplab:=pxfxctlyplbl;                        <<06664>>06755000
                   pxfxctlyplbl:=plab;                         <<06664>>06760000
                end;                                           <<06664>>06765000
                                                               <<06664>>06770000
         <<4>>  begin                                          <<06664>>06775000
                   pxfxcodetrp:=mode;                          <<06664>>06780000
                   xplab:=pxfxcodeplbl;                        <<06664>>06785000
                   pxfxcodeplbl:=plab;                         <<06664>>06790000
                end;                                           <<06664>>06795000
      end;                                                     <<06664>>06800000
fin:                                                           <<06097>>06805000
   traplabel:=ccerr;                                           <<06097>>06810000
end;                                                           <<06097>>06815000
$page                                                                   06820000
$page                                                          <<06874>>06825000
procedure xhtrap(plabel,oldplabel);                            <<06874>>06830000
   value plabel;                                               <<06874>>06835000
   integer plabel,oldplabel;                                   <<06874>>06840000
   option privileged,uncallable;                               <<06874>>06845000
begin                                                          <<06874>>06850000
                                                               <<06874>>06855000
<< will enable/disable the horizon cleanup procedure upon    >><<06874>>06860000
<< process termination.                                      >><<06874>>06865000
<<                                                           >><<06874>>06870000
<< entry:                                                    >><<06874>>06875000
<<   plabel <> 0 external plabel                             >><<06874>>06880000
<<   plabel  = 0 clear the plabel field.                     >><<06874>>06885000
<<                                                           >><<06874>>06890000
<< exit:                                                     >><<06874>>06895000
<<   oldplabel - previous plabel returned.                   >><<06874>>06900000
<<                                                           >><<06874>>06905000
<< condition code:                                           >><<06874>>06910000
<<   cce  - request granted. cleanup procedure set.          >><<06874>>06915000
<<   ccg  - request granted. cleanup procedure disabled.     >><<06874>>06920000
<<   ccl  - request denied because of illegal plabel, or db  >><<06874>>06925000
<<          not at stack.                                    >><<06874>>06930000
                                                               <<06874>>06935000
equate                                                         <<06874>>06940000
   ccl            =   1,                                       <<06874>>06945000
   intrin'num     =  0,    <<                                >><<06874>>06950000
   num'parms      =  2,    <<                                >><<06874>>06955000
   exit'num       = num'parms, <<                            >><<06874>>06960000
                                                               <<06874>>06965000
   parm'checking  = %10,       << check addr of plabel parm. >><<06874>>06970000
   intrin'exit    = [10/intrin'num,6/exit'num];                <<06874>>06975000
                                                               <<06874>>06980000
integer                                                        <<06874>>06985000
   dummy;                   <<                               >><<06874>>06990000
                                                               <<06874>>06995000
                                                               <<06874>>07000000
erroron;                                                       <<06874>>07005000
chek(intrin'exit,num'parms,double(parm'checking));             <<06874>>07010000
if carry then                                                  <<06874>>07015000
   begin      << opps...db not at stack >>                     <<06874>>07020000
   status.ccfld := ccl;                                        <<06874>>07025000
   errorexit(intrin'exit,0,0);                                 <<06874>>07030000
   end;                                                        <<06874>>07035000
                                                               <<06874>>07040000
status.ccfld := traplabel(pxhplab,dummy,plabel,dummy,          <<06874>>07045000
                          oldplabel,dummy);                    <<06874>>07050000
errorexit(intrin'exit,0,0);                                    <<06874>>07055000
end;           << procedure xhtrap >>                          <<06874>>07060000
$page                                                          <<06874>>07065000
            << >>                                                       07070000
<<********************************************************>>            07075000
<<******  callable - capability 0 -   traps       ********>>            07080000
<<********************************************************>>            07085000
            <<arm/disarm arithmetic trap mechanism with selective       07090000
               mask and external label. returns the original            07095000
               mask and external label.                                 07100000
                                                                        07105000
               mask  = bit mask for arm(=1)/disarm(=0)                  07110000
                             bit 15 - flt pt divide by 0                07115000
                             bit 14 - integer divide by 0               07120000
                             bit 13 - flt pt underflow                  07125000
                             bit 12 - integer underflow                 07130000
                             bit 11 - integer overflow                  07135000
                             bit 10 - dbl. prec. overflow      <<b0.01  07140000
                             bit  9 - dbl. prec. underflow     <<b0.01  07145000
                             bit  8 - dbl. prec. div. by zero  <<b0.01  07150000
                             bit  7 - decimal overflow         <<b0.07  07155000
                             bit  6 - invalid ascii digit      <<b0.07  07160000
                             bit  5 - invalid source word count<<b0.07  07165000
                             bit  4 - invalid decimal digit    <<b0.07  07170000
                             bit  3 - invalid decimal operand  <<b0.07  07175000
                                      length                   <<b0.07  07180000
                             bit  2 - decimal div zero         <<b0.07  07185000
               plab  <> 0 external label                                07190000
                     =  0 disarm mechanism                              07195000
                                                                        07200000
               code: cc=0 ok. armed                                     07205000
                     cc>0 ok. disarmed                                  07210000
                     cc<0 no. illegal plab                 >>           07215000
<<********************************************************>>            07220000
            << >>                                                       07225000
procedure xaritrap(mask,plab,xmask,xplab);                              07230000
  value   mask,plab;                                                    07235000
  integer mask,plab,xmask,xplab;                                        07240000
  option  privileged;                                                   07245000
  begin                                                                 07250000
    integer mode;                                              <<06097>>07255000
          equate errn=50,exitn=4;                                       07260000
          equate errex=[10/errn,6/exitn];                               07265000
          << >>                                                         07270000
          erroron;                                                      07275000
          chek(errex,%4,%240d);                                         07280000
          ccode:=traplabel(pxaplab,mask,plab,xmask,xplab,mode);<<06097>>07285000
          errorexit(errex,0,0);                                         07290000
  end;                                                                  07295000
$page                                                                   07300000
            << >>                                                       07305000
<<********************************************************>>            07310000
<<******  callable - capability 0 -   traps       ********>>            07315000
<<********************************************************>>            07320000
            <<arm/disarm library trap mechanism with external           07325000
               label. returns the original external label.              07330000
                                                                        07335000
               plab  <> 0 external label                                07340000
                     =  0 disarm mechanism                              07345000
                                                                        07350000
               code: cc=0 ok. armed                                     07355000
                     cc>0 ok. disarmed                                  07360000
                     cc<0 no. illegal plab                 >>           07365000
<<********************************************************>>            07370000
            << >>                                                       07375000
procedure xlibtrap(plab,xplab);                                         07380000
  value   plab;                                                         07385000
  integer plab,xplab;                                                   07390000
  option  privileged;                                                   07395000
  begin                                                                 07400000
    integer mode;                                              <<06097>>07405000
          equate errn=52,exitn=2;                                       07410000
          equate errex=[10/errn,6/exitn];                               07415000
          integer dum;                                                  07420000
          << >>                                                         07425000
          erroron;                                                      07430000
          chek(errex,%2,%10d);                                          07435000
          ccode:=traplabel(pxlplab,0,plab,dum,xplab,mode);     <<06097>>07440000
          errorexit(errex,0,0);                                         07445000
  end;                                                                  07450000
$page                                                                   07455000
            << >>                                                       07460000
<<********************************************************>>            07465000
<<******  callable - capability 0 -   traps       ********>>            07470000
<<********************************************************>>            07475000
            <<arm/disarm system trap mechanism with external            07480000
               label. returns the original external label.              07485000
                                                                        07490000
               plab  <> 0 external label                                07495000
                     =  0 disarm mechanism                              07500000
                                                                        07505000
               code: cc=0 ok. armed                                     07510000
                     cc>0 ok. disarmed                                  07515000
                     cc<0 no. illegal plab                 >>           07520000
<<********************************************************>>            07525000
            << >>                                                       07530000
procedure xsystrap(plab,xplab);                                         07535000
  value   plab;                                                         07540000
  integer plab,xplab;                                                   07545000
  option  privileged;                                                   07550000
  begin                                                                 07555000
    integer mode;                                              <<06097>>07560000
          equate errn=53,exitn=2;                                       07565000
          equate errex=[10/errn,6/exitn];                               07570000
          integer dum;                                                  07575000
          << >>                                                         07580000
          erroron;                                                      07585000
          chek(errex,%2,%10d);                                          07590000
          ccode:=traplabel(pxsplab,0,plab,dum,xplab,mode);     <<06097>>07595000
          errorexit(errex,0,0);                                         07600000
  end;                                                                  07605000
logical procedure ctlytrap'legal(stdin);                       <<06097>>07610000
  <<return true if process can legally set ctl-y trap>>        <<06097>>07615000
  <<return standard input device                     >>        <<06097>>07620000
  integer stdin;                                               <<06097>>07625000
  option privileged,uncallable;                                <<*7857>>07630000
  begin                                                        <<06097>>07635000
    equate stinx=3;                                            <<06097>>07640000
    integer pcbglobloc;                                        <<06664>>07645000
    array qarray(*)=q+0;                                       <<06664>>07650000
    ctlytrap'legal:=false;  <<initialize>>                     <<06097>>07655000
    pxglobal;                                                  <<06664>>07660000
    stdin:=pxg'inputldev;        <<std input device>>          <<06664>>07665000
    tos:=pxg'jobtype;            <<job type>>                  <<06664>>07670000
    if tos = 1 then ctlytrap'legal:=true; <<session>>          <<06097>>07675000
  end;                                                         <<06097>>07680000
            << >>                                              <<03046>>07685000
<<********************************************************>>   <<03046>>07690000
<<******  callable - capability 0 -   traps       ********>>   <<03046>>07695000
<<********************************************************>>   <<03046>>07700000
<<          arm/disarm code trap mechanism with external  >>   <<03046>>07705000
<<          label. returns the original external label.   >>   <<03046>>07710000
<<          the traps handled by this mechanism are:      >>   <<03046>>07715000
<<             privileged mode instr.                     >>   <<03046>>07720000
<<             unimplememted instr.                       >>   <<03046>>07725000
<<             stt uncallable                             >>   <<03046>>07730000
<<             bad stack marker                           >>   <<03046>>07735000
<<             illegal address                            >>   <<03046>>07740000
<<             bounds violation                           >>   <<03046>>07745000
<<             non-responding module                      >>   <<03046>>07750000
<<             stack underflow                            >>   <<03046>>07755000
<<             cst violation                              >>   <<03046>>07760000
<<             stt violation                              >>   <<03046>>07765000
<<                                                        >>   <<03046>>07770000
<<             plab  <> 0 external label                  >>   <<03046>>07775000
<<                   =  0 disarm mechanism                >>   <<03046>>07780000
<<                                                        >>   <<03046>>07785000
<<             code: cc=0 ok. armed                       >>   <<03046>>07790000
<<                   cc>0 ok. disarmed                    >>   <<03046>>07795000
<<                   cc<0 no. illegal plab                >>   <<03046>>07800000
<<********************************************************>>   <<03046>>07805000
            << >>                                              <<03046>>07810000
procedure xcodetrap(plab,xplab);                               <<03046>>07815000
  value   plab;                                                <<03046>>07820000
  integer plab,xplab;                                          <<03046>>07825000
  option  privileged;                                          <<03046>>07830000
  begin                                                        <<03046>>07835000
    integer mode;                                              <<06097>>07840000
          equate errn=57,exitn=2;                              <<03046>>07845000
          equate errex=[10/errn,6/exitn];                      <<03046>>07850000
          integer dum;                                         <<03046>>07855000
          << >>                                                <<03046>>07860000
          erroron;                                             <<03046>>07865000
          chek(errex,%2,%10d);                                 <<03046>>07870000
          ccode:=traplabel(pxcplab,0,plab,dum,xplab,mode);     <<06097>>07875000
          errorexit(errex,0,0);                                <<03046>>07880000
  end;                                                         <<03046>>07885000
$page                                                                   07890000
            << >>                                                       07895000
<<********************************************************>>            07900000
<<******  callable - capability 0 -   traps       ********>>            07905000
<<********************************************************>>            07910000
            <<arm/disarm "CONTROL Y" mechanism with external            07915000
               label.returns the original external label.               07920000
                                                                        07925000
               plab  <> 0 external label                                07930000
                     =  0 disarm mechanism                              07935000
                                                                        07940000
               code: cc=0 ok. armed                                     07945000
                     cc>0 ok. disarmed                                  07950000
                     cc<0 no. illegal plab                 >>           07955000
<<********************************************************>>            07960000
            << >>                                                       07965000
                                                                        07970000
                                                                        07975000
procedure xcontrap(plabel,oldplabel);                                   07980000
value plabel;                                                           07985000
integer plabel,oldplabel;                                               07990000
option privileged;                                                      07995000
                                                                        08000000
comment: sets up the control y mecanism for the caller process.         08005000
         retirns:                                                       08010000
            cc=cce   ok control y armed                                 08015000
            cc=ccg   ok control y disarmed                              08020000
            cc=ccl   failure                                            08025000
                        1.not a session                                 08030000
                        2.illegal plabel(not external/system label...)  08035000
                                                                        08040000
            oldplabel is an external label.                             08045000
      ;                                                                 08050000
                                                                        08055000
begin                                                                   08060000
          equate errn=54,exitn=2;                                       08065000
          equate errex=[10/errn,6/exitn];                               08070000
    integer mode,dum;                                          <<06097>>08075000
      integer ldt'index;                                       <<07052>>08080000
      integer stdin,cc,pin;                                             08085000
      array ldt(*) = db+0;                                     <<07052>>08090000
                                                                        08095000
                                                                        08100000
    erroron;                                                   <<06097>>08105000
    chek(errex,%2,%10d);                                       <<06097>>08110000
    status.ccfld:=ccl;                                         <<06097>>08115000
    if ctlytrap'legal(stdin) then                              <<06097>>08120000
      begin               <<pin can set ctl-y trap>>           <<06097>>08125000
        if plabel <> 0 then                                    <<06097>>08130000
          begin           <<arm trap>>                         <<06097>>08135000
            pin:=pix/pcbsize;                                  <<06097>>08140000
settrap:                                                       <<06097>>08145000
      ccode:=traplabel(18,pxcyplab,plabel,dum,oldplabel,mode); <<06664>>08150000
                  if  ccode = ccl then go finish; <<error>>    <<06097>>08155000
            tos := exchangedb(ldt'dst);                        <<07052>>08160000
            ldt'index := stdin * size'of'ldt'entry;            <<07052>>08165000
            ldt'control'y'pin := pin;                          <<07052>>08170000
            exchangedb(*);                                     <<06097>>08175000
            if plabel <> 0 then iocontrol(stdin,13);           <<06097>>08180000
          end                                                  <<06097>>08185000
         else                                                  <<06097>>08190000
          begin           <<dis arm trap>>                     <<06097>>08195000
            pin:=0;                                            <<06097>>08200000
            iocontrol(stdin,12);                               <<06097>>08205000
            go settrap;                                        <<06097>>08210000
          end;                                                 <<06097>>08215000
      end;                                                     <<06097>>08220000
finish:                                                        <<06097>>08225000
    errorexit(errex,0,0);                                      <<06097>>08230000
end;  << x c o n t r a p  >>                                            08235000
$page                                                                   08240000
                                                                        08245000
procedure resetcontrol;                                                 08250000
option privileged;                                                      08255000
                                                                        08260000
comment: resets process environment from cy to naormal.                 08265000
      retirns cce if ok                                                 08270000
              ccl if failure:the process was not rumnig in cy mode.     08275000
      ;                                                                 08280000
                                                                        08285000
begin                                                                   08290000
integer                                                        <<00.eb>>08295000
   cc,                                                         <<00.eb>>08300000
   index;                                                      <<00.eb>>08305000
                                                               <<00.eb>>08310000
integer plabel;                                                <<06097>>08315000
integer pcbpt;                                                 <<06643>>08320000
array qarray(*) = q+0;                                         <<06664>>08325000
integer pcbglobloc;                                            <<06664>>08330000
integer array q0(*) = q+0;                                     <<06664>>08335000
                                                               <<00.eb>>08340000
pointer cst = 1;                                               <<00.eb>>08345000
                                                               <<00.eb>>08350000
define sysbit = (11:1) #;                                      <<00.eb>>08355000
                                                               <<00.eb>>08360000
equate stdin = 3;                                              <<00.eb>>08365000
                                                               <<00.eb>>08370000
logical subroutine pxglob(index);                              <<00.eb>>08375000
   value index;                                                <<00.eb>>08380000
   integer index;                                              <<00.eb>>08385000
comment     *** works only if db at stack *** ;                <<00.eb>>08390000
begin                                                          <<00.eb>>08395000
                                                               <<00.eb>>08400000
assemble(                                                      <<00.eb>>08405000
pshr %40;     << dl >>                                         <<00.eb>>08410000
ldxn 1;       << pcbx globe ptr 1 below dl >>                  <<00.eb>>08415000
subm s-0,i,x; << offset to pxglob >>                           <<00.eb>>08420000
stax,adbx;    << x:= offset + index >>                         <<00.eb>>08425000
load db+0,x;  << get value >>                                  <<00.eb>>08430000
stor s-3;);   << put in return value >>                        <<00.eb>>08435000
end; << pxglob >>                                              <<00.eb>>08440000
pcbpt := curprc;                                               <<06643>>08445000
erroron;                                                       <<00.eb>>08450000
chek(55 &lsl(6),0); << db must be at stack >>                  <<00.eb>>08455000
                                                               <<00.eb>>08460000
<< check pcb pseudo int.mode for ctl y >>                      <<00.eb>>08465000
if integer(piinfo).psimfield = 5 then                          <<06643>>08470000
begin << ctly occurred >>                                      <<00.eb>>08475000
   piinfo.psimfield := 7;                                      <<06643>>08480000
   cc := cce;                                                  <<00.eb>>08485000
   << look back in markers for a ctly marker >>                <<00.eb>>08490000
   index := -1; << look at status word in marker >>            <<00.eb>>08495000
   plabel:=q0(index).(8:8);     <<cst #>>                      <<06097>>08500000
   plabel.(0:1):=if logicalmapping then q0(index-1).mapflag    <<06097>>08505000
                                   else 1;                     <<06097>>08510000
   while system(plabel) do                                     <<06097>>08515000
     begin   <<marker for system seg. skip to next marker>>    <<06097>>08520000
       index:=index-q0(index+1);                               <<06097>>08525000
       plabel:=q0(index).(8:8);       <<cst #>>                <<06097>>08530000
       plabel.(0:1):=if logicalmapping then q0(index-1).mapflag<<06097>>08535000
                                       else 1;                 <<06097>>08540000
     end; <<while>>                                            <<06097>>08545000
   << reset delta p bit 0 >>                                   <<00.eb>>08550000
   q0(index-1).(0:1) := 0;                                     <<00.eb>>08555000
                                                               <<00.eb>>08560000
   pxglobal;                                                   <<06664>>08565000
   resetbreakbits(integer(pxg'inputldev),0);                   <<06664>>08570000
   resumesoftint;                                              <<03046>>08575000
end                                                            <<00.eb>>08580000
else cc := ccl;                                                <<00.eb>>08585000
                                                               <<00.eb>>08590000
status.(6:2) := cc;                                            <<00.eb>>08595000
errorexit(55 &lsl(6),0,0);                                     <<00.eb>>08600000
                                                               <<00.eb>>08605000
end; << resetcontrol >>                                        <<00.eb>>08610000
$page                                                                   08615000
procedure setusertrap(error,option'nums,options);              <<06097>>08620000
  <<this is an extension of all the user trap >>               <<06097>>08625000
  <<procedures.  it allows traps to be called >>               <<06097>>08630000
  <<by physically mapped as well as logically >>               <<06097>>08635000
  <<mapped procedures.                        >>               <<06097>>08640000
  <<condition code returned--                 >>               <<06097>>08645000
  <<  . cce = ok armed                        >>               <<06097>>08650000
  <<  . ccg = ok unarmed                      >>               <<06097>>08655000
  <<  . ccl = error                           >>               <<06097>>08660000
  <<                                          >>               <<06097>>08665000
  integer error;           <<error return>>                    <<06097>>08670000
  integer array option'nums;<<option numbers>>                 <<06097>>08675000
  logical array options;    <<corresponding options>>          <<06097>>08680000
  option privileged;                                           <<06097>>08685000
  begin                                                        <<06097>>08690000
    double stk'lims;                                           <<06097>>08695000
    integer stk'lolim=stk'lims,stk'hilim=stk'lims+1;           <<06097>>08700000
    integer traptype,plabel,mask,mode,temp,pin,stdin;          <<06097>>08705000
    integer pointer old'plabel,old'mask,old'mode;              <<06097>>08710000
    logical endoflist;                                         <<06097>>08715000
    integer savedst;                                           <<06097>>08720000
    array ldt(*) = db+0;                                       <<07052>>08725000
    equate intrin'data  = [10/86,6/3],                         <<06097>>08730000
           chk'flag     = [8/0,2/0,1/0,5/3],                   <<06097>>08735000
           chk'parm     = [10/0,2/2,2/2,2/2],                  <<06097>>08740000
           errex        = [10/86,6/3];                         <<06097>>08745000
    equate maxopts=6,                                          <<06097>>08750000
           aritrap=15,                                         <<06097>>08755000
           ctly   =18;                                         <<06097>>08760000
    integer ldt'index;                                         <<07052>>08765000
                                                               <<07052>>08770000
    equate err1 = 1,  <<invalid option>>                       <<06097>>08775000
           err2 = 2,  <<invalid traptype>>                     <<06097>>08780000
           err3 = 3,  <<invalid old'plabel address>>           <<06097>>08785000
           err4 = 4,  <<invalid old'mode address>>             <<06097>>08790000
           err5 = 5,  <<invalid old'mask address>>             <<06097>>08795000
           err6 = 6,  <<invalid mode value>>                   <<06097>>08800000
           err7 = 7,  <<invalid traplabel>>                    <<06097>>08805000
           err8 = 8;  <<required parameter missing>>           <<06097>>08810000
                                                               <<06097>>08815000
    subroutine adjust'ldt;                                     <<06097>>08820000
      <<insert pin into ldt>>                                  <<06097>>08825000
      begin                                                    <<06097>>08830000
        savedst := exchangedb(ldt'dst);                        <<07052>>08835000
        ldt'index := stdin * size'of'ldt'entry;                <<07052>>08840000
        ldt'control'y'pin := pin;                              <<07052>>08845000
        savedst:=exchangedb(savedst);                          <<06097>>08850000
      end; <<adjust'ldt>>                                      <<06097>>08855000
                                                               <<06097>>08860000
    logical subroutine settrap;                                <<06097>>08865000
      <<call traplabel to set trap>>                           <<06097>>08870000
      begin                                                    <<06097>>08875000
        settrap:=true;      <<initialize>>                     <<06097>>08880000
        ccode:=traplabel(traptype,mask,plabel,old'mask,        <<06097>>08885000
                    old'plabel,mode);                          <<06097>>08890000
        if ccode=ccl then                                      <<06097>>08895000
          begin         <<invalid trap>>                       <<06097>>08900000
            error:=err7;                                       <<06097>>08905000
            settrap:=false;                                    <<06097>>08910000
          end;                                                 <<06097>>08915000
      end; <<settrap>>                                         <<06097>>08920000
                                                               <<06097>>08925000
    subroutine figure'options;                                 <<06097>>08930000
      <<figure values passed>>                                 <<06097>>08935000
      begin                                                    <<06097>>08940000
        <<set up default values>>                              <<06097>>08945000
        traptype:=-1;                                          <<06097>>08950000
        mask:=-1;                                              <<06097>>08955000
        plabel:=-1;                                            <<06097>>08960000
        mode:=-1;                                              <<06097>>08965000
        @old'plabel:=-1;                                       <<06097>>08970000
        @old'mask:=-1;                                         <<06097>>08975000
        endoflist:=false;                                      <<06097>>08980000
        <<check values passed>>                                <<06097>>08985000
        temp:=0;                                               <<06097>>08990000
        while temp <= maxopts and                              <<06097>>08995000
              not endoflist do                                 <<06097>>09000000
          begin                                                <<06097>>09005000
            if not (0<=option'nums(temp)<=maxopts) then        <<06097>>09010000
              begin  <<invalid option number>>                 <<06097>>09015000
                endoflist:=true;                               <<06097>>09020000
              end                                              <<06097>>09025000
             else                                              <<06097>>09030000
              begin  <<valid option number>>                   <<06097>>09035000
                case *option'nums(temp) of                     <<06097>>09040000
                 begin                                         <<06097>>09045000
                 <<0>> endoflist:=true;                        <<06097>>09050000
                 <<1>> if traptype = -1 then                   <<06097>>09055000
                         begin <<1st occurrence>>              <<06097>>09060000
                           traptype:=options(temp);            <<06097>>09065000
                           <<check validity>>                  <<06097>>09070000
                           if not (1<=traptype<=4) then        <<06097>>09075000
                             begin <<invalid>>                 <<06097>>09080000
                               error:=err2;                    <<06097>>09085000
                               go returnerror;                 <<06097>>09090000
                             end;                              <<06097>>09095000
                           traptype:=traptype+14; <<adjust>>   <<06097>>09100000
                         end                                   <<06097>>09105000
                        else endoflist:=true; <<2nd occurrence><<06097>>09110000
                 <<2>> if mask = -1                            <<06097>>09115000
                         then mask:=options(temp) <<1st time>> <<06097>>09120000
                         else endoflist:=true;    <<2nd time>> <<06097>>09125000
                 <<3>> if plabel = -1                          <<06097>>09130000
                         then plabel:=options(temp)<<1st time>><<06097>>09135000
                         else endoflist:=true;     <<2nd time>><<06097>>09140000
                 <<4>> if mode = -1 then                       <<06097>>09145000
                         begin                     <<1st time>><<06097>>09150000
                           mode:=options(temp);                <<06097>>09155000
                           <<check validity>>                  <<06097>>09160000
                           if mode = 0 then                    <<06097>>09165000
                             begin <<original call>>           <<06097>>09170000
                               mode:= if logicalmapping        <<06097>>09175000
                                        then 0                 <<06097>>09180000
                                        else 1;                <<06097>>09185000
                             end                               <<06097>>09190000
                            else                               <<06097>>09195000
                             begin <<using encoded mode>>      <<06097>>09200000
                               if mode.(0:3) = 5 then          <<06097>>09205000
                                 begin <<valid encoded value>> <<06097>>09210000
                                   mode:=mode.(15:1);          <<06097>>09215000
                                 end                           <<06097>>09220000
                                else                           <<06097>>09225000
                                 begin <<invalid value>>       <<06097>>09230000
                                   error:=err6;                <<06097>>09235000
                                   go returnerror;             <<06097>>09240000
                                 end;                          <<06097>>09245000
                             end;                              <<06097>>09250000
                         end                                   <<06097>>09255000
                        else endoflist:=true;      <<2nd time>><<06097>>09260000
                 <<5>> if @old'plabel = -1 then                <<06097>>09265000
                         begin                     <<1st time>><<06097>>09270000
                           @old'plabel:=options(temp);         <<06097>>09275000
                           <<check validity>>                  <<06097>>09280000
                           if not (stk'lolim<=@old'plabel      <<06097>>09285000
                                            <=stk'hilim) then  <<06097>>09290000
                             begin <<invalid address>>         <<06097>>09295000
                               error:=err3;                    <<06097>>09300000
                               go returnerror;                 <<06097>>09305000
                             end;                              <<06097>>09310000
                         end                                   <<06097>>09315000
                        else endoflist:=true;      <<2nd time>><<06097>>09320000
                 <<6>> if @old'mask = -1 then                  <<06097>>09325000
                         begin                     <<1st time>><<06097>>09330000
                           @old'mask:=options(temp);           <<06097>>09335000
                           <<check validity>>                  <<06097>>09340000
                           if not (stk'lolim<=@old'mask        <<06097>>09345000
                                            <=stk'hilim) then  <<06097>>09350000
                             begin <<invalid address>>         <<06097>>09355000
                               error:=err5;                    <<06097>>09360000
                               go returnerror;                 <<06097>>09365000
                             end;                              <<06097>>09370000
                         end                                   <<06097>>09375000
                        else endoflist:=true;      <<2nd time>><<06097>>09380000
                 end; <<cases>>                                <<06097>>09385000
              end;                                             <<06097>>09390000
            temp:=temp+1;                                      <<06097>>09395000
          end; <<while>>                                       <<06097>>09400000
        if option'nums(temp-1) <> 0 then                       <<06097>>09405000
          begin <<invalid option>>                             <<06097>>09410000
            error:=err1;                                       <<06097>>09415000
            go returnerror;                                    <<06097>>09420000
          end;                                                 <<06097>>09425000
        <<verify required parameters are present>>             <<06097>>09430000
        if traptype = -1 or                                    <<06097>>09435000
           plabel   = -1 or                                    <<06097>>09440000
           mode     = -1 or                                    <<06097>>09445000
           @old'plabel=-1 then                                 <<06097>>09450000
          begin  <<parameter missing>>                         <<06097>>09455000
            error:=err8;                                       <<06097>>09460000
            go returnerror;                                    <<06097>>09465000
          end;                                                 <<06097>>09470000
        if traptype = aritrap and                              <<06097>>09475000
           (mask = -1 or @old'mask = -1) then                  <<06097>>09480000
          begin  <<parameter missing>>                         <<06097>>09485000
            error:=err8;                                       <<06097>>09490000
            go returnerror;                                    <<06097>>09495000
          end;                                                 <<06097>>09500000
      end; <<figure'options>>                                  <<06097>>09505000
                                                               <<06097>>09510000
                                                               <<06097>>09515000
    erroron;                                                   <<06097>>09520000
    stk'lims:=chek'noabort(intrin'data,chk'flag,               <<06097>>09525000
                               double(chk'parm));              <<06097>>09530000
    figure'options;                                            <<06097>>09535000
    error:=0;      <<initialize>>                              <<06097>>09540000
    status.ccfld:=cce;                                         <<06097>>09545000
    if traptype <> ctly then                                   <<06097>>09550000
      begin        <<ari/lib/sys trap>>                        <<06097>>09555000
        settrap;                                               <<06097>>09560000
      end                                                      <<06097>>09565000
     else                                                      <<06097>>09570000
      begin        <<ctly trap>>                               <<06097>>09575000
        if ctlytrap'legal(stdin) then                          <<06097>>09580000
          begin    <<pin can set ctly trap>>                   <<06097>>09585000
            if plabel <> 0 then                                <<06097>>09590000
              begin <<arming trap>>                            <<06097>>09595000
                pin:=pix/pcbsize;                              <<06097>>09600000
                if settrap then                                <<06097>>09605000
                  begin <<valid trap>>                         <<06097>>09610000
                    adjust'ldt; <<put pin in ldt>>             <<06097>>09615000
                    iocontrol(stdin,13);                       <<06097>>09620000
                  end;                                         <<06097>>09625000
              end                                              <<06097>>09630000
             else                                              <<06097>>09635000
              begin <<unarming trap>>                          <<06097>>09640000
                iocontrol(stdin,12);                           <<06097>>09645000
                if settrap then adjust'ldt;                    <<06097>>09650000
              end;                                             <<06097>>09655000
          end                                                  <<06097>>09660000
         else                                                  <<06097>>09665000
          begin     <<pin cannot set ctly trap>>               <<06097>>09670000
            error:=err7                                        <<06097>>09675000
          end;                                                 <<06097>>09680000
      end;                                                     <<06097>>09685000
returnerror:                                                   <<06097>>09690000
    if error <> 0 then status.ccfld:=ccl;                      <<06097>>09695000
    errorexit(errex,0,0);                                      <<06097>>09700000
  end;                                                         <<06097>>09705000
$page                                                                   09710000
                                                               <<b0.02>>09715000
procedure dec'sim'trap(trapnum);                               <<b0.07>>09720000
  value trapnum;                                               <<b0.07>>09725000
  integer trapnum;                                             <<b0.07>>09730000
  option privileged;                                           <<b0.07>>09735000
                                                               <<b0.07>>09740000
begin                                                          <<b0.07>>09745000
  comment this procedure simulates procedure traps in passing  <<b0.07>>09750000
    traps from the decimal firmware simulations to procedure   <<b0.07>>09755000
    abort.  it assumes the opcode and sdec are in certain      <<b0.07>>09760000
    locations q-relative to the user stack marker.  this is    <<b0.07>>09765000
    taken advantage of by popping the two top stack markers    <<b0.07>>09770000
    before accessing this data.                                <<b0.07>>09775000
    ;                                                          <<b0.07>>09780000
  integer xreg=x,  <<index register>>                          <<b0.07>>09785000
          dq=q+0,  <<delta q>>                                 <<b0.07>>09790000
          param=q+1,   <<error parameter(opcode on entry)>>    <<b0.07>>09795000
          sdec=q+2,  <<sdec implicitly passed by firmwaresim>> <<b0.07>>09800000
          tnum=s-5;                                            <<b0.07>>09805000
  integer array stack(*)=q+0;                                  <<b0.07>>09810000
  equate type=0,mark=1,mode=[8/mark,8/type];                   <<b0.07>>09815000
    tos:=0d;  <<logicalcst return>>                            <<06097>>09820000
    tos:=status.cstfield;     <<cst #>>                        <<06097>>09825000
    tos.(0:1):=if logicalmapping then deltap.mapflag else 1;   <<06097>>09830000
    tos:=logicalcst'(*,pix);                                   <<06875>>09835000
  del;                                                         <<b0.07>>09840000
  if tos=systemsl then    <<came from firmwaresim>>            <<b0.07>>09845000
    begin                                                      <<b0.07>>09850000
      xreg:=-(stack(-dq)+dq)-1;<<disp to user sm>>             <<b0.07>>09855000
      tos:=stack(xreg);<<user status>>                         <<b0.07>>09860000
      assemble(tbc 2);                                         <<b0.07>>09865000
      if = then <<traps off>>                                  <<b0.07>>09870000
        begin                                                  <<b0.07>>09875000
          assemble(tsbc 4);<<set overflow>>                    <<b0.07>>09880000
          stack(xreg):=tos;<<replace user status>>             <<b0.07>>09885000
          push(q);                                             <<b0.07>>09890000
          tos:=tos+xreg+1;<<reset sm>>                         <<b0.07>>09895000
          set(q);                                              <<b0.07>>09900000
          tos:=%31400+sdec;                                    <<b0.07>>09905000
          assemble(xeq 0);                                     <<b0.07>>09910000
        end                                                    <<b0.07>>09915000
      else                                                     <<b0.07>>09920000
        begin    <<traps on>>                                  <<b0.07>>09925000
          del;   <<delete user status>>                        <<b0.07>>09930000
          push(s,q);                                           <<b0.07>>09935000
          tos:=xreg+1;                                         <<b0.07>>09940000
          assemble(dup,cab);                                   <<b0.07>>09945000
          tos:=tos+tos;                                        <<b0.07>>09950000
          set(q);                                              <<b0.07>>09955000
          tos:=tos+tos+1;  <<new s pointer>>                   <<b0.07>>09960000
          xreg:=param;                                         <<b0.07>>09965000
          param:=tnum;                                         <<b0.07>>09970000
          set(s);                                              <<b0.07>>09975000
          abort(mode,param,0);                                 <<b0.07>>09980000
        end;                                                   <<b0.07>>09985000
    end;                                                       <<b0.07>>09990000
end; <<dec'sim'trap>>                                          <<b0.07>>09995000
$page                                                                   10000000
                                                               <<b0.07>>10005000
procedure dec'sim'trap'(opcode,trapnum);                       <<b0.07>>10010000
value opcode,trapnum;                                          <<b0.07>>10015000
integer opcode,trapnum;                                        <<b0.07>>10020000
option privileged;                                             <<b0.07>>10025000
begin                                                          <<b0.07>>10030000
  comment this procedure interfaces traps coming from divd,    <<b0.07>>10035000
    mpyd and edit with the regular decimal firmwaresim         <<b0.07>>10040000
    trap mechanism.;                                           <<b0.07>>10045000
  integer array stack(*)=q+0;                                  <<b0.07>>10050000
  integer dq=q+0;  <<delta q>>                                 <<b0.07>>10055000
  equate type=0, mark=1;                                                10060000
  equate sdecdisp=-4;<<displacement from user sm to sdec>>     <<b0.07>>10065000
    tos:=0d;  <<logicalcst return>>                            <<06097>>10070000
    tos:=status.cstfield;     <<cst #>>                        <<06097>>10075000
    tos.(0:1):=if logicalmapping then deltap.mapflag else 1;   <<06097>>10080000
    tos:=logicalcst'(*,pix);                                   <<06875>>10085000
  del;                                                         <<b0.07>>10090000
  if tos = systemsl then <<came from system>>                  <<b0.07>>10095000
    begin                                                      <<b0.07>>10100000
      stack(-dq+1):=opcode;                                    <<b0.07>>10105000
      stack(-dq+2):=stack(-dq+sdecdisp)&lsl(1)+1;              <<00.02>>10110000
      dec'sim'trap(trapnum);                                   <<b0.07>>10115000
    end                                                        <<b0.07>>10120000
end; <<dec'sim'trap'>>                                         <<b0.07>>10125000
                                                               <<c0.00>>10130000
        <<--------------------->>                              <<c0.00>>10135000
        <<  s t a c k d u m p  >>                              <<c0.00>>10140000
        <<  r o u t i n e s    >>                              <<c0.00>>10145000
        <<--------------------->>                              <<c0.00>>10150000
                                                               <<c0.00>>10155000
                                                               <<c0.00>>10160000
procedure regist(sx,boutbuf);                                  <<c0.00>>10165000
                value sx;                                      <<c0.00>>10170000
                integer sx;                                    <<c0.00>>10175000
                byte array boutbuf;                            <<c0.00>>10180000
                option privileged,uncallable;                  <<c0.00>>10185000
begin                                                          <<c0.00>>10190000
    comment:                                                   <<c0.00>>10195000
    << gets s, dl, and z regs from marker located at sx and    <<c0.00>>10200000
    << formats them in output buffer boutbuf;                  <<c0.00>>10205000
                                                               <<c0.00>>10210000
    move boutbuf _ "S=";                                                10215000
    ascii(sx-4,8,boutbuf(2));                                  <<c0.00>>10220000
    move boutbuf(12):="DL=";                                   <<c0.00>>10225000
    tos:=0d;                                                   <<c0.00>>10230000
    push(dl);                                                  <<c0.00>>10235000
    ascii(*,8,boutbuf(15));                                    <<c0.00>>10240000
    move boutbuf(25):="Z=";                                    <<c0.00>>10245000
    push(z);                                                   <<c0.00>>10250000
    ascii(*,8,boutbuf(27));                                    <<c0.00>>10255000
end  <<procedure regist>>;                                     <<c0.00>>10260000
                                                               <<c0.00>>10265000
                                                               <<c0.00>>10270000
<<--------------------------------------------------------------->>     10275000
                                                               <<c0.00>>10280000
                                                               <<c0.00>>10285000
procedure marker(p,boutbuf);                                   <<c0.00>>10290000
                value p;                                       <<c0.00>>10295000
                integer p;                                     <<c0.00>>10300000
                byte array boutbuf;                            <<c0.00>>10305000
                option privileged,uncallable;                  <<c0.00>>10310000
begin                                                          <<c0.00>>10315000
    comment:                                                   <<c0.00>>10320000
    << extracts content of marker pointed to by p and formats  <<c0.00>>10325000
    << it in output buffer boutbuf.                            <<c0.00>>10330000
    <<                                                         <<c0.00>>10335000
    << returns ccl if cst is invalid;                          <<c0.00>>10340000
                                                               <<c0.00>>10345000
  byte array sd(0:12)=pb:="PU1010RL1010";                      <<c0.00>>10350000
  byte array cc(0:12)=pb:="CCGCCLCCE 3 ";                      <<c0.00>>10355000
  array stack(*)=db+0;                                         <<c0.00>>10360000
  integer dq=q+0,                                              <<c0.00>>10365000
          x,                                                   <<c0.00>>10370000
          v;                                                   <<c0.00>>10375000
                                                               <<c0.00>>10380000
          <<-------------------->>                             <<c0.00>>10385000
                                                               <<c0.00>>10390000
    move boutbuf _ "Q=";                                                10395000
    ascii(p,8,boutbuf(2));                                     <<c0.00>>10400000
    move boutbuf(9):="P=";                                     <<c0.00>>10405000
    ascii(stack(p-2).(2:14)-1,8,boutbuf(11));                  <<06097>>10410000
    tos:=0d;       <<logicalcst return>>                       <<06097>>10415000
    tos:=stack(p-1).(8:8);  <<cst #>>                          <<06097>>10420000
   tos.(0:1):=if logicalmapping then stack(p-2).mapflag else 1;<<06097>>10425000
    tos:=logicalcst'(*,pix);                                   <<06875>>10430000
    if < then                                                  <<c0.00>>10435000
      begin                                                    <<c0.00>>10440000
        status.ccfld _ ccl;                                             10445000
        return;                                                <<c0.00>>10450000
      end;                                                     <<c0.00>>10455000
    assemble(zero,xch);                                        <<c0.00>>10460000
    tos:=ascii(*,8,boutbuf(23));                               <<c0.00>>10465000
    assemble(del);                                             <<c0.00>>10470000
    move boutbuf(19):="LCST= ";                                <<c0.00>>10475000
    if s0 = progsegtype then                                   <<06097>>10480000
      begin        <<lib source = prog file>>                  <<06097>>10485000
        assemble(del);                                         <<06097>>10490000
        tos:=" ";                                              <<06097>>10495000
      end                                                      <<06097>>10500000
     else                                                      <<06097>>10505000
      begin        <<lib source = sl>>                         <<06097>>10510000
        case tos of                                            <<06097>>10515000
          begin                                                <<06097>>10520000
            <<0>> tos:="S";                                    <<06097>>10525000
            <<1>> tos:="P";                                    <<06097>>10530000
            <<2>> tos:="G";                                    <<06097>>10535000
          end;                                                 <<06097>>10540000
      end;                                                     <<06097>>10545000
    boutbuf(25):=tos;                                          <<c0.00>>10550000
                                                               <<c0.00>>10555000
    move boutbuf(31):="STAT= , , , , , ,   ";                  <<c0.00>>10560000
    tos:=stack(p-1);                                           <<c0.00>>10565000
    v:=-1;                                                     <<c0.00>>10570000
    while (v:=v+1)<=5 do                                       <<c0.00>>10575000
    begin                                                      <<c0.00>>10580000
      assemble(test);                                          <<c0.00>>10585000
      x:= if < then 2*v else 2*v+1;                            <<c0.00>>10590000
      move boutbuf(36+2*v):=sd(x),(1);                         <<c0.00>>10595000
      tos:=tos&lsl(1);                                         <<c0.00>>10600000
    end;                                                       <<c0.00>>10605000
                                                               <<c0.00>>10610000
    v:=tos&lsr(14);                                            <<c0.00>>10615000
    move boutbuf(48):=cc(v*3),(3);                             <<c0.00>>10620000
    move boutbuf(54):="X=";                                    <<c0.00>>10625000
    ascii(stack(p-3),8,boutbuf(56));                           <<c0.00>>10630000
    status.ccfld _ cce;                                                 10635000
end  <<procedure marker>>;                                     <<c0.00>>10640000
                                                               <<c0.00>>10645000
                                                               <<c0.00>>10650000
<<--------------------------------------------------------------->>     10655000
                                                               <<c0.00>>10660000
                                                               <<c0.00>>10665000
procedure stackdump(filen,idnumber,flag ,selec);               <<c0.00>>10670000
                   byte array filen;                           <<c0.00>>10675000
                   integer idnumber;                           <<c0.00>>10680000
                   logical flag;                               <<c0.00>>10685000
                   double array selec;                         <<c0.00>>10690000
                   option privileged,variable;                 <<c0.00>>10695000
begin                                                          <<c0.00>>10700000
    comment:                                                   <<c0.00>>10705000
    << intrinsic #77.                                          <<c0.00>>10710000
    << dumps stack according to specs;                         <<c0.00>>10715000
                                                               <<c0.00>>10720000
  entry stackdump';                                            <<c0.00>>10725000
                                                               <<c0.00>>10730000
  equate jstl=4;               <<job $stdlist in pcbx>>                 10735000
  array outb(0:128);                                           <<c0.00>>10740000
  byte array boutb(*)=outb;                                    <<c0.00>>10745000
  integer xreg=x,                                                       10750000
          stat=q-1,                                            <<c0.00>>10755000
          fn,                                                  <<c0.00>>10760000
          cc,                                                  <<c0.00>>10765000
          recsize,                                             <<c0.00>>10770000
          pcbglobloc,                                          <<06664>>10775000
          errcode:=77;                                         <<c0.00>>10780000
  logical var=q-4,                                             <<c0.00>>10785000
          pf:=false,                                           <<c0.00>>10790000
          pxfixedloc,                                          <<06664>>10795000
          foptions,                                            <<c0.00>>10800000
          aoptions;                                            <<c0.00>>10805000
  integer adum=q-7,                                            <<c0.00>>10810000
          dummy,                                               <<c0.00>>10815000
          ldt'index,                                           <<07052>>10820000
          sx;                                                  <<c0.00>>10825000
  array ldt(*)=db+0,                                           <<c0.00>>10830000
        qarray(*)=q+0,                                         <<06664>>10835000
        wint(0:40);                      <<temporary>>         <<c0.00>>10840000
  logical flags;                                               <<c0.00>>10845000
  byte array tit(0:50)=pb:=                                    <<c0.00>>10850000
      "***      STACK  DISPLAY      ***          ID #      ";  <<c0.00>>10855000
  integer array st(*)=db+0;                                    <<c0.00>>10860000
  integer s0=s-0,                                              <<c0.00>>10865000
          s1=s-1,                                              <<c0.00>>10870000
          s2=s-2,                                              <<c0.00>>10875000
          v,                                                   <<c0.00>>10880000
          t,                                                   <<c0.00>>10885000
          w,                                                   <<c0.00>>10890000
          dstx;                                                <<c0.00>>10895000
  logical sbf;                                                 <<c0.00>>10900000
  integer qr,                                                  <<c0.00>>10905000
          qin,                                                 <<02341>>10910000
          sr,                                                  <<c0.00>>10915000
          dbad,                                                <<c0.00>>10920000
          count,                                               <<c0.00>>10925000
          lbound,                                              <<c0.00>>10930000
          ubound;                                              <<c0.00>>10935000
  logical areaf;                                               <<c0.00>>10940000
  integer envir:=0,                                            <<c0.00>>10945000
          lkount,                                              <<c0.00>>10950000
          px;                                                  <<c0.00>>10955000
  double bounds=lbound;                                        <<c0.00>>10960000
  logical af:=true;                                            <<c0.00>>10965000
  integer curselx:=-1,                                         <<c0.00>>10970000
          lim,                                                 <<c0.00>>10975000
          wpl,                                                 <<c0.00>>10980000
          l1,                                                  <<c0.00>>10985000
          l2,                                                  <<c0.00>>10990000
          l3;                                                  <<c0.00>>10995000
  array is(0:1);                                               <<c0.00>>11000000
  byte array bis(*)=is;                                        <<c0.00>>11005000
  integer ot,                                                  <<c0.00>>11010000
          lines,                                               <<c0.00>>11015000
          cw,                                                  <<c0.00>>11020000
          cl;                                                  <<c0.00>>11025000
  logical uf;                                                  <<c0.00>>11030000
  byte array mad(0:20)=pb:="..DB.. ..Q... ..S... ";            <<c0.00>>11035000
  define ccl= < #,                                             <<c0.00>>11040000
         ccg= > #,                                             <<c0.00>>11045000
         cce= = #;                                             <<c0.00>>11050000
                                                               <<c0.00>>11055000
          <<-------------------->>                             <<c0.00>>11060000
                                                               <<c0.00>>11065000
  subroutine filerr;                                           <<c0.00>>11070000
  begin                                                        <<c0.00>>11075000
    if pf then idnumber:=0                                     <<c0.00>>11080000
      else fcheck(fn,idnumber);                                <<c0.00>>11085000
    cc:=1;                                                     <<c0.00>>11090000
    go fini;                                                   <<c0.00>>11095000
  end  <<subroutine filerr>>;                                  <<c0.00>>11100000
                                                               <<c0.00>>11105000
          <<-------------------->>                             <<c0.00>>11110000
                                                               <<c0.00>>11115000
  subroutine clearbuf;                                         <<c0.00>>11120000
  begin                                                        <<c0.00>>11125000
        comment:                                               <<c0.00>>11130000
        << clears the output buffer;                           <<c0.00>>11135000
    outb:="  ";                                                <<c0.00>>11140000
    move outb(1):=outb,(recsize&lsr(1));                       <<c0.00>>11145000
  end  <<subroutine clearbuf>>;                                <<c0.00>>11150000
                                                               <<c0.00>>11155000
          <<-------------------->>                             <<c0.00>>11160000
                                                               <<c0.00>>11165000
  subroutine write(n);                                         <<c0.00>>11170000
                  value n;                                     <<c0.00>>11175000
                  integer n;                                   <<c0.00>>11180000
  begin                                                        <<c0.00>>11185000
        comment:                                               <<c0.00>>11190000
        << writes on output file n bytes from output buffer;   <<c0.00>>11195000
    if pf then print(outb,-n,0) else fwrite(fn,outb,-n,0);     <<c0.00>>11200000
    if <> then filerr;                                         <<c0.00>>11205000
    clearbuf;                                                  <<c0.00>>11210000
  end  <<subroutine write>>;                                   <<c0.00>>11215000
                                                               <<c0.00>>11220000
          <<-------------------->>                             <<c0.00>>11225000
                                                               <<c0.00>>11230000
  logical subroutine stchk;                                    <<c0.00>>11235000
  begin                                                        <<c0.00>>11240000
        comment:                                               <<c0.00>>11245000
        << tests dbad and cound against stack bounds.          <<c0.00>>11250000
        << returns true if ok;                                 <<c0.00>>11255000
    stchk:=true;                                               <<c0.00>>11260000
    if not(lbound<=dbad) lor not (dbad+count<=ubound) then     <<c0.00>>11265000
      begin                                  <<out of bounds>> <<c0.00>>11270000
        sbf:=false;                                            <<c0.00>>11275000
        if (dbad+count<lbound) lor (dbad>ubound) then stchk:=false      11280000
          else begin                                           <<c0.00>>11285000
 aj:                                                           <<c0.00>>11290000
            if dbad+count>ubound then count:=ubound-dbad;      <<c0.00>>11295000
            if dbad<lbound then                                <<c0.00>>11300000
              begin                                            <<c0.00>>11305000
                dbad:=lbound;                                  <<c0.00>>11310000
                goto aj;                                       <<c0.00>>11315000
              end;                                             <<c0.00>>11320000
          end;                                                 <<c0.00>>11325000
      end;                                                     <<c0.00>>11330000
  end  <<logical subroutine stchk>>;                           <<c0.00>>11335000
                                                               <<c0.00>>11340000
          <<-------------------->>                             <<c0.00>>11345000
                                                               <<c0.00>>11350000
  subroutine title;                                            <<c0.00>>11355000
  begin                                                        <<c0.00>>11360000
        comment:                                               <<c0.00>>11365000
        << outputs main title for stackdump;                   <<c0.00>>11370000
    if pf then print(outb,0,%61) else fwrite(fn,outb,0,%61);   <<c0.00>>11375000
    if <> then filerr;                                         <<c0.00>>11380000
    sx:=(recsize-53)&lsr(2);                                   <<00867>>11385000
    clearbuf;                                                  <<c0.00>>11390000
    move boutb(sx):=tit(0),(50);                               <<c0.00>>11395000
    if var.(13:1) then ascii(idnumber,10,boutb(sx+47))         <<c0.00>>11400000
      else move boutb(sx+42):="    ";                          <<c0.00>>11405000
    write(53+sx);                                              <<00867>>11410000
    if pf then print(outb,0,%202) else fwrite(fn,outb,0,%202); <<c0.00>>11415000
    if <> then filerr;                                         <<c0.00>>11420000
  end  <<subroutine title>>;                                   <<c0.00>>11425000
                                                               <<c0.00>>11430000
                                                               <<c0.00>>11435000
          <<-------------------->>                             <<c0.00>>11440000
                                                               <<c0.00>>11445000
subroutine formatdp(admode);                                   <<c0.00>>11450000
                   value admode;                               <<c0.00>>11455000
                   integer admode;                             <<c0.00>>11460000
  begin                                                        <<c0.00>>11465000
        comment:                                               <<c0.00>>11470000
        << admode=0 -- db                                      <<c0.00>>11475000
        <<        4 -- ds                                      <<c0.00>>11480000
        <<        1 -- q                                       <<c0.00>>11485000
        <<        2 -- s                                       <<c0.00>>11490000
        << figures out formatting of output record using       <<c0.00>>11495000
        << following rules:                                    <<c0.00>>11500000
        <<   1) computes maximum number of words per line (wpl)<<c0.00>>11505000
        <<   2) sets tab marks for addressingg, octal and ascii<<c0.00>>11510000
        <<      dumps, and number blanks between areads        <<c0.00>>11515000
        <<   3) prints first line of area;                     <<c0.00>>11520000
    t:=if admode.(14:2)=0 then 8                               <<c0.00>>11525000
       else if admode.(14:2)=1 then 15 else 22;                <<c0.00>>11530000
    v := if flags.(15:1)  then 7  else 10;                     <<02341>>11535000
    wpl:=(((recsize-t)/v)&lsr(2))&lsl(2);                      <<c0.00>>11540000
    t:=                                                        <<c0.00>>11545000
       (wpl*7-1) +                                             <<c0.00>>11550000
       (if not flags.(15:1)  then wpl*3-1  else 4) +           <<02341>>11555000
       ((admode.(14:2)+1)*7) ;                                 <<c0.00>>11560000
                                                               <<c0.00>>11565000
    if not flags.(15:1)  then         <<ascii>>                <<02341>>11570000
      begin                                                    <<c0.00>>11575000
        v:=(recsize-2-t)&lsr(2);                               <<c0.00>>11580000
        l1:=v;                                                 <<c0.00>>11585000
        l2:=l1+(admode.(14:2)+1)*7+2+v;                        <<c0.00>>11590000
        l3:=l2+wpl*7-1+v;                                      <<c0.00>>11595000
      end                                                      <<c0.00>>11600000
      else begin                                               <<c0.00>>11605000
        v:=(recsize-t-2)/3;                                    <<c0.00>>11610000
        l1:=v;                                                 <<c0.00>>11615000
        l2:=l1+(admode.(14:2)+1)*7+2+v;                        <<c0.00>>11620000
        l3:=0;                                                 <<c0.00>>11625000
      end;                                                     <<c0.00>>11630000
                                                               <<c0.00>>11635000
          <<output title for the area>>                        <<c0.00>>11640000
                                                               <<c0.00>>11645000
    move boutb(l1):=mad(0),                                    <<c0.00>>11650000
                    ((admode.(14:2)+1)*7);                     <<c0.00>>11655000
    if admode=4 then                                           <<c0.00>>11660000
      begin                                                    <<c0.00>>11665000
        move boutb(l1+3):="S.. #";             <<data segment>><<c0.00>>11670000
        ascii(dstx,10,boutb(l1+10));                           <<c0.00>>11675000
      end;                                                     <<c0.00>>11680000
    move boutb(t:=l2+(wpl*7-1)&lsr(1)-3):="OCTAL";             <<c0.00>>11685000
    if not (flags.(15:1)) then                                 <<02341>>11690000
    move boutb(t:=l3+(wpl*3-1)&lsr(1)-3):="ASCII";             <<c0.00>>11695000
    write(t+6);                  <<write format title>>        <<c0.00>>11700000
  end  <<subroutine formatdp>>;                                <<c0.00>>11705000
                                                               <<c0.00>>11710000
          <<--------------------->>                            <<c0.00>>11715000
                                                               <<c0.00>>11720000
  subroutine trcbck;                                           <<c0.00>>11725000
  begin                                                        <<c0.00>>11730000
        comment:                                               <<c0.00>>11735000
        << outputs trace back of stack;                        <<c0.00>>11740000
    sx:=qr;                                                    <<c0.00>>11745000
    uf:= if st(sx-1)>0 then true else false;                   <<c0.00>>11750000
    while sx > qin do                                          <<02341>>11755000
    begin                                                      <<c0.00>>11760000
      if (st(sx-1)<0) land uf then return;                     <<c0.00>>11765000
      marker(sx,boutb((recsize-60)&lsr(1)));                   <<c0.00>>11770000
      if ccl  or  (st(sx) < 4) then go er;                     <<02341>>11775000
      write((recsize+2)&lsr(1)+31);          <<ouput record>>  <<c0.00>>11780000
      sx := sx - st(sx);                                       <<02341>>11785000
    end;                                                       <<c0.00>>11790000
    if pf then print(outb,0,%203) else fwrite(fn,outb,0,%203); <<c0.00>>11795000
    if <> then filerr;                                         <<c0.00>>11800000
    return;                                                    <<c0.00>>11805000
                                                               <<c0.00>>11810000
 er:                                                           <<c0.00>>11815000
    move boutb((recsize-60)&lsr(1)):="ILLEGAL MARKER";         <<c0.00>>11820000
    write(recsize&lsr(1)-15);              <<output>>          <<c0.00>>11825000
  end  <<subroutine trcbck>>;                                  <<c0.00>>11830000
                                                               <<c0.00>>11835000
          <<-------------------->>                             <<c0.00>>11840000
                                                               <<c0.00>>11845000
  subroutine convertad(num,indx);                              <<c0.00>>11850000
                      value num,indx;                          <<c0.00>>11855000
                      integer num,indx;                        <<c0.00>>11860000
  begin                                                        <<c0.00>>11865000
        comment:                                               <<c0.00>>11870000
        << converts into octal and deposits number into        <<c0.00>>11875000
        << location specified by indx;                         <<c0.00>>11880000
    ascii(if num>=0 then num else -num,8,boutb(indx));         <<c0.00>>11885000
    boutb(indx):=if num<0 then "-" else " ";                   <<c0.00>>11890000
  end  <<subroutine convertad>>;                               <<c0.00>>11895000
                                                               <<c0.00>>11900000
          <<-------------------->>                             <<c0.00>>11905000
                                                               <<c0.00>>11910000
  subroutine dumpascii(dbadr,count,bufx);                      <<c0.00>>11915000
                      value dbadr,count,bufx;                  <<c0.00>>11920000
                      integer dbadr,count,bufx;                <<c0.00>>11925000
  begin                                                        <<c0.00>>11930000
        comment:                                               <<c0.00>>11935000
        << dump "COUNT" words in specified area;               <<c0.00>>11940000
    v:=0;                                                      <<c0.00>>11945000
    while (v:=v+1)<=count do                                   <<c0.00>>11950000
    begin                                                      <<c0.00>>11955000
      is(0):=st(dbadr);                                        <<c0.00>>11960000
                                                               <<c0.00>>11965000
          << not printable characters>>                        <<c0.00>>11970000
                                                               <<c0.00>>11975000
      xreg:=-1;                                                <<c0.00>>11980000
      while (xreg:=xreg+1)<2 do                                <<c0.00>>11985000
      if bis(xreg)<%40 or bis(xreg)>%172 then bis(xreg):=".";  <<c0.00>>11990000
      move boutb(l3+bufx):=bis(0),(2);                         <<c0.00>>11995000
      boutb(l3+(bufx:=bufx+2)):=" ";         <<separation>>    <<c0.00>>12000000
      bufx:=bufx+1;                                            <<c0.00>>12005000
      dbadr:=dbadr+1;                                          <<c0.00>>12010000
    end;                                                       <<c0.00>>12015000
  end  <<subroutine dumpascii>>;                               <<c0.00>>12020000
                                                               <<c0.00>>12025000
          <<-------------------->>                             <<c0.00>>12030000
                                                               <<c0.00>>12035000
  subroutine dumpoctal(dbadr,count,bufx);                      <<c0.00>>12040000
                      value dbadr,count,bufx;                  <<c0.00>>12045000
                      integer dbadr,count,bufx;                <<c0.00>>12050000
  begin                                                        <<c0.00>>12055000
        comment:                                               <<c0.00>>12060000
        << dumps "COUNT" words located in dbadr in stack and   <<c0.00>>12065000
        << puts them in output buffer.  all separated by       <<c0.00>>12070000
        << blanks;                                             <<c0.00>>12075000
    v:=0;                                                      <<c0.00>>12080000
    while (v:=v+1)<=count do                                   <<c0.00>>12085000
    begin                                                      <<c0.00>>12090000
      ascii(st(dbadr),8,boutb(l2+bufx));                       <<c0.00>>12095000
      dbadr:=dbadr+1;                                          <<c0.00>>12100000
      bufx:=bufx+7;                                            <<c0.00>>12105000
    end;                                                       <<c0.00>>12110000
                                                               <<c0.00>>12115000
  end;   <<dumpoctal>>                                         <<c0.00>>12120000
                                                               <<c0.00>>12125000
          <<-------------------->>                             <<c0.00>>12130000
                                                               <<c0.00>>12135000
  subroutine setad(admode,dbad);                               <<c0.00>>12140000
                  value admode,dbad;                           <<c0.00>>12145000
                  integer admode,dbad;                         <<c0.00>>12150000
  begin                                                        <<c0.00>>12155000
        comment:                                               <<c0.00>>12160000
        << admode= 0 (db), 4 (ds), 1 (q), 2 (s)                <<c0.00>>12165000
        << converts addresses and deposits them in output      <<c0.00>>12170000
        << buffer in l1 area;                                  <<c0.00>>12175000
    admode:=admode.(14:2);                 <<db,q & s>>        <<c0.00>>12180000
    convertad(dbad,l1);                                        <<c0.00>>12185000
    if admode>=1 then convertad(dbad-qr,l1+7);                 <<c0.00>>12190000
    if admode>=2 then convertad(dbad-sr,l1+14);                <<c0.00>>12195000
  end  <<subroutine setad>>;                                   <<c0.00>>12200000
                                                               <<c0.00>>12205000
          <<-------------------->>                             <<c0.00>>12210000
                                                               <<c0.00>>12215000
  subroutine dump(admode);                                     <<c0.00>>12220000
                 value admode;                                 <<c0.00>>12225000
                 integer admode;                               <<c0.00>>12230000
  begin                                                        <<c0.00>>12235000
    sbf:=true;                                                 <<c0.00>>12240000
    formatdp(admode);                                          <<00599>>12245000
    if admode<4 and not stchk then begin cc:=0;go arret; end;  <<c0.00>>12250000
    if admode=4 then begin push(q,s);w:=tos-tos;end;           <<c0.00>>12255000
                                                               <<c0.00>>12260000
        <<compute number of lines in area>>                    <<c0.00>>12265000
                                                               <<c0.00>>12270000
    tos:=if admode.(14:2)=0 then dbad                          <<c0.00>>12275000
         else if admode.(14:2)=1 then dbad-qr else dbad-sr;    <<c0.00>>12280000
    assemble(zero,xch);                                        <<c0.00>>12285000
    tos:=wpl;                                                  <<c0.00>>12290000
    assemble(ldiv,delb);                                       <<c0.00>>12295000
    ot:=tos;         <<word offset in line>>                   <<c0.00>>12300000
                                                               <<c0.00>>12305000
        <<compute offset in first line>>                       <<c0.00>>12310000
                                                               <<c0.00>>12315000
    tos:=count;                                                <<c0.00>>12320000
    if= then begin assemble(del);return;end;<<skip>>           <<c0.00>>12325000
    tos:=wpl;                                                  <<c0.00>>12330000
    assemble(div,test);<<test remainder>>                      <<c0.00>>12335000
    if = then                                                  <<c0.00>>12340000
      begin                                                    <<c0.00>>12345000
        assemble(del);                                         <<c0.00>>12350000
        if ot<>0 then tos:=tos+1;  <<more lines>>              <<c0.00>>12355000
      end                                                      <<c0.00>>12360000
      else begin            <<remainder non 0>>                <<c0.00>>12365000
        s1:=s1+1;  <<increase line # by 1>>                    <<c0.00>>12370000
        if tos>wpl-ot then tos:=tos+1;                         <<c0.00>>12375000
      end;                                                     <<c0.00>>12380000
    lines:=tos;                                                <<c0.00>>12385000
    cw:=0;           <<initialize>>                            <<c0.00>>12390000
    cl:=0;            <<current lines>>                        <<c0.00>>12395000
    while (cl:=cl+1)<=lines do                                 <<c0.00>>12400000
    begin                                                      <<c0.00>>12405000
      setad(admode,dbad);                                      <<c0.00>>12410000
      if cl=1 then       <<first line>>                        <<c0.00>>12415000
      begin                                                    <<c0.00>>12420000
        if dbad=0 then ot:=0;                                  <<c0.00>>12425000
      end                                                      <<c0.00>>12430000
      else ot:=0;                                              <<c0.00>>12435000
                                                               <<c0.00>>12440000
      <<computation of the count to be oupt>>                  <<c0.00>>12445000
                                                               <<c0.00>>12450000
      lkount:=if cl=lines then count-cw else                   <<c0.00>>12455000
      if cl=1 then lkount:=wpl-ot else wpl;                    <<c0.00>>12460000
      if admode=4 then sbf:=not dmove'(dstx,dbad,lkount,@wint,true,w);  12465000
      dumpoctal(if admode=4 then @wint else dbad,lkount,ot*7); <<c0.00>>12470000
      if not flags.(15:1) then                                 <<02341>>12475000
          dumpascii(if admode=4 then @wint else dbad,lkount,ot*3);      12480000
      cw:=cw+lkount;                                           <<c0.00>>12485000
      dbad:=dbad+lkount;                                       <<c0.00>>12490000
      write(if flags.(15:1)  then l2+wpl*7  else l3+wpl*3);    <<02341>>12495000
      if (admode=4 land not sbf) then go arret;                <<c0.00>>12500000
    end;                                                       <<c0.00>>12505000
  arret:                                                       <<c0.00>>12510000
    if not sbf then                                            <<c0.00>>12515000
      begin                                                    <<c0.00>>12520000
        move boutb(l1):="** AREA OUT OF BOUNDS **";write(l1+24);        12525000
        cc:=0;             <<ccg>>                             <<c0.00>>12530000
      end;                                                     <<c0.00>>12535000
    if pf then print(outb,0,%203) else fwrite(fn,outb,0,%203); <<c0.00>>12540000
    if <> then filerr;                                         <<c0.00>>12545000
  end  <<subroutine dump>>;                                    <<c0.00>>12550000
                                                               <<c0.00>>12555000
          <<-------------------->>                             <<c0.00>>12560000
                                                               <<c0.00>>12565000
        <<----------------->>                                  <<c0.00>>12570000
        << begin procedure >>                                  <<c0.00>>12575000
        <<----------------->>                                  <<c0.00>>12580000
                                                               <<c0.00>>12585000
    erroron;                                                   <<c0.00>>12590000
    bounds:=chek(errcode&lsl(6)+5,4,double(%253),,%17);        <<c0.00>>12595000
    cc:=2;                                 <<cce>>             <<c0.00>>12600000
    if not var&lsr(2) then adum:=@dummy;   <<no idnum>>        <<c0.00>>12605000
    if not(var)&lsr(3) then                <<no filen>>        <<c0.00>>12610000
      begin                                                    <<c0.00>>12615000
        pf:=true;   af:=false;                                 <<c0.00>>12620000
        pxglobal;                                              <<06664>>12625000
        ldt'index := pxg'outputldev * size'of'ldt'entry;       <<07052>>12630000
        exchangedb(ldt'dst);                                   <<07052>>12635000
        recsize := ldt'record'width & lsl(1); << bytes >>      <<07052>>12640000
        exchangedb(0); <<to stack>>                            <<c0.00>>12645000
        go wjx;                                                <<c0.00>>12650000
      end;                                                     <<c0.00>>12655000
    fn:=fopen(filen,,4);                                       <<c0.00>>12660000
    if ccl then begin cc:=1;fcheck(fn,idnumber);go fini;end;   <<c0.00>>12665000
    go c;                                                      <<c0.00>>12670000
                                                               <<c0.00>>12675000
stackdump':                                                    <<c0.00>>12680000
    erroron;                                                   <<c0.00>>12685000
    bounds:=chek(errcode&lsl(6)+5,4,double(%253),,%17);        <<c0.00>>12690000
    if not var&lsr(2) then adum:=@dummy;   <<no idnum>>        <<c0.00>>12695000
    cc:=2;                                 <<cce>>             <<c0.00>>12700000
    if not var&lsr(3) then                 <<no filen>>        <<c0.00>>12705000
      begin                                                    <<c0.00>>12710000
        cc:=1;                                                 <<c0.00>>12715000
        idnumber:=72;                      <<"BAD FILE #">>    <<c0.00>>12720000
        go fini;                                               <<c0.00>>12725000
      end;                                                     <<c0.00>>12730000
    fn:= filen(0);                         <<get file number>> <<c0.00>>12735000
    af:=false;                                                 <<c0.00>>12740000
                                                               <<c0.00>>12745000
c:                                                             <<c0.00>>12750000
    fgetinfo(fn,,foptions,aoptions,recsize);                   <<c0.00>>12755000
    if ccl then begin cc:=1;fcheck(fn,idnumber);go fini;end;   <<c0.00>>12760000
    recsize:= if foptions.(13:1) then -recsize                 <<c0.00>>12765000
              else recsize&lsl(1);                             <<c0.00>>12770000
wjx:                                                           <<c0.00>>12775000
    if recsize>256 or recsize<32 then                          <<c0.00>>12780000
      begin                                                    <<c0.00>>12785000
d:                                                             <<c0.00>>12790000
        cc:=0;   go fini;                                      <<c0.00>>12795000
      end;                                                     <<c0.00>>12800000
    pxfixed;                                                   <<06664>>12805000
    envir:=pxfxstkdmpenv;                                      <<06664>>12810000
     qin := pxfxqreg;                                          <<06664>>12815000
    push(q); v:=if envir=0 then -1 else 0;                     <<c0.00>>12820000
   while ((v:=v+1) <= envir) and (s0 > qin) do                 <<02341>>12825000
    begin                                                      <<c0.00>>12830000
      assemble(dup,dup);                                       <<c0.00>>12835000
      sr:=tos-4;                                               <<c0.00>>12840000
      tos:=tos-st(tos);                                        <<c0.00>>12845000
    end;                                                       <<c0.00>>12850000
    qr:=tos; ubound:=sr;                                       <<c0.00>>12855000
    flags := if not(var&lsr(1)) then false else flag;                   12860000
    if envir=0 then                                            <<c0.00>>12865000
      begin                                                    <<c0.00>>12870000
        title;                                                 <<c0.00>>12875000
        push(q); px:=tos;                                      <<c0.00>>12880000
        regist(px,boutb((recsize-32)&lsr(1)));                 <<c0.00>>12885000
        write((recsize+2)&lsr(1)+16);                          <<c0.00>>12890000
        marker(px,boutb((recsize-60)&lsr(1)));                 <<c0.00>>12895000
        write((recsize+2)&lsr(1)+31);                          <<c0.00>>12900000
        if pf then print(outb,0,%201) else fwrite(fn,outb,0,%201);      12905000
        if <> then filerr;                                     <<c0.00>>12910000
        if not flags.(14:1) then trcbck;                       <<02341>>12915000
      end;                                                     <<c0.00>>12920000
    if not var then go fini;      <<array selec missing>>      <<c0.00>>12925000
    if pf then print(outb,0,%201) else fwrite(fn,outb,0,%201); <<c0.00>>12930000
    if <> then filerr;                                         <<c0.00>>12935000
    clearbuf;                                                  <<c0.00>>12940000
    push(q); tos:=@selec; tos:=tos-tos;                        <<c0.00>>12945000
    lim:=(tos-4)&lsr(1);                                       <<c0.00>>12950000
next:                                                          <<c0.00>>12955000
    curselx:=curselx+1;                                        <<c0.00>>12960000
    if curselx>lim then goto fini;                             <<c0.00>>12965000
    tos:=selec(curselx);                                       <<c0.00>>12970000
    assemble(ddup);                                            <<c0.00>>12975000
    if tos=%177777d then goto fini;                            <<c0.00>>12980000
                                                               <<c0.00>>12985000
    <<decode entry>>                                           <<c0.00>>12990000
                                                               <<c0.00>>12995000
    assemble(test);                                            <<c0.00>>13000000
    if >= then                                                 <<c0.00>>13005000
      begin                                                    <<c0.00>>13010000
        count:=tos;                                            <<c0.00>>13015000
        dbad:=tos;                                             <<c0.00>>13020000
        dump(0);                                               <<c0.00>>13025000
      end                                                      <<c0.00>>13030000
      else begin                                               <<c0.00>>13035000
        assemble(dup);                                         <<c0.00>>13040000
        v:=tos;                                                <<c0.00>>13045000
        case v.(0:3) of begin                                  <<c0.00>>13050000
          <<empty>>;                                           <<c0.00>>13055000
          <<empty>>;                                           <<c0.00>>13060000
          <<empty>>;                                           <<c0.00>>13065000
          <<empty>>;                                           <<c0.00>>13070000
          begin                                                <<c0.00>>13075000
            chek(errcode&lsl(6)+5,%44,,double(2));      <<cap>><<c0.00>>13080000
            assemble(xch); dstx:=tos;      <<extra ds>>        <<c0.00>>13085000
            if (dstx:=pxdseg(4,dstx))=0 then                   <<c0.00>>13090000
              begin                                            <<c0.00>>13095000
ws:                                                            <<c0.00>>13100000
                cc:=0;                      <<invalid>>        <<c0.00>>13105000
                go fini;                                       <<c0.00>>13110000
              end;                                             <<c0.00>>13115000
            assemble(dup);                                     <<c0.00>>13120000
            dbad:=(tos land %17600)&lsl(2);       <<db adress>><<c0.00>>13125000
            count:=(tos land %177)&lsl(7);        <<count to be output>>13130000
            dump(4);                                           <<c0.00>>13135000
          end;                                                 <<c0.00>>13140000
          begin                                                <<c0.00>>13145000
            <<check cap: pm code or prog has pm cap>>          <<00512>>13150000
            if status.(0:1) <> 1 then                          <<00512>>13155000
            chek(errcode&lsl(6)+5,%44,,double(%100));          <<00512>>13160000
            assemble(dup);                                     <<c0.00>>13165000
            dbad:=(tos land %17600)&lsl(2);                    <<c0.00>>13170000
            count:=(tos land %177)&lsl(7);                     <<c0.00>>13175000
            dstx:=tos;                                         <<c0.00>>13180000
            if dsti'(dstx&lsl(2)).(3:13) = 0 then                       13185000
             goto ws;       <<invalid entry>>                           13190000
            dump(4);                                           <<c0.00>>13195000
          end;                                                 <<c0.00>>13200000
          begin     << q >>                                    <<c0.00>>13205000
            count:=tos.(3:13);                                 <<c0.00>>13210000
            dbad:=qr+tos;                                      <<c0.00>>13215000
            dump(1);                                           <<c0.00>>13220000
          end;                                                 <<c0.00>>13225000
          begin     << s >>                                    <<c0.00>>13230000
            count:=tos.(3:13);                                 <<c0.00>>13235000
            dbad:=sr+tos;                                      <<c0.00>>13240000
            dump(2);                                           <<c0.00>>13245000
          end;                                                 <<c0.00>>13250000
        end  <<case>>;                                         <<c0.00>>13255000
      end;                                                     <<c0.00>>13260000
    go to next;                                                <<c0.00>>13265000
                                                               <<c0.00>>13270000
fini:                                                          <<c0.00>>13275000
    if af then                                                 <<c0.00>>13280000
      begin                                                    <<c0.00>>13285000
        fclose(fn,0,0);                                        <<c0.00>>13290000
        if ccl then begin cc:=1;fcheck(fn,idnumber);end;       <<c0.00>>13295000
      end;                                                     <<c0.00>>13300000
    stat.(6:2):=cc;              <<cc in return>>              <<c0.00>>13305000
    errorexit(errcode&lsl(6)+5,0,0);       <<quit system>>     <<c0.00>>13310000
end  <<procedures stackdump & stackdump'>>;                    <<c0.00>>13315000
                                                                        13320000
$control segment=main                                                   13325000
                                                               <<b0.07>>13330000
end.  <<abortdump>>                                            <<00652>>13335000
