$control uslinit,map,code                                               00001000
                                                                        00002000
begin                                                                   00003000
                                                                        00004000
$include inclvuf                                                        00005000
                                                                        00006000
   integer fnum,                                                        00007000
           total'seg'num,                                               00008000
           error,                                                       00009000
           parm = Q-4;                                                  00010000
                                                                        00011000
   logical list'code;                                                   00012000
                                                                        00013000
   array   seg'sa'array(0:255),                                         00014000
           seg'array(0:255),                                            00015000
           commandw(0:39),                                              00016000
           inst(0:16384);                                               00017000
                                                                        00018000
   byte array command(*)=commandw;                                      00019000
                                                                        00020000
   equate  no'error     = 0,                                            00021000
           print'error  = 1,                                            00022000
           read'error   = 2,                                            00023000
           fread'error  = 3,                                            00024000
           fopen'error  = 4,                                            00025000
           fclose'error = 5,                                            00026000
           file'not'prog=11,                                            00027000
           null'input   =12,                                            00028000
                                                                        00029000
           prog'filecode=1029,                                          00030000
           file'sys'err = 10;                                           00031000
                                                                        00032000
   entry listcode;                                                      00033000
                                                                        00034000
   logical procedure deassemble(result,string,inst1,inst2);             00035000
      value inst1,inst2;                                                00036000
      integer result,inst1,inst2;                                       00037000
      byte array string;                                                00038000
      option variable,external;                                         00039000
                                                                        00040000
   intrinsic fopen,                                                     00041000
             fclose,                                                    00042000
             print,                                                     00043000
             read,                                                      00044000
             freaddir,                                                  00045000
             fgetinfo,                                                  00046000
             fcheck,                                                    00047000
             getprivmode,                                               00048000
             getusermode,                                               00049000
             ascii;                                                     00050000
                                                                        00051000
procedure title;                                                        00052000
                                                                        00053000
begin                                                                   00054000
                                                                        00055000
   array title'line(0:39);                                              00056000
   byte array btitle'line(*)=title'line;                                00057000
   integer len;                                                         00058000
                                                                        00059000
   move btitle'line:=                                                   00060000
     "MPE V Program Verifier ",2;                                       00061000
   len:=tos-@btitle'line;                                               00062000
                                                                        00063000
   move btitle'line(len):=official'vuuff,2;                             00064000
   len:=tos-@btitle'line;                                               00065000
                                                                        00066000
   move btitle'line(len):=                                              00067000
     " (C) Hewlett-Packard Co. 1984 ";                                  00068000
                                                                        00069000
   print(title'line,-59,0);                                             00070000
   if <> then                                                           00071000
      begin                                                             00072000
         error := print'error;                                          00073000
         return;                                                        00074000
      end;                                                              00075000
end;                                                                    00076000
                                                                        00077000
procedure prompt;                                                       00078000
                                                                        00079000
begin                                                                   00080000
   array prompt'line(0:14);                                             00081000
                                                                        00082000
   move prompt'line := "Enter file name to be verified";                00083000
   print (prompt'line, -30, 0);                                         00084000
   if <> then                                                           00085000
      begin                                                             00086000
         error := print'error;                                          00087000
         return;                                                        00088000
      end;                                                              00089000
   move prompt'line := "Or enter // to exit ";                          00090000
   print (prompt'line, -19, 0);                                         00091000
   if <> then                                                           00092000
      begin                                                             00093000
         error := print'error;                                          00094000
         return;                                                        00095000
      end;                                                              00096000
   move prompt'line := "? ";                                            00097000
   print (prompt'line, -2, %320);                                       00098000
   if <> then                                                           00099000
      begin                                                             00100000
         error := print'error;                                          00101000
         return;                                                        00102000
      end;                                                              00103000
end;                                                                    00104000
                                                                        00105000
procedure cleanup;                                                      00106000
                                                                        00107000
begin                                                                   00108000
   if fnum <> 0 then                                                    00109000
      begin                                                             00110000
         fclose(fnum,0,0);                                              00111000
         fnum:=0;                                                       00112000
      end;                                                              00113000
end;                                                                    00114000
                                                                        00115000
procedure print'err(error);                                             00116000
   value error;                                                         00117000
   integer error;                                                       00118000
                                                                        00119000
begin                                                                   00120000
   array msg(0:40);                                                     00121000
   byte array msgb(*) = msg;                                            00122000
   integer errorcode,                                                   00123000
           numchar;                                                     00124000
                                                                        00125000
   case error of                                                        00126000
   begin                                                                00127000
                                                                        00128000
   << 0>>;                                                              00129000
   << 1>>begin                                                          00130000
            move msg:="Print error";                                    00131000
            numchar:=11;                                                00132000
         end;                                                           00133000
   << 2>>begin                                                          00134000
            move msg:="Read error";                                     00135000
            numchar:=10;                                                00136000
         end;                                                           00137000
   << 3>>begin                                                          00138000
            move msg:="Fread error";                                    00139000
            numchar:=11;                                                00140000
         end;                                                           00141000
   << 4>> begin                                                         00142000
             move msg:="Fopen error";                                   00143000
             numchar:=11;                                               00144000
          end;                                                          00145000
   << 5>> begin                                                         00146000
             move msg:="Fclose error";                                  00147000
             numchar:=12;                                               00148000
          end;                                                          00149000
   << 6>> ;                                                             00150000
   << 7>> ;                                                             00151000
   << 8>> ;                                                             00152000
   << 9>> ;                                                             00153000
   <<10>> ;                                                             00154000
   <<11>> begin                                                         00155000
             move msg:="File is not a program file";                    00156000
             numchar:=26;                                               00157000
          end;                                                          00158000
   end;                                                                 00159000
                                                                        00160000
   print(msg,-numchar,0);                                               00161000
   if error <= file'sys'err then                                        00162000
      begin                                                             00163000
         fcheck(fnum,errorcode);                                        00164000
         move msg := "File System Error ";                              00165000
         numchar:=ascii(errorcode,10,msgb(18));                         00166000
         print(msg,-18-numchar,0);                                      00167000
      end;                                                              00168000
   print(msg,0,0);                                                      00169000
   cleanup;                                                             00170000
end;                                                                    00171000
                                                                        00172000
procedure readinput;                                                    00173000
                                                                        00174000
begin                                                                   00175000
   array input(0:39);                                                   00176000
   byte array inputb(*) = input;                                        00177000
   integer numchar;                                                     00178000
   integer numblank;                                                    00179000
                                                                        00180000
   numchar:=read(input,-80);                                            00181000
   if <> then                                                           00182000
      begin                                                             00183000
         error:=read'error;                                             00184000
         return;                                                        00185000
      end;                                                              00186000
   print(input,0,0);                                                    00187000
   numblank:=0;                                                         00188000
   while inputb(numblank) = " " do                                      00189000
      begin                                                             00190000
         numblank := numblank+1;                                        00191000
         numchar := numchar-1;                                          00192000
      end;                                                              00193000
   if numchar <= 0 then                                                 00194000
      begin                                                             00195000
         error:=null'input;                                             00196000
         return;                                                        00197000
      end;                                                              00198000
   move command := inputb(numblank),(numchar);                          00199000
   move command(numchar) := " ";                                        00200000
end;                                                                    00201000
                                                                        00202000
procedure init;                                                         00203000
                                                                        00204000
begin                                                                   00205000
                                                                        00206000
   integer filecode,                                                    00207000
           segnum,                                                      00208000
           seg'array'index,                                             00209000
           seg'array'rec;                                               00210000
                                                                        00211000
   fnum:=fopen(command,%3,%320);                                        00212000
   if <> then                                                           00213000
      begin                                                             00214000
         error:=fopen'error;                                            00215000
         return;                                                        00216000
      end;                                                              00217000
   fgetinfo(fnum,,,,,,,,filecode);                                      00218000
   if filecode <> prog'filecode then                                    00219000
      begin                                                             00220000
         error:=file'not'prog;                                          00221000
         return;                                                        00222000
      end;                                                              00223000
   freaddir(fnum,seg'array,128,0d);                                     00224000
   if <> then                                                           00225000
      begin                                                             00226000
         error:=fread'error;                                            00227000
         return;                                                        00228000
      end;                                                              00229000
   total'seg'num := seg'array(1);                                       00230000
   seg'sa'array := seg'array(4);                                        00231000
   seg'array'index := 28+(total'seg'num+1)/2;                           00232000
   seg'array'rec := seg'array'index/128;                                00233000
   seg'array'index := seg'array'index mod 128;                          00234000
   freaddir(fnum,inst,128*3,double(seg'array'rec));                     00235000
   if < then                                                            00236000
      begin                                                             00237000
         error:=fread'error;                                            00238000
         return;                                                        00239000
      end;                                                              00240000
   move seg'array := inst(seg'array'index),(total'seg'num);             00241000
   segnum := 1;                                                         00242000
   while segnum < total'seg'num do                                      00243000
      begin                                                             00244000
      seg'sa'array(segnum) :=                                           00245000
      seg'sa'array(segnum-1)+(seg'array(segnum-1).(2:14)+127)/128;      00246000
      segnum:=segnum+1;                                                 00247000
      end;                                                              00248000
end;                                                                    00249000
                                                                        00250000
procedure verify;                                                       00251000
                                                                        00252000
begin                                                                   00253000
                                                                        00254000
   integer segnum,                                                      00255000
           seg'sa,                                                      00256000
           seg'length,                                                  00257000
           inst'offset,                                                 00258000
           br'offset;                                                   00259000
                                                                        00260000
   logical recompile'flag,                                              00261000
           head'print'flag;                                             00262000
                                                                        00263000
   subroutine print'code;                                               00264000
      begin                                                             00265000
         if not list'code then return;                                  00266000
         if head'print'flag then                                        00267000
            begin                                                       00268000
               move command:="Segment   PB rel. address   Code";        00269000
               print(commandw,-32,0);                                   00270000
               move command:="-------   ---------------   ----";        00271000
               print(commandw,-32,%60);                                 00272000
               head'print'flag := false;                                00273000
            end;                                                        00274000
         getprivmode;                                                   00275000
         command:=" ";                                                  00276000
         move command(1):=command,(59);                                 00277000
         ascii(segnum,8,command(1));                                    00278000
         ascii(inst'offset,8,command(14));                              00279000
         deassemble(error,command(28),inst(inst'offset));               00280000
         print(commandw,-60,0);                                         00281000
         command:=" ";                                                  00282000
         move command(1):=command,(59);                                 00283000
         ascii(inst'offset+1,8,command(14));                            00284000
         deassemble(error,command(28),inst(inst'offset+1));             00285000
         print(commandw,-60,0);                                         00286000
         command:=" ";                                                  00287000
         move command(1):=command,(59);                                 00288000
         ascii(br'offset,8,command(14));                                00289000
         deassemble(error,command(28),inst(br'offset));                 00290000
         print(commandw,-60,%60);                                       00291000
         getusermode;                                                   00292000
      end;                                                              00293000
                                                                        00294000
   subroutine print'result;                                             00295000
      begin                                                             00296000
         move command:="Program file       : ";                         00297000
         move command(21):="                            ";              00298000
         fgetinfo(fnum,command(21));                                    00299000
         print(commandw,-49,0);                                         00300000
         move command:="# Suspected PCAL 0 :          ";                00301000
         if recompile'flag <> 0 then                                    00302000
            ascii(recompile'flag,10,command(21))                        00303000
         else                                                           00304000
            move command(21):="None";                                   00305000
         print(commandw,-30,0);                                         00306000
         move command:="Recompile required :    ";                      00307000
         if recompile'flag <> 0 then                                    00308000
            move command(21) := "Yes"                                   00309000
         else                                                           00310000
            move command(21) := "No";                                   00311000
         print(commandw,-24,%60);                                       00312000
      end;                                                              00313000
                                                                        00314000
   segnum := 0;                                                         00315000
   head'print'flag := true;                                             00316000
   recompile'flag := 0;                                                 00317000
   while segnum < total'seg'num do                                      00318000
      begin                                                             00319000
         seg'sa := seg'sa'array(segnum);                                00320000
         seg'length := seg'array(segnum).(2:14);                        00321000
         freaddir(fnum,inst,seg'length,double(seg'sa));                 00322000
         if <> then                                                     00323000
            begin                                                       00324000
               error := fread'error;                                    00325000
               return;                                                  00326000
            end;                                                        00327000
         seg'length:=seg'length-integer(inst(seg'length-1).(8:8))-1;    00328000
         inst'offset := 0;                                              00329000
         while inst'offset < seg'length do                              00330000
            begin                                                       00331000
               if (inst(inst'offset) land %171000)=%170000 then         00332000
                  if (inst(inst'offset+1) land %147000)=%140000 then    00333000
                     begin                                              00334000
                        br'offset:=inst(inst'offset+1).(8:8);           00335000
                        if inst(inst'offset+1).(7:1) then               00336000
                           br'offset:=-br'offset;                       00337000
                        br'offset:=br'offset+inst'offset+1;             00338000
                        if inst(br'offset) = %31000 then                00339000
                           begin                                        00340000
                              recompile'flag:=recompile'flag + 1;       00341000
                              print'code;                               00342000
                           end;                                         00343000
                     end;                                               00344000
               inst'offset:=inst'offset+1;                              00345000
            end;                                                        00346000
         segnum:=segnum+1;                                              00347000
      end;                                                              00348000
   print'result;                                                        00349000
end;                                                                    00350000
                                                                        00351000
   <<**********************************>>                               00352000
   <<     Outer Block                  >>                               00353000
   <<**********************************>>                               00354000
                                                                        00355000
   list'code := false;                                                  00356000
   go to normal'start;                                                  00357000
listcode:                                                               00358000
   list'code := true;                                                   00359000
normal'start:                                                           00360000
   error := no'error;                                                   00361000
   fnum:=0;                                                             00362000
   title;                                                               00363000
   if error <> no'error then                                            00364000
      begin                                                             00365000
         print'err(error);                                              00366000
         go exit;                                                       00367000
      end;                                                              00368000
restart:                                                                00369000
   cleanup;                                                             00370000
   error := no'error;                                                   00371000
   Prompt;                                                              00372000
   if error <> no'error then                                            00373000
      begin                                                             00374000
         print'err(error);                                              00375000
         go to exit;                                                    00376000
      end;                                                              00377000
   Readinput;                                                           00378000
   if error <> no'error then                                            00379000
      begin                                                             00380000
         if error=null'input then                                       00381000
            go to restart;                                              00382000
         print'err(error);                                              00383000
         go to restart;                                                 00384000
      end;                                                              00385000
   If command = "//" then                                               00386000
      go to exit;                                                       00387000
   init;                                                                00388000
   if error <> no'error then                                            00389000
      begin                                                             00390000
         print'err(error);                                              00391000
         go to restart;                                                 00392000
      end;                                                              00393000
   verify;                                                              00394000
   if error <> no'error then                                            00395000
      begin                                                             00396000
         print'err(error);                                              00397000
      end;                                                              00398000
   go to restart;                                                       00399000
exit:                                                                   00400000
   cleanup;                                                             00401000
   title;                                                               00402000
                                                                        00403000
end.                                                                    00404000
