$CONTROL USLINIT,MAP,CODE                                      <<03006>>00010000
<<sysdump - module 01>>                                                 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=sysdump,privileged                                        00060000
$control privileged,uncallable                                          00065000
$set x6 = on                                                   <<06762>>00070000
<<----------------------------------------------------------------------00075000
         m p e   s y s t e m   d u m p   p r o g r a m                  00080000
---------------------------------------------------------------------->>00085000
$control segment=mainseg1                                               00090000
begin                                                                   00095000
$page "CONSTANT DEFINITION"                                             00100000
  entry defaults, fos, partbkup, fullbkup;                     <<i9075>>00105000
  logical fostape := false;                                    <<i9075>>00110000
  logical default := false;                                    <<*8393>>00115000
  logical auto'bkup := false;                                  <<*8393>>00120000
  define auto'full'bkup = auto'bkup.(14:1)#;                   <<*8393>>00125000
  define auto'part'bkup = auto'bkup and not auto'full'bkup#;   <<*8393>>00130000
  equate full'bkup = 3,                                        <<*8393>>00135000
         part'bkup = 1;                                        <<*8393>>00140000
         <<-------------->>                                    <<02509>>00145000
         <<  misc. maps  >>                                    <<02509>>00150000
         <<-------------->>                                    <<02509>>00155000
  equate bitmap0  = %12,     << series ii,iii >>               <<02509>>00160000
         bitmap1  = %164,    << series 33,44,55,37 >>          <<m8393>>00165000
         bitmap2  = %12,     << sio machines >>                <<02509>>00170000
         bitmap3  = %164,    << hpib machines >>               <<m8393>>00175000
         bitmap4  = %12,     << tapes using sio >>             <<02509>>00180000
         bitmap5  = %176,    << tapes using amigo >>           <<m8393>>00185000
         bitmap6  = %76,     << tapes using cs80 >>            <<m8393>>00190000
         bitmap7  = %140;    << icf55 and series-37 >>         <<m8393>>00195000
                                                               <<02509>>00200000
          <<-------------                                               00205000
            table sizes                                                 00210000
          ------------->>                                               00215000
  equate                                                       <<06762>>00220000
          maxldev   =  1024,<<max # of configured ldevs>>      <<06815>>00225000
          maxunit   =  127, << max allowable units     >>      <<06762>>00230000
          ldtsize   =    7,    <<logical device table entry>>  <<06762>>00235000
          ldtxsize  =    5,    <<ldt extension>>               <<06762>>00240000
          lpdtsize  =    4,    <<lpdt entry size  >>           <<06762>>00245000
          dvrsize   =    7,    <<driver table entry size>>     <<06762>>00250000
          vtabsize  =    14,         <<volume table entry size>>        00255000
          perportmax=    99,         <<max. no. tbufs/port>>   <<03007>>00260000
          ctab0size =    128,        <<configuration info table size>>  00265000
          ncoresizes=    36,         <<# mem sizes>>           <<01757>>00270000
          ctabsize  =    128,        <<coresize-related info size>>     00275000
        commsize  =   128,                                     <<07039>>00280000
          infosize  =    256,        <<disc cold load info table>>      00285000
          ncst      =    32,         <<# of temporary cst entries>>     00290000
          tcstsize  =    ncst*4,     <<size of temporary cst>>          00295000
          csdvrsize =    4,           <<cs additional dvrs>>            00300000
          csdrivers =    32,       <<max cs additional dvrs>>           00305000
          dvrtsize  =    128*dvrsize,                                   00310000
          csdefsize =    maxldev,                              <<06762>>00315000
          csdvrtsize=    csdrivers*csdvrsize,                           00320000
          exptables =   11; <<# of tables which expand>>       <<t8393>>00325000
                                                                        00330000
        <<-------------------------------------->>             <<06762>>00335000
        <<  table array and index declarations  >>             <<06762>>00340000
        <<-------------------------------------->>             <<06762>>00345000
                                                               <<06762>>00350000
                                                               <<06762>>00355000
integer   ldt'dst'index,    << xdseg # for ldt >>              <<06762>>00360000
          lpdt'dst'index,   << xdseg # for lpdt>>              <<06762>>00365000
          ldtx'dst'index,   << xdseg # for ldtx>>              <<06762>>00370000
          dvrtab'dst'index, << xdseg # for dvrtab>>            <<06762>>00375000
                                                               <<06762>>00380000
          ldt'index,        << index into ldt  >>              <<06762>>00385000
          lpdt'index,       << index into lpdt >>              <<06762>>00390000
          ldtx'index,       << index into ldtx >>              <<06762>>00395000
          dvr'index;     << index into dvrtab>>                <<06762>>00400000
                                                               <<06762>>00405000
integer array ldt(0:ldtsize),                                  <<06762>>00410000
              lpdt(0:lpdtsize),                                <<06762>>00415000
              ldtx(0:ldtxsize),                                <<06762>>00420000
              dvrtab(0:dvrsize);                               <<06762>>00425000
          <<--------------------->>                            <<03544>>00430000
          <<    disc types       >>                            <<03544>>00435000
          <<--------------------->>                            <<03544>>00440000
  equate  disc0=0,  << moving head discs >>                    <<03544>>00445000
          disc1=1,  << fixed head discs >>                     <<03544>>00450000
          disc2=2,  << floppy discs >>                         <<03544>>00455000
          disc3=3;  << moving head discs--cs'80 >>             <<03544>>00460000
          << ***** type 0 removable subtypes ***** >>          <<03544>>00465000
  equate  uh7905 =  4,  << subtype upper part 7905 >>          <<03544>>00470000
          s7920  =  8,  << subtype 7920 >>                     <<03544>>00475000
          s7925  =  9,  << subtype 7925 >>                     <<03544>>00480000
          uh7906 = 10,  << subtype upper part 7906 >>          <<03544>>00485000
          << ***** type 3 removable subtypes ***** >>          <<03544>>00490000
          buffalo=  3,  << subtype buffalo >>                  <<*8393>>00495000
          linus  =  0,  << subtype linus >>                    <<03544>>00500000
          s7935  =  8;  << subtype 7935 >>                     <<03544>>00505000
$include inclldt5                                              <<06762>>00510000
$include incllpdt                                              <<06762>>00515000
$include incldvr                                               <<06762>>00520000
$include incldct                                               <<06762>>00525000
                                                               <<06762>>00530000
                                                               <<06762>>00535000
          <<--------------                                              00540000
            volume table                                                00545000
          -------------->>                                              00550000
  equate  vtab8     =     8,         << word 8 of vtab >>      <<01549>>00555000
          vtab10    =    10,         << word 10 of vtab >>     <<01549>>00560000
          vtab12    =    12;         << word 12 of vtab >>     <<01549>>00565000
  define  vms       =    (12:1)#,    << v.m. supporting >>     <<01549>>00570000
          vtabldev  =    (0:8)#;     << logical device # >>    <<01549>>00575000
                                                                        00580000
          <<------------                                                00585000
            table dsts                                                  00590000
          ------------>>                                                00595000
  equate  lpdtdstn  =    13,         <<logical-physical device table>>  00600000
          ldtdstn   =    14,         <<logical device table>>           00605000
          drspdst   =    21,         <<directory space>>                00610000
          rindstn   =    22,         <<rin table>>                      00615000
          liddst    =    33,                                   <<*7657>>00620000
          vtabdstn  =    29;         <<volume table>>                   00625000
                                                                        00630000
         <<--------->>                                         <<tp.00>>00635000
         <<cpu types>>                                         <<tp.00>>00640000
         <<--------->>                                         <<tp.00>>00645000
  equate series'i  =      0,         <<return values from>>    <<tp.00>>00650000
         series'ii =      1,         <<thiscpu procedure>>     <<tp.00>>00655000
         lc3000    =      2,                                   <<tp.00>>00660000
         series'35 =      3,                                   <<01402>>00665000
         icf44     =      4,                                   <<01402>>00670000
         icf55     =      5,                                   <<m8393>>00675000
         series'37 =      6;                                   <<m8393>>00680000
  define postseries3    = bitmap1&csr(cputype)#,               <<02509>>00685000
         seriesii'iii   = bitmap0&csr(cputype)#,               <<m8393>>00690000
         multi'imb'sys  = bitmap7&csr(cputype)#;               <<m8393>>00695000
         <<----------------------->>                           <<02509>>00700000
         <<  i/o system formats   >>                           <<02509>>00705000
         <<----------------------->>                           <<02509>>00710000
                                                               <<02509>>00715000
  define io'sio          = bitmap2&csr(cputype)#,              <<02509>>00720000
         io'hpib         = bitmap3&csr(cputype)#,              <<02509>>00725000
         cltape'sio      = bitmap4&csr(cputype)#,              <<02509>>00730000
         cltape'amigo    = bitmap5&csr(cputype)#,              <<02509>>00735000
         cltape'cs80     = bitmap6&csr(cputype)#;              <<02509>>00740000
                                                               <<02509>>00745000
                                                               <<tp.00>>00750000
          <<--------------------------->>                      <<00134>>00755000
          <<message catalog set numbers>>                      <<00134>>00760000
          <<--------------------------->>                      <<00134>>00765000
   equate cimsgset=2;                                          <<00134>>00770000
                                                               <<00134>>00775000
          <<------                                                      00780000
            sirs                                                        00785000
          ------>>                                                      00790000
  equate  dirsir    =    8,          <<directory>>                      00795000
          fmavtsir =    16,          <<fmavt>>                 <<00197>>00800000
          rinsir    =    38,         <<rin sir>>                        00805000
          flabsir   =    37;         <<file label>>                     00810000
                                                               <<07039>>00815000
   <<----------------------------------->>                     <<07039>>00820000
   <<   sysdump/initial communication   >>                     <<07039>>00825000
   <<----------------------------------->>                     <<07039>>00830000
                                                               <<07039>>00835000
   equate mitversion     =  0,                                 <<07039>>00840000
          mitupdate      =  1,                                 <<07039>>00845000
          mitfix         =  2,                                 <<07039>>00850000
          version'       =  3,                                 <<07039>>00855000
          updatel'       =  4,                                 <<07039>>00860000
          fixlevel'      =  5,                                 <<07039>>00865000
          expflag'       =  6,                                 <<07039>>00870000
          drtnum         =  7,                                 <<07039>>00875000
          hldev'         =  8,                                 <<07039>>00880000
          hvol'          =  9,                                 <<07039>>00885000
          numadvrs       = 10,                                 <<07039>>00890000
          coldloadid'    = 11,                                 <<07039>>00895000
          filesdumped    = 12,                                 <<07039>>00900000
          serialdiscload'= 13,                                 <<07039>>00905000
          taperecsize'   = 14,                                 <<07039>>00910000
          discentry'     = 15,                                 <<07039>>00915000
          maxinitseg'    = 16,                                 <<07039>>00920000
          dvclsize'      = 20,                                 <<07039>>00925000
          ttdtsize'      = 21,                                 <<07039>>00930000
          oldvtabsize    = 22,                                 <<07039>>00935000
          oldinfosize    = 23,                                 <<07039>>00940000
          cstabsize      = 24,                                 <<07039>>00945000
          tlbufsize      = 25,                                 <<i8885>>00950000
          tlbufentries   = 26,                                 <<i8885>>00955000
          systapeldev'   = 27,                                 <<i8885>>00960000
          id0            = 30,                                 <<07039>>00965000
          id1            = 31,                                 <<07039>>00970000
          id2            = 32,                                 <<07039>>00975000
          id3            = 33,                                 <<07039>>00980000
          logfilenum'    = 40;                                 <<07039>>00985000
          <<---------------------                                       00990000
            configuration table                                         00995000
          --------------------->>                                       01000000
  equate  ctabcurversion =  1;                                 <<07039>>01005000
  equate  ctabchecksum = 0,          <<core size in k words>>  <<07039>>01010000
          ctabver   =    1,          <<version of ctab>>       <<07039>>01015000
          sss       =    2,          <<std stack size>>                 01020000
          coresize  =    3,          <<core size in k wds>>    <<07039>>01025000
          termpri   =    4,          <<terminal bound job priority>>    01030000
          normpri   =    5,          <<normal job priority>>            01035000
          cpupri    =    6,          <<cpu bound job priority>>         01040000
          logon     =    7,          <<number of seconds to logon>>     01045000
          logrecsize=    8,          <<log file record size>>           01050000
          logfilesize=   9,          <<log file size in records>>       01055000
          logbits   =    11,         <<what is being logged>>           01060000
          cpulim    =    16,         <<default cpu time limit>>         01065000
          tslice    =    27,         <<time quantum>>                   01070000
          maxspoolf =    28,         <<max open spoolfiles>>            01075000
          kilosects =    15,         <<spoolfile kilosectors>>          01080000
          extssect' =    33;         <<sector/spoolfile ext>>  <<07039>>01085000
                                                               <<03006>>01090000
  define  loadtype=(15:1)#, <<set if>>                         <<00150>>01095000
                            <<sysdump is to a serial disc>>    <<00150>>01100000
          loaddate=(14:1)#, <<set if>>                         <<i8894>>01105000
                            <<sysdump is futuredate>>          <<00150>>01110000
          loadfos =(13:1)#; <<set if>>                         <<i8894>>01115000
                            <<sysdump is run defaults>>        <<i8894>>01120000
                                                               <<i8894>>01125000
  equate  cstnum    =    0,      <<# of cst entries>>                   01130000
          dstnum    =    1,      <<# of dst entries>>                   01135000
          pcbnum    =    2,      <<# of pcb entries>>                   01140000
          ioqnum    =    3,      <<# of ioq entries>>                   01145000
          tbufnum   =    4,      <<# of terminal buffers>>              01150000
          cstxnum   =    5,          <<# of program area csts>>         01155000
          icssize   =    6,      <<# of words on ics>>                  01160000
          ucrqnum   =    7,      <<# of ucop req queue entries>>        01165000
          stopnum   =    8,          <<# of breakpoint table entries>>  01170000
          trlnum    =    9,      <<# of timer request list entries>>    01175000
          rins'     =    10,         <<# of rins>>                      01180000
          grins'    =    11,         <<max # of global rins>>           01185000
          sbufnum   =    12,         <<# of system buffers>>            01190000
          conprognum=    13,         <<# of concurrent programs>>       01195000
          lstsize   =    14,         <<loader seg table size>> <<07092>>01200000
          << typebuf (word 15) is reserved for future use >>   <<03702>>01205000
     <<   typebuf   =    15,     <<type ahead buffer size>>    <<03702>>01210000
          virmemsect'=   20,     <<size of virtual memory>>             01215000
          dirsect'  =    21,         <<size of directory in sectors>>   01220000
          mcss      =    30,     <<may code seg size>>                  01225000
          mcsp      =    31,         <<max code segs/process>>          01230000
          mstack    =    32,         <<max stack size>>                 01235000
          mxdss     =    33,     <<max extra data seg size>>            01240000
          mxdsp     =    34,         <<max xtra data segs/process>>     01245000
          maxrses   =    40,     <<max running sessions>>               01250000
   maxrjob   =   41,                                           <<00506>>01255000
   nlogprocs   =   42,                                         <<00506>>01260000
          logids=43,                                           <<01626>>01265000
          discreqtable=44,         <<disc request table length>>        01270000
          specialreqtable=45,      <<special request table length>>     01275000
          primarymsgtable=46,      <<primary message table length>>     01280000
          secndrymsgtable=48, <<2ndary msg table length>>      <<03701>>01285000
          swaptable=47;            <<swap table length>>       <<01626>>01290000
                                                                        01295000
          <<-------------                                               01300000
            system disk                                                 01305000
          ------------->>                                               01310000
  equate  sysdisc   =    1,       << system disc ldev >>       <<03544>>01315000
          infosect  =    28;     <<cold load info sector addr>><<00.dl>>01320000
                                                                        01325000
          <<--------------------                                        01330000
            configuration file                                          01335000
          -------------------->>                                        01340000
  equate  ctabrec   =    1;          <<non-coresize confiduration rec>> 01345000
                                                               <<06763>>01350000
          <<------------------------------->>                  <<06763>>01355000
          <<   device configuration file   >>                  <<06763>>01360000
          <<------------------------------->>                  <<06763>>01365000
                                                               <<06763>>01370000
  define  devchecksum   = devrec0#,  <<record 0 checksum>>     <<06763>>01375000
          devversion    = devrec0(1)#, << file version >>      <<06763>>01380000
          devnextrec    = devrec0(2)#, << next avail rec >>    <<06763>>01385000
          devhldev      = devrec0(3)#, << highest ldev >>      <<06763>>01390000
          devhdrt       = devrec0(4)#, << highest drt  >>      <<06763>>01395000
          devnradvrs    = devrec0(5)#; << nr add'l dvr >>      <<06763>>01400000
                                                               <<06763>>01405000
  equate  devtabenties  = 64, << start table of entries >>     <<06763>>01410000
          devcurversion =  1; << current dev file version >>   <<06763>>01415000
  equate  devdvrnr      =  0,    << driver table >>            <<06763>>01420000
          devlpdtnr     =  1,    << lpdt         >>            <<06763>>01425000
          devldtnr      =  2,    << ldt          >>            <<06763>>01430000
          devldtxnr     =  3,    << ldtx         >>            <<06763>>01435000
          devhdrnr      =  4,    << fdvcl header >>            <<06763>>01440000
          devclassnr    =  5,    << class table  >>            <<06763>>01445000
          devttdtnr     =  6,    << ttdt         >>            <<06763>>01450000
          devcsdvrnr    =  7,    << add'l cs dvr >>            <<06763>>01455000
          devcsdefnr    =  8,    << cs def table >>            <<06763>>01460000
          devcstabnr    =  9,    << cs table     >>            <<06763>>01465000
          devrec0size   =128;    << devdata rec size >>        <<06763>>01470000
equate                                                         <<t8393>>01475000
   defcurversion      = 1,                                     <<t8393>>01480000
   defrec0size        =128,                                    <<t8393>>01485000
   tl'head'size       = 6;                                     <<t8393>>01490000
                                                               <<t8393>>01495000
define                                                         <<t8393>>01500000
   tlh'checksum       = tl'head(0)                #,           <<t8393>>01505000
   tlh'version        = tl'head(1)                #,           <<t8393>>01510000
   tlh'table'size     = tl'head(2)                #,           <<t8393>>01515000
   tlh'ent'size       = tl'head(3)                #,           <<t8393>>01520000
   tlh'num'entries    = tl'head(4)                #,           <<t8393>>01525000
   tlh'first'entry'ptr= tl'head(5)                #;           <<t8393>>01530000
                                                               <<t8393>>01535000
                                                               <<t8393>>01540000
define                                                         <<t8393>>01545000
   tl'dev'name        = tl'entb(0)                 #,          <<t8393>>01550000
   tl'ent'size        = tl'ent( 8)                 #,          <<t8393>>01555000
   tl'num'dev'class   = tl'ent( 9)                 #,          <<t8393>>01560000
   tl'dev'class'ptr   = tl'ent(10)                 #,          <<t8393>>01565000
   tl'ttdf'ptr        = tl'ent(11)                 #,          <<t8393>>01570000
   tl'def'out'dev     = tl'ent(12)                 #,          <<t8393>>01575000
   tl'cs'ldtx'ptr     = tl'ent(13)                 #,          <<t8393>>01580000
   tl'ldev'num        = tl'ent(14)                 #,          <<t8393>>01585000
   tl'id'code         = tl'ent(15)                 #,          <<t8393>>01590000
   tl'drt'num         = tl'ent(16)                 #,          <<t8393>>01595000
   tl'unit'num        = tl'ent(17)                 #,          <<t8393>>01600000
   tl'dev'type        = tl'ent(18).( 0: 6)         #,          <<t8393>>01605000
   tl'dev'subtype     = tl'ent(18).( 6: 4)         #,          <<t8393>>01610000
   tl'job'accept      = tl'ent(18).(10: 1)         #,          <<t8393>>01615000
   tl'data'accept     = tl'ent(18).(11: 1)         #,          <<t8393>>01620000
   tl'interactive     = tl'ent(18).(12: 1)         #,          <<t8393>>01625000
   tl'duplicative     = tl'ent(18).(13: 1)         #,          <<t8393>>01630000
   tl'spool'state     = tl'ent(18).(14: 2)         #,          <<t8393>>01635000
   tl'chan'num        = tl'ent(19).( 0: 3)         #,          <<t8393>>01640000
   tl'core'res        = tl'ent(19).( 3: 1)         #,          <<t8393>>01645000
   tl'cs'dev          = tl'ent(19).( 4: 1)         #,          <<t8393>>01650000
   tl'spool'queues    = tl'ent(19).( 5: 1)         #,          <<t8393>>01655000
   tl'def'out'class   = tl'ent(19).( 6: 1)         #,          <<t8393>>01660000
   tl'auto'incr       = tl'ent(19).( 7: 1)         #,          <<t8393>>01665000
   tl'rec'width       = tl'ent(19).( 8: 8)         #,          <<t8393>>01670000
   tl'term'type       = tl'ent(20).( 0: 7)         #,          <<t8393>>01675000
   tl'auto'reply      = tl'ent(20).( 7: 1)         #,          <<s8966>>01680000
   tl'term'speed      = tl'ent(21)                 #,          <<t8393>>01685000
   tl'driver'name     = tl'entb(54)                #;          <<t8393>>01690000
                                                               <<t8393>>01695000
integer array defrec0( 0 : defrec0size - 1);                   <<t8393>>01700000
                                                               <<t8393>>01705000
          <<---------------------                                       01710000
            segmenter commands                                          01715000
          -------------------->>                                        01720000
  equate  addsl     =    1,      <<add sl segment>>                     01725000
          exitseg   =    8,      <<exit segmenter>>                     01730000
          listsl    =    11,     <<list sl>>                            01735000
          purgesl   =    17,     <<remove sl segment>>                  01740000
          usesl     =    20,     <<sl>>                                 01745000
          useusl    =    22;     <<usl>>                                01750000
                                                                        01755000
          <<-----------------                                           01760000
            condition codes                                             01765000
          ----------------->>                                           01770000
  equate  ccg       =    0,          <<greater>>                        01775000
          ccl       =    1,          <<less>>                           01780000
          cce       =    2;          <<equal>>                          01785000
  define  cc        =    stat.(6:2)#;<<status bits>>           <<01549>>01790000
                                                               <<04659>>01795000
          <<-------------------->>                             <<04659>>01800000
          <<  ascii characters  >>                             <<04659>>01805000
          <<-------------------->>                             <<04659>>01810000
                                                               <<04659>>01815000
  equate                                                       <<04659>>01820000
          cr'comma  =    %6454,      << cr & "," >>            <<06068>>01825000
          cr        =    %15,                                  <<04659>>01830000
          cr'semi   =    %6473;      << cr & ";" >>            <<04659>>01835000
                                                                        01840000
          <<---------------------------                                 01845000
            cold load tape parameters                                   01850000
          --------------------------->>                                 01855000
  equate  stacksize =  1024,        <<initial stack size>>     <<m8393>>01860000
          markersize=    12,         <<initial stack marker>>           01865000
          nstartseg =    11,         <<# of initial's segments <<03604>>01870000
          nnonswapseg=   4,          <<# of segments not swappe<<03604>>01875000
          a0size    =    12,         <<low core area size>>             01880000
          icsbase   =    %174000,    <<start of ics>>          <<03604>>01885000
          icslen    =    40,         <<ics length>>            <<03604>>01890000
          icsqi     =    32,         <<ics q value>>           <<06260>>01895000
          icszi     =  2044,         <<ics z value>>           <<03604>>01900000
          cstbase   = icsbase-tcstsize;<<start adr of cst>>    <<03604>>01905000
  define  coreend   =    %377750d#;  <<bank 1, address 177750>><<03604>>01910000
  define  initz     =    %102000d#;<<initial's z @ cold load>> <<06811>>01915000
                                                                        01920000
          <<--------------------------                                  01925000
            system global area cells                                    01930000
          -------------------------->>                                  01935000
  equate  dirdisc1  =    %130,        <<high-order bits>>      <<00215>>01940000
          dirdisc2  =    %131,        <<low-order bits>>       <<00215>>01945000
          sysid     =    %115,        <<system id>>                     01950000
          sysdiskldev=   62,          <<system disk logical device>>    01955000
          logfilenum=    %205,        <<log file number>>               01960000
          coldloadcnt=   %75;         <<cold load count>>               01965000
                                                                        01970000
              <<******************>>                           <<06813>>01975000
              << c s data segment >>                           <<06813>>01980000
              <<******************>>                           <<06813>>01985000
                                                               <<06813>>01990000
   define csldtxentrysize    = csldtx            #,            <<06813>>01995000
          csldtxdvrchangable = csldtx( 1).( 0: 1)#,            <<06813>>02000000
          csldtxhsi'chan     = csldtx( 1).( 1: 4)#,            <<06813>>02005000
          csldtxexp          = csldtx( 1).( 5: 1)#,            <<06813>>02010000
          csldtxprotocol     = csldtx( 1).( 8: 8)#,            <<06813>>02015000
          csldtxmode         = csldtx( 2).( 6: 4)#,            <<06813>>02020000
          csldtxcode         = csldtx( 2).(10: 6)#,            <<06813>>02025000
          csldtxdual'speed   = csldtx( 3).( 0: 1)#,            <<06813>>02030000
          csldtxhalf'speed   = csldtx( 3).( 1: 1)#,            <<06813>>02035000
          csldtxxmsnmode     = csldtx( 3).( 2: 2)#,            <<06813>>02040000
          csldtxspeedchngble = csldtx( 3).( 4: 1)#,            <<06813>>02045000
          csldtxanswer       = csldtx( 3).( 5: 2)#,            <<06813>>02050000
          csldtxdial         = csldtx( 3).( 7: 1)#,            <<06813>>02055000
          csldtxauto'dial'ldn= csldtx( 4)        #,            <<06813>>02060000
          csldtxdoptions     = csldtx( 5)        #,            <<06813>>02065000
          csldtxrecv'timeout = csldtx( 6)        #,            <<06813>>02070000
          csldtxlocal'timeout= csldtx( 7)        #,            <<06813>>02075000
          csldtxconct'timeout= csldtx( 8)        #,            <<06813>>02080000
          csldtxinspeed      = csldtx( 9)        #,            <<06813>>02085000
          csldtxoutspeed     = csldtx(11)        #,            <<06813>>02090000
          csldtxpbuffsize    = csldtx(13)        #,            <<06813>>02095000
          csldtxldev         = csldtx(14)        #,            <<06813>>02100000
          csldtxdrindex      = csldtx(15).( 8: 8)#,            <<06813>>02105000
          csldtxcontptr      = csldtx(16)        #,            <<06813>>02110000
          csldtxidlistptr    = csldtx(17)        #,            <<06813>>02115000
          csldtxphlistptr    = csldtx(18)        #,            <<06813>>02120000
          csldtxdump'date    = csldtx(34)        #,            <<06813>>02125000
          csldtx'dev'dumped  = csldtx(35).( 0: 1)#,            <<06813>>02130000
          csldtxcur'dump'num = csldtx(35).( 8: 8)#,            <<06813>>02135000
          csldtxmax'dumps    = csldtx(36)        #;            <<06813>>02140000
  equate  csdstn    =    49,                                            02145000
          csxentries=    1,                                             02150000
          csxptr    =    2,                                             02155000
          csxsize   =    6,                                             02160000
          csxstart  =    7,                                             02165000
          intcomdelay=   1, <<intercomponent delay>>                    02170000
          cirpdelay =    2, <<circular poll delay >>                    02175000
          contrstart=    37,<<control/tributary sect starts>>  <<08393>>02180000
          manlanswer=    1,      <<manual answer>>                      02185000
          autoanswer=    2,      <<automatic answer>>                   02190000
          numseq    =    2,      <<number of sequences>>                02195000
          conseqstart=   5,      <<compoence sequence                   02200000
                                start for control section>>             02205000
          numstation=    8;      <<# of stations>>                      02210000
   equate csdev17   =    17,  <<sccp>>                         <<01165>>02215000
          csdev18   =    18,  <<sslc>>                         <<01165>>02220000
          csdev19   =    19;  <<hsi>>                          <<01165>>02225000
  define  remostat      = 4).(0:8#,    <<remote stations>>              02230000
          numcomp       = 4).(8:8#,  <<# of components>>               02235000
          comptyp       = (6:2)#,                                       02240000
          firstcomp     = 3).(0:8#,                                     02245000
          lastcomp      = 3).(8:8#,                                     02250000
          nextcomp      = (0:6)#,                                       02255000
          intype      =   (0:2)#,                                       02260000
          switched  =    (lpdt'subtype mod 4)=0#,              <<06762>>02265000
          nonswitched=   1<=(lpdt'subtype mod 4)<=3#,          <<06762>>02270000
          modem      =   0<=(lpdt'subtype mod 4)<=2#,          <<06762>>02275000
          hardwired =    (lpdt'subtype mod 4)=3#,              <<06762>>02280000
          csdev     =    csdev17<=type<=csdev19#,              <<03544>>02285000
          csdevice  =    csdev17<=ldt'device'type<=csdev19#,   <<06762>>02290000
          contention=    1<=csldtxmode<=2#,<<aka pnt-to-pnt>>  <<+0.06>>02295000
          supervised=    3<=csldtxmode<=4#, <<aka multi-point>><<+0.06>>02300000
          <<aka means "ALSO KNOWN AS">>                        <<+0.06>>02305000
          controlst =    csldtxmode=3#,                                 02310000
          tributary =    csldtxmode=4#,                                 02315000
          cspresent =    cstab(csxentries)>0#;                          02320000
equate nsysprog  = 42, <<#system progs common to both>>        <<*8585>>02325000
       nsysprog'2 =14, <<#system progs unique to series'ii>>   <<01300>>02330000
       nsysprog'33=28,  <<#system progs unique to series'33>>  <<*8393>>02335000
       nfosfiles  = 1,  <<#system progs unique to fos tape >>  <<i9075>>02340000
       nsysprog'all=nsysprog+nsysprog'2+nsysprog'33+           <<i9075>>02345000
                   +nfosfiles;                                 <<i9075>>02350000
                                                               <<dl.01>>02355000
equate logrmax = 18;  << max number of log types >>            <<04251>>02360000
equate inbuflen=40, <<length in term input buffer>>            <<dl.01>>02365000
       binbuflen=inbuflen*2; <<byte length>>                   <<dl.01>>02370000
                                                                        02375000
  define quit0=                                                         02380000
                begin                                                   02385000
                message(m2466);                                <<*8393>>02390000
                quit(0);                                                02395000
                end#;                                                   02400000
  define  lbite     =    (0:8)#,     <<left byte>>                      02405000
          rbite     =    (8:8)#;     <<right byte>>                     02410000
  define  sysop     =    (5:1)#;     <<system operator capability>>     02415000
  equate  blank     =    %6440;                                         02420000
  define  duplicate =    tos:=s0#;                                      02425000
  define  d'l       =    double(logical#;                               02430000
  equate  diraccess =    0,  <<direct access>>                          02435000
          serinput  =    1,  <<serial input>>                           02440000
          coninout  =    2,  <<concurrent i/o>>                         02445000
          nconinout =    3,  <<non concurrent i/o>>                     02450000
          seroutput =    4,  <<serial output>>                          02455000
          termdevtype=   16, <<terminal device type>>          <<03544>>02460000
          tapetype  =    24; <<tape device type>>              <<03544>>02465000
  define  diracc    =    (15:1)#,                                       02470000
          serinp    =    (14:1)#,                                       02475000
          conio     =    (13:1)#,                                       02480000
          nconio    =    (12:1)#,                                       02485000
          serout    =    (11:1)#;                                       02490000
$page "DIRECTORY DATA STRUCTURE AND VARIABLES"                 <<de>>   02495000
                                                               <<de>>   02500000
equate                                                         <<de>>   02505000
   sys'dds         = 20;  << system data seg - dirc buffer >>  <<de>>   02510000
                                                               <<de>>   02515000
equate                                                         <<de>>   02520000
   xx              = 22,                                       <<de>>   02525000
   zz              = 139,                                      <<de>>   02530000
   namesize        = 4,                                        <<de>>   02535000
   dirlen          = 1024;  << length of dds buffer >>         <<de>>   02540000
array                                                          <<de>>   02545000
   dds(*)          = db+0;                                     <<de>>   02550000
equate             << displacements into prepre >>             <<de>>   02555000
   ddsbase         = 0,                                        <<de>>   02560000
   ddsbase1        = ddsbase,          << logical device and>> <<de>>   02565000
   ddsbase2        = ddsbase1+1,       << directory address >> <<de>>   02570000
   contents        = ddsbase2+1,       << directory pointer >> <<de>>   02575000
   lpntr           = contents+1,       << db addr of 1st ele >><<de>>   02580000
   iopntr          = lpntr+1,          << block start address>><<de>>   02585000
   numvalid        = iopntr+1,           <<# valid dir pp >>   <<de>>   02590000
   dirty           = numvalid+1,                               <<de>>   02595000
   flags           = dirty,                                    <<de>>   02600000
   xsize           = dirty+1,                                  <<de>>   02605000
   used            = xsize+1,            <<=xsize * xcount>>   <<de>>   02610000
   bsize           = used+1,             <<block size (pp.)>>  <<de>>   02615000
   bwsize          = bsize+1,            <<= bsize & lsr(7)>>  <<de>>   02620000
   bfactor         = bwsize+1,           <<= bwsize/xsize>>    <<de>>   02625000
   miscwd          = bfactor+1,                                <<de>>   02630000
   xcount          = miscwd+1,                                 <<de>>   02635000
   pcount          = xcount+1,                                 <<de>>   02640000
   etotal          = pcount+1,                                 <<de>>   02645000
   emiscwd         = etotal+1,                                 <<de>>   02650000
   pindexp         = emiscwd+1,                                <<de>>   02655000
   pname           = pindexp+1;                                <<de>>   02660000
                                                               <<de>>   02665000
                                                               <<de>>   02670000
array                                                          <<de>>   02675000
   daprepre(*)     = dds(zz);                                  <<de>>   02680000
array                                                          <<de>>   02685000
   dbprepre (*)    = daprepre(xx);                             <<de>>   02690000
                                                               <<de>>   02695000
integer                                                        <<de>>   02700000
   sysacctindex    = dbprepre+xx;                              <<de>>   02705000
double                                                         <<de>>   02710000
   dirbase         = sysacctindex+1;                           <<de>>   02715000
integer                                                        <<de>>   02720000
   dirbase1        = dirbase,                                  <<de>>   02725000
   dirbase2        = dirbase1+1;                               <<de>>   02730000
define                                                         <<de>>   02735000
   dirldev         = dirbase1.(0:8) #;                         <<de>>   02740000
integer                                                        <<de>>   02745000
   sysacctinx'sav  = dirbase+2,                                <<de>>   02750000
   dds'cnt         = sysacctinx'sav+1;                         <<de>>   02755000
double                                                         <<de>>   02760000
   dds'cnt1        = dds'cnt+1,                                <<de>>   02765000
   dds'cnt2        = dds'cnt1+2,                               <<de>>   02770000
   dds'cnt3        = dds'cnt2+2,                               <<de>>   02775000
   dds'cnt4        = dds'cnt3+2,                               <<de>>   02780000
   dds'cnt5        = dds'cnt4+2;                               <<de>>   02785000
real                                                           <<de>>   02790000
   goodpercent     = dds'cnt5+2;                               <<de>>   02795000
logical pointer                                                <<de>>   02800000
   base            = goodpercent+2;                            <<de>>   02805000
integer pointer                                                <<de>>   02810000
   ibase           = base;                                     <<de>>   02815000
double pointer                                                 <<de>>   02820000
   dbase           = base;                                     <<de>>   02825000
define                                                         <<de>>   02830000
   whichdirty = base(dirty) #;                                 <<de>>   02835000
                                                               <<de>>   02840000
             << directory block sizes >>                       <<de>>   02845000
                                                               <<de>>   02850000
equate  syssaibsize  =  3,    <<    account index block size>> <<de>>   02855000
        sysauibsize  =  1,    <<  acct/user index block size>> <<de>>   02860000
        sysagibsize  =  1,    << acct/group index block size>> <<de>>   02865000
        sysgfibsize  =  2,    << group/file index block size>> <<de>>   02870000
        sysgvsibsize =  1,    <<  group/vsd index block size>> <<de>>   02875000
        sysaebsize   =  3,    <<    account entry block size>> <<de>>   02880000
        sysuebsize   =  2,    <<       user entry block size>> <<de>>   02885000
        sysgebsize   =  2,    <<      group entry block size>> <<de>>   02890000
        sysfebsize   =  2,    <<       file entry block size>> <<de>>   02895000
        sysvsebsize  =  1,    <<        vsd entry block size>> <<de>>   02900000
        ddsbsize     =  3,    << maximum block size (3 sect)>> <<de>>   02905000
        ddsbwsize    =  %600; << maximum block size (#words)>> <<de>>   02910000
                                                               <<de>>   02915000
<<----------------------------------------------------------->><<07089>>02920000
<< directory space management data segment defines           >><<07089>>02925000
<<----------------------------------------------------------->><<07089>>02930000
                                                               <<07089>>02935000
<< directory space management control data                   >><<07089>>02940000
                                                               <<07089>>02945000
logical  ds'base         = db + 0;                             <<07089>>02950000
double   ds'dir'addr     = ds'base;            << dir. addr. >><<07089>>02955000
define   ds'ldev         = ds'base.(0:8)#;     << dir. ldev  >><<07089>>02960000
logical  ds'last'word    = ds'dir'addr + 2;    << buf. last w>><<07089>>02965000
pointer  ds'first'word   = ds'last'word + 1;   << buf. firs.w>><<07089>>02970000
logical  ds'dir'size     = ds'first'word + 1;  << dir. size  >><<07089>>02975000
logical  ds'flags        = ds'dir'size + 1;    << dsm flags  >><<07089>>02980000
define   ds'dirty        = ds'flags.(0:1)#;    << buf. mod.  >><<07089>>02985000
define   ds'err'in'prog  = ds'flags.(1:1)#;    << in progress>><<07089>>02990000
define   ds'dir'disabled = ds'flags.(2:1)#;    << sys. disabl>><<07089>>02995000
define   ds'perm'disable = ds'flags.(3:1)#;    << perm. dis. >><<07089>>03000000
logical  ds'cur'sector   = ds'flags + 1;       << sec. in buf>><<07089>>03005000
double   ds'addr         = ds'cur'sector + 1;  << sec. addr. >><<07089>>03010000
integer  ds'addr1        = ds'addr;                            <<07089>>03015000
integer  ds'addr2        = ds'addr + 1;                        <<07089>>03020000
integer  ds'size         = ds'addr + 2;        << buf data sz>><<07089>>03025000
logical  ds'req'sector   = ds'size + 1;        << requested s>><<07089>>03030000
logical  ds'last'sector  = ds'req'sector + 1;  << bm last sec>><<07089>>03035000
logical  ds'sys'last     = ds'last'sector + 1; << saved buf p>><<07089>>03040000
logical  ds'sys'first    = ds'sys'last + 1;    << saved buf p>><<07089>>03045000
logical  ds'sys'cur      = ds'sys'first + 1;   << saved buf s>><<07089>>03050000
logical  ds'sys'size     = ds'sys'cur + 1;     << sys dir siz>><<07089>>03055000
logical  ds'error'ldev   = ds'sys'size + 1;    << bad dir ldv>><<07089>>03060000
logical  ds'error'type   = ds'error'ldev + 1;  << dir err typ>><<07089>>03065000
define   ds'header       = 18#;                << ds head sz >><<07444>>03070000
                                                               <<07089>>03075000
<< buffer area                                               >><<07089>>03080000
                                                               <<07089>>03085000
array    ds'buffer (*)   = db + ds'header;     << buffer     >><<07089>>03090000
logical  ds'dir'last     = ds'buffer;          << sector 0 lw>><<07089>>03095000
logical  ds'dir'first    = ds'dir'last + 1;    << sector 0 fw>><<07089>>03100000
define   ds'dir'header   = 2#;                 << bm header  >><<07089>>03105000
define   ds'buf'size's   = 3#;                 << buf sz sec.>><<07089>>03110000
define   ds'buf'size'w   = %600#;              << buf sz word>><<07089>>03115000
define   ds'dst          = %25#;               << dsm dst    >><<07089>>03120000
                                                               <<07089>>03125000
<<----------------------------------------------------------->><<07089>>03130000
                                                               <<de>>   03135000
integer array typemask (0:2) :=                                <<de>>   03140000
                     %002720,      << account-user >>          <<de>>   03145000
                     %002120,      << account-group-file >>    <<de>>   03150000
                     %003120;      << account-group-vsd >>     <<de>>   03155000
$page "VARIABLE DECLARATIONS"                                  <<de>>   03160000
  byte pointer bpinbuf,              <<input buffer pointer>>           03165000
               sameprog,             <<same program change>>            03170000
               bpnotdump,            <<files not dumped>>               03175000
               bpspc;                                                   03180000
  integer array tableptrs(0:exptables)=db;                     <<06762>>03185000
                <<ptrs to expanding tables>>                   <<06762>>03190000
                                                               <<06762>>03195000
  integer pointer                                              <<06762>>03200000
          cstab    =tableptrs+1,<< cs table             >>     <<06762>>03205000
          tclass   =tableptrs+2,<< temp dev class table >>     <<06812>>03210000
          dct'head =tableptrs+3,<< header for dct       >>     <<06812>>03215000
          dctab    =tableptrs+4,<< device class tab     >>     <<06812>>03220000
          tdtab    =tableptrs+5,<< term type descr table>>     <<*7657>>03225000
          tl'buf   =tableptrs+6,<< table lookup         >>     <<t8393>>03230000
          vtab     =tableptrs+7,<< volume table         >>     <<t8393>>03235000
          oldvtab  =tableptrs+8,<< old copy of vtab     >>     <<t8393>>03240000
          lidtab   =tableptrs+9,<<logging id table        >>   <<t8393>>03245000
          ctab     =tableptrs+10,<<coresize related conf  >>   <<t8393>>03250000
          ctab0    =tableptrs+11;<<configuration info     >>   <<t8393>>03255000
                                                               <<06762>>03260000
  byte pointer                                                 <<06762>>03265000
          blinbuf=tableptrs+0,<<filename input buffer>>        <<06762>>03270000
          bdvrtab,                                             <<06762>>03275000
          tdt'b,     << current entry pointer >>               <<*7657>>03280000
          dct'b,                                               <<t8393>>03285000
          tl'entb;                                             <<t8393>>03290000
                                                               <<06762>>03295000
  integer array tableincrs(0:exptables-1)=db:=exptables(0);    <<06762>>03300000
               <<increments for expanding tables>>             <<06762>>03305000
                                                               <<06762>>03310000
  integer blinbufincr =tableincrs+0,<<blinbuf increment   >>   <<06762>>03315000
          cstabincr   =tableincrs+1,<<cs table increment  >>   <<06762>>03320000
          tclassincr  =tableincrs+2,<<temp dev class incr >>   <<06812>>03325000
          dcthincr    =tableincrs+3,<<device class head   >>   <<06812>>03330000
          dctabincr   =tableincrs+4,<<future dvcltab incr >>   <<06812>>03335000
          ttdtincr    =tableincrs+5,<<termtype descr incr >>   <<06812>>03340000
          tl'incr     =tableincrs+6,<<table lookup incr   >>   <<t8393>>03345000
          vtabincr    =tableincrs+7,<<volume tab incr     >>   <<t8393>>03350000
          << no incr needed for old vtab                  >>   <<t8393>>03355000
          lidtabincr  =tableincrs+9,<<logging id table inc>>   <<t8393>>03360000
          ctabincr    =tableincrs+10,                          <<t8393>>03365000
          ctab0incr   =tableincrs+11;                          <<t8393>>03370000
                                                               <<06762>>03375000
  integer pointer                                              <<06762>>03380000
          tdt ,              << current tdt entry to work on >><<*7657>>03385000
          dct,                                                 <<06762>>03390000
          tl'ent,                                              <<t8393>>03395000
          tl'head,                                             <<t8393>>03400000
          csldtx;            <<current entry in cstab     >>   <<*7833>>03405000
                                                               <<06762>>03410000
integer event'word;             <<log event mask word #>>      <<01762>>03415000
  equate spclength = (nsysprog'all+7)*17;                      <<04253>>03420000
  equate sysprog'chg'table'limit = spclength*2;                <<04253>>03425000
                      <<calc maxlength of system prog table>>  <<04253>>03430000
        double dtemp;                                          <<01073>>03435000
        integer dt0=dtemp,dt1=dtemp+1;                         <<01073>>03440000
        logical listfiles := false;                            <<01073>>03445000
  integer array lbuf(0:4512),        <<utility buffer>>        <<02509>>03450000
                comm(0:127), << sysdump/initial communication>><<07039>>03455000
                devrec0(0:127),      <<parms for dev conf>>    <<06763>>03460000
                tcst(0:tcstsize-1),  <<temporary cst>>                  03465000
                csdvr(0:csdvrtsize-1),                                  03470000
                csdef(0:csdefsize-1),<<csldtx entry# cross>>   <<+0.06>>03475000
                <<reference table indexed by ldev>>            <<+0.06>>03480000
                flab(0:127),         <<file label>>                     03485000
                ivname(0:3),         <<volume name>>                    03490000
                dname(*)=ivname,      <<driver name>>                   03495000
                dbarray(*)=db+0,                                        03500000
                segsize(0:31),       <<init segment sizes>>             03505000
                segadr(0:31),        <<init segment record #'s>>        03510000
                rec0(0:127),         <<init record 0>>                  03515000
                stt(0:383),          <<init segment's stt>>             03520000
                inbuf(0:inbuflen-1), <<input buffer>>          <<dl.01>>03525000
                spc(0:spclength);    <<system program changes>><<hc.01>>03530000
  double pointer dcsldtx=csldtx;                                        03535000
  byte array filename(*)=lbuf,       <<list file designator>>           03540000
             b(*)=lbuf(128),         <<:file command for seglist>>      03545000
             notdump(*)=stt,         <<files not dumped>>               03550000
             blbuf(*)=lbuf,                                             03555000
             bspc(*)=spc,                                               03560000
             binbuf(*)=inbuf,                                           03565000
             vname(*)=ivname,                                           03570000
          btyp(*)=vname,                                                03575000
             bcsdvr(*)=csdvr,                                           03580000
             bdname(*)=vname,                                           03585000
             brec0(*)=rec0;                                             03590000
  double array flabdbl(*)=flab,                                         03595000
               dlbuf(*)=lbuf,                                           03600000
               dtcst(*)=tcst,                                  <<03604>>03605000
          dctab0(*)=ctab0,                                              03610000
                  dbdbl(*)=db+0;                                        03615000
 define  << file label definition >>                                    03620000
 fllocname   =flab( 0)#,       << local file name >>                    03625000
 flgrpname   =flab( 4)#,       <<  group name >>                        03630000
 flacctname  =flab( 8)#,       << account name >>                       03635000
 fluserid    =flab(12)#,       << creating userid >>                    03640000
 fllockword  =flab(16)#,       << lockword >>                           03645000
 flsecmx     =flab(20)#,       << security matrix >>                    03650000
 flcreate    =flab(23)#,       << create date >>                        03655000
   fllastacc   =flab(24)#,       << last access date >>                 03660000
 fllastmod   =flab(25)#,       << last modification date >>             03665000
 flfilecode  =flab(26)#,       << file code >>                          03670000
 flfcbvect   =flabdbl(16)#,       << fcb vector >>             <<07155>>03675000
 flflim      =flabdbl(15)#,    << file limit >>                         03680000
 flpvinf     =flab(27)#, <<private vol info word>>             <<07155>>03685000
 flmvtabx    =flpvinf.(4:4)#,                                  <<07155>>03690000
 flclid      =flab(35)#,       << cold load id >>                       03695000
 flfoptions  =flab(36)#,       << foptions >>                           03700000
 flrecsize   =flab(37)#,       << record size >>                        03705000
 flblksize   =flab(38)#,       << block size >>                         03710000
 flsectoff   =flab(39).(0:8)#, << sector offset to data >>              03715000
 fldflags    =flab(39).(8:4)#, << disc flags >>                         03720000
flnumexts   =flab(39).(11:5)#,<<number of extents>>                     03725000
 flnextword  =flab(39)#,                                                03730000
 fleofdisp   =flab(40)#,       << logical s9ze of last block >>         03735000
 flextsize   =flab(41)#,       << extent size >>                        03740000
 fllastextsize=flab(40)#,      <<size of last extent>>         <<00.cr>>03745000
 fleof       =flabdbl(21)#,    << end-of-data pointer >>                03750000
 flext0      =22#,             <<1st extent>>                           03755000
 flextmap    =flab(44)#;       << origin of extent map >>               03760000
equate                                                         <<03604>>03765000
   flmiscx      = 28,  <<load, read, etc index>>               <<03604>>03770000
   flchecksumx  = 34,  <<checksum index>>                      <<03604>>03775000
   flclidx      = 35;  <<cold load id index>>                  <<03604>>03780000
  byte array ctabfile(0:17):="CONFDATA.PUB.SYS ";              <<06763>>03785000
  byte array devfile(0:15) := "DEVDATA.PUB.SYS ";              <<06763>>03790000
  byte array deffile(0:15) := "DEFDATA.PUB.SYS ";              <<t8393>>03795000
    <<------------------------------------------>>             <<dl.01>>03800000
    <<catalog file changes using makecat.pub.sys>>             <<dl.01>>03805000
    <<------------------------------------------>>             <<dl.01>>03810000
                                                               <<dl.01>>03815000
  byte array makecatprog(0:15):="MAKECAT.PUB.SYS ";            <<dl.01>>03820000
  integer makecatpin,                                          <<dl.01>>03825000
          makecatjcw;                                          <<dl.01>>03830000
  equate  makecatflag=1,                                       <<dl.01>>03835000
          makecatsusp=2;                                       <<dl.01>>03840000
                                                               <<04659>>03845000
<<-------------------->>                                       <<04659>>03850000
<<    store stuff     >>                                       <<04659>>03855000
<<-------------------->>                                       <<04659>>03860000
                                                               <<04659>>03865000
equate                                                         <<04659>>03870000
   dump'date'len         = 8, <<# of chars in: "mm/dd/yy">>    <<04659>>03875000
   s'err'syntax          = 1, <<store found syntax error>>     <<04659>>03880000
   s'err'unknown'program = 2, <<store.pub.sys not found>>      <<04659>>03885000
   s'err'createprocess   = 3, <<createprocess found error>>    <<04659>>03890000
   s'err'store'failed    = 4, <<store failed>>                 <<04659>>03895000
   s'err'activate        = 5, <<activate failed>>              <<04659>>03900000
   s'err'mail            = 6, <<mail stuff failed>>            <<04659>>03905000
   store'files'len       = 240; <<length of store'files'>>     <<04659>>03910000
                                                               <<04659>>03915000
byte array                                                     <<04659>>03920000
   dump'date'     (0:dump'date'len-1),                         <<04659>>03925000
   store'files'   (0:store'files'len-1),                       <<04659>>03930000
   storejcw'      (0:8):="STOREJCW ";                          <<04659>>03935000
                                                               <<04659>>03940000
                                                               <<04659>>03945000
<<--------------------------------------->>                    <<00150>>03950000
<<softdump changes using sdfcheck.pub.sys>>                    <<00150>>03955000
<<--------------------------------------->>                    <<00150>>03960000
                                                               <<00150>>03965000
byte array sdfprog(0:16):="SDFCHECK.PUB.SYS ";                 <<00150>>03970000
integer sdfpin,                                                <<00150>>03975000
        sdfjcw;                                                <<00150>>03980000
equate  sdfflag=1,                                             <<00150>>03985000
        sdfsusp=2;                                             <<00150>>03990000
                                                               <<00150>>03995000
  byte array dirfname(0:8):="SYSTDIRC ";  << temp directory >> <<de>>   04000000
  byte array pslfile(0:8):="SL       "; <<permanent sl file>>  <<04253>>04005000
  byte array tslfile (0:25):=                                  <<04253>>04010000
          "TEMPSL                    "; <<temporary sl file>>  <<04253>>04015000
  byte array listfile(0:8):="SYSDLIST ";   <<list file>>                04020000
  byte array tapefile(0:8):="DUMPTAPE ";   <<mag tape for dump>>        04025000
  byte array goodfile(0:8):="SYSDGOOD ";                                04030000
  byte array errorfile(0:7):="SYSDERR ";                                04035000
  byte array initfile(0:8):="INITIAL  ";   <<initialize program>>       04040000
  byte array tapeentryname(0:7):="TAPELOAD";                            04045000
  byte array discentryname(0:7) := "DISCBOOT";                          04050000
  byte array direc(0:9):="DIRECTORY ";                                  04055000
  byte array segerrmess(0:17):="SEGMENTER ERROR # ";                    04060000
  byte array hex(0:15) := "0123456789ABCDEF";                           04065000
  byte array catalogfile(0:7):="CATALOG "; <<must match>>      <<dl.01>>04070000
       <<system program file name for catalog file>>           <<dl.01>>04075000
  byte array catalogfile'rep(0:25):=                           <<04253>>04080000
               "CATALOG                   ";                   <<04253>>04085000
  byte array sdfcomfile(0:7):="SDFCOM  "; <<must match>>       <<00150>>04090000
  <<system program file name for the softdump facility>>       <<00150>>04095000
  <<command file>>                                             <<00150>>04100000
  byte array sdfcomfile'rep(0:25):=                            <<04253>>04105000
               "SDFCOM                    ";                   <<04253>>04110000
                                                               <<00150>>04115000
byte array sysprog(0:nsysprog*8-1):=                           <<01300>>04120000
      "HIOTAPE0","HIOLPRT0","HIOLPRT1",                        <<01300>>04125000
      "HIOFLOP0","HIOMDSC1","IOINP0  ",                        <<01300>>04130000
      "LOG     ","ININ    ","DEVREC  ",                        <<01300>>04135000
      "PROGEN  ","UCOP    ","IOCDPN0 ",                        <<01300>>04140000
      "LOAD    ","SEGDVR  ","HIOMDSC2",                        <<03544>>04145000
      "SEGPROC ","SYSDUMP ","INITIAL ",                        <<01300>>04150000
      "CONFDATA","PFAIL   ","MAKECAT ",                        <<01300>>04155000
      "MEMLOGP ","CATALOG ","PVPROC  ",                        <<01300>>04160000
      "PVINIT  ","MPECHECK","IODS0   ",                        <<01300>>04165000
      "CSDUMMY ","HIOLPRT2","HIOPPRT0",                        <<02520>>04170000
      "HIOTAPE1","HIOCTAP0","HIOCIPR0",                        <<04536>>04175000
      "STORE   ","IODSTRM0","IODSX   ",                        <<04955>>04180000
      "IODSTRMX","IOPAD0  ","DEVDATA ",                        <<07388>>04185000
      "HIOTAPE2","DEFDATA ","IOPAD1  ";                        <<*8585>>04190000
byte array sysprog'2(0:nsysprog'2*8-1):=                       <<01300>>04195000
      "IOTAPE0 ","IOLPRT0 ","IOTERM0 ",                        <<01300>>04200000
      "IOMDISC0","IOFDISC0","IOCDRD0 ",                        <<01300>>04205000
      "CSHBSC0 ","IOREM0  ","IOPTRD0 ",                        <<01300>>04210000
      "IOPTPN0 ","IOPLOT0 ","IOPRPN0 ",                        <<01300>>04215000
      "IOMDISC1","CSSBSC0 ";                                   <<01300>>04220000
byte array sysprog'33(0:nsysprog'33*8-1):=                     <<01300>>04225000
      "SDFLOAD ","SDFCOM  ","SDFCHECK",                        <<01300>>04230000
      "SDFGEN  ","SYSWCS64","HIOTERM2",                        <<06810>>04235000
      "HIOTERM1","HIOASLP0","HIOCDRD0",                        <<06068>>04240000
      "TT4     ","TT6     ","TT9     ",                        <<06068>>04245000
      "TT10    ","TT12    ","TT13    ",                        <<06068>>04250000
      "TT15    ","TT16    ","TT18    ",                        <<06068>>04255000
      "TT19    ","TT20    ","TT21    ",                        <<06068>>04260000
      "TT22    ","TT31    ","VFC31B7 ",                        <<06068>>04265000
      "VFC31B8 ","HIOASLP2","SYSWCS37",                        <<*8393>>04270000
      "HIOCTAP1";                                              <<*8393>>04275000
byte array fosfiles(0:nfosfiles*8-1):=                         <<i9075>>04280000
      "AUTOINST";                                              <<i9075>>04285000
  integer array firstday(0:11):=0,31,59,90,120,151,181,212,243,273,304, 04290000
                                334; <<first day of each month>>        04295000
  integer array dayinmonth(0:11):=31,28,31,30,31,30,31,31,30,31,30,31;  04300000
  integer array retval(0:1)=db:=0,0; <<return from istore>>             04305000
  integer array coresizes(0:ncoresizes-1) :=                   <<01757>>04310000
    64, 80, 96, 128, 160, 192, 224, 256, 384, 512, 768, 1024,  <<01757>>04315000
    1152, 1280, 1408, 1536, 1664, 1792, 1920, 2048,            <<01757>>04320000
    2176, 2304, 2432, 2560, 2688, 2816, 2944, 3072,            <<01757>>04325000
    3200, 3328, 3456, 3584, 3712, 3840, 3968, 4096;            <<01757>>04330000
  byte array uslfile(0:26),          <<usl file name>>                  04335000
             fullname(0:27),         <<full file name>>                 04340000
             segment(0:15),          <<segment name>>                   04345000
             fqfname(0:25),                                    <<06068>>04350000
          devclass(*)=segment;       <<device class name>>              04355000
  integer array ifqfname(*) = fqfname;                         <<06068>>04360000
  array versid(0:2);                                           <<12.km>>04365000
  byte array bversid(*)= versid;                               <<12.km>>04370000
  define version=     versid #,                                <<12.km>>04375000
         updatel=     versid(1) #,                             <<12.km>>04380000
         fixlevel=    versid(2) #;                             <<12.km>>04385000
  define bversion=    bversid(1) #,                            <<12.km>>04390000
         bupdatel=    bversid(2) #,                            <<12.km>>04395000
         bfixlevel=   bversid(4) #,                            <<12.km>>04400000
         bversid'end= bversid(5) #;                            <<12.km>>04405000
                                                                        04410000
  double flimit,                                                        04415000
         eof,                        <<end of file>>                    04420000
         capability,                 <<user capability from who>>       04425000
         dirdiscadr,                 <<directory disc address>>         04430000
         systemfilespace := 0d,     <<total system file space>><<00928>>04435000
          ds0 = s-1;    <<top of stack double>>                         04440000
  integer ctabfnum,                  <<configuration file number>>      04445000
          deffnum,                   <<default device file numb<<t8393>>04450000
          devfnum,                   <<device conf file num>>  <<06763>>04455000
          pslfnum,                   <<permanent sl file number>>       04460000
          tslfnum,                   <<temporary sl file number>>       04465000
          listfnum,                  <<list file number>>               04470000
          initfnum,                  <<configurator file number>>       04475000
          tapefnum,                  <<tape file number>>               04480000
          goodfnum,                  <<good file number>>               04485000
          errfnum,                   <<error file number>>              04490000
          rins,                      <<# of rins>>                      04495000
          grins,                     <<# of global rins>>               04500000
          mingrin,                   <<minimum number of global rins>>  04505000
          mindrt, <<smallest allowable drt fot this cputype>>  <<00072>>04510000
          maxdrt, << maximum drt num for this cpu type     >>  <<06762>>04515000
          minrin,                    <<minimum number of rins>><<06814>>04520000
          rindseg,                   <<dstn of new rin table>> <<06814>>04525000
          dllen,                     <<size of dl area>>                04530000
          rinlen,                    <<length of rin table>>            04535000
          nrinlen,                   <<new length of rin table>>        04540000
      lidtablen,                                               <<00506>>04545000
      newlidtablen,                                            <<00506>>04550000
          rsir,                      <<rin sir return>>                 04555000
          mode,                      <<mode (from who)>>                04560000
          usllen,                    <<# of chars in usl name>>         04565000
          drtn,                      <<drt #>>                          04570000
          unitn,                     <<unit #>>                <<06762>>04575000
          ldev,                      <<logical device #>>               04580000
          olddrt,                    <<old drt #>>                      04585000
          hldev,                     <<highest logical device number>>  04590000
          nvol,                      <<volume table counts>>   <<rh.pv>>04595000
          index,                     <<table index>>                    04600000
          maxinitseg,                <<max initial segment size>>       04605000
          tablesize,                 <<size of initial's table area>>   04610000
          initpb,                    <<configurator pb>>                04615000
          initdb,                    <<configurator db>>                04620000
          db'index,                                            <<*8393>>04625000
          nseg,                      <<# of segments for init>>         04630000
          sttindex,                  <<index in stt to pl>>             04635000
          sttrec,                    <<stt record #>>                   04640000
          oldcst,                    <<cst from stt entry>>             04645000
          firstcst,                  <<first cst used by init>>         04650000
          taperecsize,               <<size of tape rec's>>    <<03604>>04655000
          coldloadid,                <<cold load count>>                04660000
          discentry,                 <<disc cold load entry point>>     04665000
          tapeentry,                 <<tape cold load entry point>>     04670000
          dumpdate,                  <<date oldest file was changed>>   04675000
          dsir,                      <<directory sir return>>           04680000
          fmsir,                     <<fmavtsir return>>       <<00197>>04685000
          fsir,                      <<file sir return>>                04690000
          efrcount=retval,           <<# of records in error file>>     04695000
          gfrcount=retval+1,         <<# of records on good file>>      04700000
          density  := 0,             <<density of tape>>       <<04659>>04705000
          recsize,                   <<file record size>>               04710000
          blksize,                   <<file block size>>                04715000
          devtype,                   <<device type>>                    04720000
          foptions,                                                     04725000
          aoptions,                                                     04730000
          cputype,                   <<type of hp3000 cpu>>    <<tp.00>>04735000
          filecode,                                                     04740000
          initalloc,                                                    04745000
          extsize,                                                      04750000
          numextents,                                                   04755000
          segerror,                  <<segmenter error #>>              04760000
          tindex,      <<temporary class index>>                        04765000
          expflag,                   <<exp sys flag>>          <<06070>>04770000
          pin;                       <<temporaries>>           <<*7657>>04775000
  integer i,j,k,l,m,n,temp;          <<temporaries>>                    04780000
  logical more,                                                         04785000
          ldumpdate=dumpdate,                                  <<00072>>04790000
        dev'defaults,                                          <<t8393>>04795000
          dirsect,                        << directory size >> <<de>>   04800000
          direc'size,                     << old dir. size   >><<07089>>04805000
          attrib=capability,         <<user attributes>>                04810000
          rinchange := false,        <<rin table changed>>              04815000
          sirs := false,             <<directory and file sirs held>>   04820000
          tempslopen := false,                                          04825000
          error := false,                                               04830000
          last = error,                                                 04835000
          magtape,       << dumping to a magtape? >>           <<02509>>04840000
          tempslsaved := false;                                         04845000
  integer x=x;                       <<x register>>                     04850000
  logical xr = x;                                              <<07089>>04855000
  byte bs0=s-0,bs1=s-1;              <<top of stack byte values>>       04860000
  integer s0=s-0,s1=s-1,s2=s-2,s3=s-3,s4=s-4,s5=s-5,s6=s-6,s7=s-7;      04865000
  logical ls0=s-0;                                             <<rh.pv>>04870000
  integer pointer ps0=s-0,ps1=s-1;  <<<top of stack pointers>>          04875000
  byte pointer bps0=s-0,bps1=s-1;    <<top of stack byte pointers>>     04880000
  logical stat=q-1;                  <<status word in marker>>          04885000
  logical returnp=q-2;               <<return address in marker>>       04890000
  integer parmq4 = q-4;              <<parm for exp sys>>      <<06070>>04895000
  integer infolen = q-6;                                       <<*8393>>04900000
  byte pointer info = q-5;                                     <<*8393>>04905000
  integer array db2(*)=db+2;                                            04910000
   array errmess(0:7) _ "*ERROR, PARM#  *";                             04915000
  integer array ias0(*)=s-0;                                            04920000
                                                               <<rh.pv>>04925000
  define                                                       <<rh.pv>>04930000
          mvol = nvol.(0:8)#,        <<max vols in vtab>>      <<rh.pv>>04935000
          hvol = nvol.(8:8)#;        <<sys vols in vtab>>      <<rh.pv>>04940000
                                                               <<dl.01>>04945000
          equate semicolonblank=%35440,                        <<dl.01>>04950000
                 semicoloncomma=%35454,                        <<dl.01>>04955000
                 reset=0;                                      <<00777>>04960000
  array filemask(4:12):=%7502,%7501,%7503,%7503,%7503,%7503,   <<00072>>04965000
  %7502,%7501,%7503;                                           <<00072>>04970000
  integer array sec'cyl (4:12):= 96, 48, 144, 144, 240, 576,   <<02509>>04975000
  96,96,192;                                                   <<00072>>04980000
  array headbase (4:12):= 0, %1000, 0, 0, 0, 0,                <<00072>>04985000
  0,%1000,0;                                                   <<00072>>04990000
  array hdbase (0:12):= 0, 2, 0, 0, 0, 2, 0, 0, 0, 0,          <<00072>>04995000
  0,2,0;                                                       <<00072>>05000000
  array secthd (0:12):= 24, 24, 24, 23, 48, 48, 48, 48, 48, 64,<<00072>>05005000
  48,48,48;                                                    <<00072>>05010000
equate                                                         <<00185>>05015000
          magtapetype=24;                                      <<02509>>05020000
   equate reqstat = 7; <<status request function code>>        <<00072>>05025000
   define doublesided=lbuf(1).(4:1)=1#;<<status return for floppy>>     05030000
   double discaddress;                                                  05035000
   integer d1=discaddress,                                              05040000
           d2=discaddress+1,                                            05045000
           outdevtype, <<real devtype for output dev>>         <<00072>>05050000
           flop'sec'cyl,<<single or double sided flop>>        <<00072>>05055000
           blockn,                                             <<00072>>05060000
           sdiscldev;                                                   05065000
   define floppy=(outdevtype=disc2)#;                          <<03604>>05070000
   define stype=devtype.(0:8)#;                                         05075000
                                                               <<00072>>05080000
<<-------------------------------------->>                     <<00072>>05085000
<<header/trailer labels for floppy discs>>                     <<00072>>05090000
<<-------------------------------------->>                     <<00072>>05095000
double time;                                                   <<00072>>05100000
integer time1=time,                                            <<00072>>05105000
        time2=time1+1;                                         <<00072>>05110000
integer reelnum:=1;                                            <<00072>>05115000
logical date;                                                  <<00072>>05120000
                                                               <<00072>>05125000
define null'date= dumpdate=-1#,                                <<00072>>05130000
       future'date= date<ldumpdate and dumpdate<>-1#;          <<00150>>05135000
   equate noerr=1; <<low word value meaning attachio>>                  05140000
                   <<executed properly>>                                05145000
integer errorcode; <<fcheck return value>>                     <<00072>>05150000
equate eotcode=23; <<end of tape return from fcheck>>          <<00072>>05155000
array tpfilemask(4:12):=%7406,%7405,%7407,%7407,%7407,%7407,   <<00072>>05160000
                        %7406,%7505,%7407;                     <<00072>>05165000
equate seed=%123456;<<starting value for the checksum>>        <<00150>>05170000
                    <<for coldload on the series'25>>          <<*8393>>05175000
                                                               <<*8393>>05180000
      <<**************************************************>>   <<*8393>>05185000
      <<  message system equates                          >>   <<*8393>>05190000
      <<**************************************************>>   <<*8393>>05195000
                                                               <<*8393>>05200000
equate                                                         <<*8393>>05205000
   m0      = 0,                                                <<*8393>>05210000
   m1      = 1,                                                <<*8393>>05215000
   m2      = 2,                                                <<*8393>>05220000
   m3      = 3,                                                <<*8393>>05225000
   m4      = 4,                                                <<*8393>>05230000
   m5      = 5,                                                <<*8393>>05235000
   m6      = 6,                                                <<*8393>>05240000
   m7      = 7,                                                <<*8393>>05245000
   m8      = 8,                                                <<*8393>>05250000
   m9      = 9,                                                <<*8393>>05255000
   m10     = 10,                                               <<*8393>>05260000
   m11     = 11,                                               <<*8393>>05265000
   m12     = 12,                                               <<*8393>>05270000
   m13     = 13,                                               <<*8393>>05275000
   m14     = 14,                                               <<*8393>>05280000
   m15     = 15,                                               <<*8393>>05285000
   m16     = 16,                                               <<*8393>>05290000
   m17     = 17,                                               <<*8393>>05295000
   m18     = 18,                                               <<*8393>>05300000
   m19     = 19,                                               <<*8393>>05305000
   m20     = 20,                                               <<*8393>>05310000
   m21     = 21,                                               <<*8393>>05315000
   m22     = 22,                                               <<*8393>>05320000
   m23     = 23,                                               <<*8393>>05325000
   m24     = 24,                                               <<*8393>>05330000
   m25     = 25,                                               <<*8393>>05335000
   m26     = 26,                                               <<*8393>>05340000
   m27     = 27,                                               <<*8393>>05345000
   m28     = 28,                                               <<*8393>>05350000
   m29     = 29,                                               <<*8393>>05355000
   m30     = 30,                                               <<*8393>>05360000
   m31     = 31,                                               <<*8393>>05365000
   m32     = 32,                                               <<*8393>>05370000
   m33     = 33,                                               <<*8393>>05375000
   m34     = 34,                                               <<*8393>>05380000
   m35     = 35,                                               <<*8393>>05385000
   m100    = 100,                                              <<*8393>>05390000
   m101    = 101,                                              <<*8393>>05395000
   m102    = 102,                                              <<*8393>>05400000
   m103    = 103,                                              <<*8393>>05405000
   m104    = 104,                                              <<*8393>>05410000
   m105    = 105,                                              <<*8393>>05415000
   m106    = 106,                                              <<*8393>>05420000
   m107    = 107,                                              <<*8393>>05425000
   m108    = 108,                                              <<*8393>>05430000
   m109    = 109,                                              <<*8393>>05435000
   m110    = 110,                                              <<*8393>>05440000
   m111    = 111,                                              <<*8393>>05445000
   m112    = 112,                                              <<*8393>>05450000
   m113    = 113,                                              <<*8393>>05455000
   m114    = 114,                                              <<*8393>>05460000
   m115    = 115,                                              <<*8393>>05465000
   m116    = 116,                                              <<*8393>>05470000
   m117    = 117,                                              <<*8393>>05475000
   m118    = 118,                                              <<*8393>>05480000
   m119    = 119,                                              <<*8393>>05485000
   m120    = 120,                                              <<*8393>>05490000
   m121    = 121,                                              <<*8393>>05495000
   m122    = 122,                                              <<*8393>>05500000
   m123    = 123,                                              <<*8393>>05505000
   m124    = 124,                                              <<*8393>>05510000
   m125    = 125,                                              <<*8393>>05515000
   m126    = 126,                                              <<*8393>>05520000
   m127    = 127,                                              <<*8393>>05525000
   m128    = 128,                                              <<*8393>>05530000
   m129    = 129,                                              <<*8393>>05535000
   m130    = 130,                                              <<*8393>>05540000
   m131    = 131,                                              <<*8393>>05545000
   m132    = 132,                                              <<*8393>>05550000
   m133    = 133,                                              <<*8393>>05555000
   m134    = 134,                                              <<*8393>>05560000
   m135    = 135,                                              <<*8393>>05565000
   m136    = 136,                                              <<*8393>>05570000
   m137    = 137,                                              <<*8393>>05575000
   m200    = 200,                                              <<*8393>>05580000
   m201    = 201,                                              <<*8393>>05585000
   m202    = 202,                                              <<*8393>>05590000
   m203    = 203,                                              <<*8393>>05595000
   m204    = 204,                                              <<*8393>>05600000
   m205    = 205,                                              <<*8393>>05605000
   m225    = 225,                                              <<*8393>>05610000
   m226    = 226,                                              <<*8393>>05615000
   m227    = 227,                                              <<*8393>>05620000
   m228    = 228,                                              <<*8393>>05625000
   m229    = 229,                                              <<*8393>>05630000
   m230    = 230,                                              <<*8393>>05635000
   m231    = 231,                                              <<*8393>>05640000
   m232    = 232,                                              <<*8393>>05645000
   m233    = 233,                                              <<*8393>>05650000
   m234    = 234,                                              <<*8393>>05655000
   m235    = 235,                                              <<*8393>>05660000
   m236    = 236,                                              <<*8393>>05665000
   m237    = 237,                                              <<*8393>>05670000
   m250    = 250,                                              <<*8393>>05675000
   m251    = 251,                                              <<*8393>>05680000
   m252    = 252,                                              <<*8393>>05685000
   m253    = 253,                                              <<*8393>>05690000
   m254    = 254,                                              <<*8393>>05695000
   m275    = 275,                                              <<*8393>>05700000
   m276    = 276,                                              <<*8393>>05705000
   m277    = 277,                                              <<*8393>>05710000
   m278    = 278,                                              <<*8393>>05715000
   m300    = 300,                                              <<*8393>>05720000
   m301    = 301,                                              <<*8393>>05725000
   m302    = 302,                                              <<*8393>>05730000
   m303    = 303,                                              <<*8393>>05735000
   m304    = 304,                                              <<*8393>>05740000
   m305    = 305,                                              <<*8393>>05745000
   m325    = 325,                                              <<*8393>>05750000
   m326    = 326,                                              <<*8393>>05755000
   m327    = 327,                                              <<*8393>>05760000
   m328    = 328,                                              <<*8393>>05765000
   m329    = 329,                                              <<*8393>>05770000
   m330    = 330,                                              <<*8393>>05775000
   m331    = 331,                                              <<*8393>>05780000
   m332    = 332,                                              <<*8393>>05785000
   m333    = 333,                                              <<*8393>>05790000
   m334    = 334,                                              <<*8393>>05795000
   m335    = 335,                                              <<*8393>>05800000
   m350    = 350,                                              <<*8393>>05805000
   m351    = 351,                                              <<*8393>>05810000
   m352    = 352,                                              <<*8393>>05815000
   m353    = 353,                                              <<*8393>>05820000
   m354    = 354,                                              <<*8393>>05825000
   m374    = 374,                                              <<*8393>>05830000
   m377    = 377,                                              <<*8393>>05835000
   m378    = 378,                                              <<*8393>>05840000
   m379    = 379,                                              <<*8393>>05845000
   m400    = 400,                                              <<*8393>>05850000
   m401    = 401,                                              <<*8393>>05855000
   m450    = 450,                                              <<*8393>>05860000
   m451    = 451,                                              <<*8393>>05865000
   m452    = 452,                                              <<*8393>>05870000
   m453    = 453,                                              <<*8393>>05875000
   m454    = 454,                                              <<*8393>>05880000
   m455    = 455,                                              <<*8393>>05885000
   m456    = 456,                                              <<*8393>>05890000
   m457    = 457,                                              <<*8393>>05895000
   m458    = 458,                                              <<*8393>>05900000
   m459    = 459,                                              <<*8393>>05905000
   m500    = 500,                                              <<*8393>>05910000
   m501    = 501,                                              <<*8393>>05915000
   m2000   = 2000,                                             <<*8393>>05920000
   m2001   = 2001,                                             <<*8393>>05925000
   m2002   = 2002,                                             <<*8393>>05930000
   m2003   = 2003,                                             <<*8393>>05935000
   m2004   = 2004,                                             <<*8393>>05940000
   m2005   = 2005,                                             <<*8393>>05945000
   m2006   = 2006,                                             <<*8393>>05950000
   m2007   = 2007,                                             <<*8393>>05955000
   m2008   = 2008,                                             <<*8393>>05960000
   m2009   = 2009,                                             <<*8393>>05965000
   m2010   = 2010,                                             <<*8393>>05970000
   m2011   = 2011,                                             <<*8393>>05975000
   m2012   = 2012,                                             <<*8393>>05980000
   m2013   = 2013,                                             <<*8393>>05985000
   m2014   = 2014,                                             <<*8393>>05990000
   m2015   = 2015,                                             <<*8393>>05995000
   m2016   = 2016,                                             <<*8393>>06000000
   m2017   = 2017,                                             <<*8393>>06005000
   m2018   = 2018,                                             <<*8393>>06010000
   m2019   = 2019,                                             <<*8393>>06015000
   m2020   = 2020,                                             <<*8393>>06020000
   m2021   = 2021,                                             <<*8393>>06025000
   m2022   = 2022,                                             <<*8393>>06030000
   m2023   = 2023,                                             <<*8393>>06035000
   m2024   = 2024,                                             <<*8393>>06040000
   m2025   = 2025,                                             <<*8393>>06045000
   m2026   = 2026,                                             <<*8393>>06050000
   m2027   = 2027,                                             <<*8393>>06055000
   m2028   = 2028,                                             <<*8393>>06060000
   m2029   = 2029,                                             <<*8393>>06065000
   m2041   = 2041,                                             <<*8393>>06070000
   m2042   = 2042,                                             <<*8393>>06075000
   m2043   = 2043,                                             <<*8393>>06080000
   m2044   = 2044,                                             <<*8393>>06085000
   m2045   = 2045,                                             <<*8393>>06090000
   m2046   = 2046,                                             <<*8393>>06095000
   m2047   = 2047,                                             <<*8393>>06100000
   m2048   = 2048,                                             <<*8393>>06105000
   m2049   = 2049,                                             <<*8393>>06110000
   m2050   = 2050,                                             <<*8393>>06115000
   m2051   = 2051,                                             <<*8393>>06120000
   m2052   = 2052,                                             <<*8393>>06125000
   m2055   = 2055,                                             <<s8966>>06130000
   m2056   = 2056,                                             <<s8966>>06135000
   m2470   = 2470,                                                      06140000
   m2471   = 2471,                                                      06145000
   m2551   = 2551,                                             <<*8393>>06150000
   m2100   = 2100,                                             <<*8393>>06155000
   m2101   = 2101,                                             <<*8393>>06160000
   m2102   = 2102,                                             <<*8393>>06165000
   m2103   = 2103,                                             <<*8393>>06170000
   m2104   = 2104,                                             <<*8393>>06175000
   m2105   = 2105,                                             <<*8393>>06180000
   m2106   = 2106,                                             <<*8393>>06185000
   m2107   = 2107,                                             <<*8393>>06190000
   m2108   = 2108,                                             <<*8393>>06195000
   m2109   = 2109,                                             <<*8393>>06200000
   m2110   = 2110,                                             <<*8393>>06205000
   m2111   = 2111,                                             <<*8393>>06210000
   m2112   = 2112,                                             <<*8393>>06215000
   m2113   = 2113,                                             <<*8393>>06220000
   m2114   = 2114,                                             <<*8393>>06225000
   m2115   = 2115,                                             <<*8393>>06230000
   m2116   = 2116,                                             <<*8393>>06235000
   m2117   = 2117,                                             <<*8393>>06240000
   m2118   = 2118,                                             <<*8393>>06245000
   m2119   = 2119,                                             <<*8393>>06250000
   m2120   = 2120,                                             <<*8393>>06255000
   m2121   = 2121,                                             <<*8393>>06260000
   m2122   = 2122,                                             <<*8393>>06265000
   m2123   = 2123,                                             <<*8393>>06270000
   m2124   = 2124,                                             <<*8393>>06275000
   m2125   = 2125,                                             <<*8393>>06280000
   m2126   = 2126,                                             <<*8393>>06285000
   m2127   = 2127,                                             <<*8393>>06290000
   m2128   = 2128,                                             <<*8393>>06295000
   m2129   = 2129,                                             <<*8393>>06300000
   m2130   = 2130,                                             <<*8393>>06305000
   m2131   = 2131,                                             <<*8393>>06310000
   m2140   = 2140,                                             <<*8393>>06315000
   m2141   = 2141,                                             <<*8393>>06320000
   m2150   = 2150,                                             <<*8393>>06325000
   m2151   = 2151,                                             <<*8393>>06330000
   m2152   = 2152,                                             <<*8393>>06335000
   m2153   = 2153,                                             <<*8393>>06340000
   m2154   = 2154,                                             <<*8393>>06345000
   m2155   = 2155,                                             <<*8393>>06350000
   m2156   = 2156,                                             <<*8393>>06355000
   m2200   = 2200,                                             <<*8393>>06360000
   m2201   = 2201,                                             <<*8393>>06365000
   m2202   = 2202,                                             <<*8393>>06370000
   m2203   = 2203,                                             <<*8393>>06375000
   m2204   = 2204,                                             <<*8393>>06380000
   m2205   = 2205,                                             <<*8393>>06385000
   m2206   = 2206,                                             <<*8393>>06390000
   m2207   = 2207,                                             <<*8393>>06395000
   m2208   = 2208,                                             <<*8393>>06400000
   m2210   = 2210,                                             <<*8393>>06405000
   m2211   = 2211,                                             <<*8393>>06410000
   m2212   = 2212,                                             <<*8393>>06415000
   m2215   = 2215,                                             <<*8393>>06420000
   m2216   = 2216,                                             <<*8393>>06425000
   m2217   = 2217,                                             <<*8393>>06430000
   m2218   = 2218,                                             <<*8393>>06435000
   m2219   = 2219,                                             <<*8393>>06440000
   m2220   = 2220,                                             <<*8393>>06445000
   m2225   = 2225,                                             <<*8393>>06450000
   m2226   = 2226,                                             <<*8393>>06455000
   m2227   = 2227,                                             <<*8393>>06460000
   m2228   = 2228,                                             <<*8393>>06465000
   m2229   = 2229,                                             <<*8393>>06470000
   m2230   = 2230,                                             <<*8393>>06475000
   m2231   = 2231,                                             <<*8393>>06480000
   m2232   = 2232,                                             <<*8393>>06485000
   m2233   = 2233,                                             <<*8393>>06490000
   m2234   = 2234,                                             <<*8393>>06495000
   m2235   = 2235,                                             <<*8393>>06500000
   m2236   = 2236,                                             <<*8393>>06505000
   m2237   = 2237,                                             <<*8393>>06510000
   m2238   = 2238,                                             <<*8393>>06515000
   m2239   = 2239,                                             <<*8393>>06520000
   m2240   = 2240,                                             <<*8393>>06525000
   m2241   = 2241,                                             <<*8393>>06530000
   m2242   = 2242,                                             <<*8393>>06535000
   m2243   = 2243,                                             <<*8393>>06540000
   m2244   = 2244,                                             <<*8393>>06545000
   m2245   = 2245,                                             <<*8393>>06550000
   m2246   = 2246,                                             <<*8393>>06555000
   m2247   = 2247,                                             <<*8393>>06560000
   m2248   = 2248,                                             <<*8393>>06565000
   m2250   = 2250,                                             <<*8393>>06570000
   m2275   = 2275,                                             <<*8393>>06575000
   m2276   = 2276,                                             <<*8393>>06580000
   m2277   = 2277,                                             <<*8393>>06585000
   m2278   = 2278,                                             <<*8393>>06590000
   m2279   = 2279,                                             <<*8393>>06595000
   m2280   = 2280,                                             <<*8393>>06600000
   m2281   = 2281,                                             <<*8393>>06605000
   m2282   = 2282,                                             <<*8393>>06610000
   m2283   = 2283,                                             <<*8393>>06615000
   m2284   = 2284,                                             <<*8393>>06620000
   m2285   = 2285,                                             <<*8393>>06625000
   m2286   = 2286,                                             <<*8393>>06630000
   m2287   = 2287,                                             <<*8393>>06635000
   m2288   = 2288,                                             <<*8393>>06640000
   m2289   = 2289,                                             <<*8393>>06645000
   m2290   = 2290,                                             <<*8393>>06650000
   m2291   = 2291,                                             <<*8393>>06655000
   m2292   = 2292,                                             <<*8393>>06660000
   m2293   = 2293,                                             <<*8393>>06665000
   m2300   = 2300,                                             <<*8393>>06670000
   m2301   = 2301,                                             <<*8393>>06675000
   m2302   = 2302,                                             <<*8393>>06680000
   m2303   = 2303,                                             <<*8393>>06685000
   m2304   = 2304,                                             <<*8393>>06690000
   m2305   = 2305,                                             <<*8393>>06695000
   m2306   = 2306,                                             <<*8393>>06700000
   m2307   = 2307,                                             <<*8393>>06705000
   m2308   = 2308,                                             <<*8393>>06710000
   m2309   = 2309,                                             <<*8393>>06715000
   m2310   = 2310,                                             <<*8393>>06720000
   m2311   = 2311,                                             <<*8393>>06725000
   m2312   = 2312,                                             <<*8393>>06730000
   m2313   = 2313,                                             <<*8393>>06735000
   m2314   = 2314,                                             <<*8393>>06740000
   m2315   = 2315,                                             <<*8393>>06745000
   m2316   = 2316,                                             <<*8393>>06750000
   m2325   = 2325,                                             <<*8393>>06755000
   m2326   = 2326,                                             <<*8393>>06760000
   m2327   = 2327,                                             <<*8393>>06765000
   m2328   = 2328,                                             <<*8393>>06770000
   m2329   = 2329,                                             <<*8393>>06775000
   m2330   = 2330,                                             <<*8393>>06780000
   m2331   = 2331,                                             <<*8393>>06785000
   m2332   = 2332,                                             <<*8393>>06790000
   m2333   = 2333,                                             <<*8393>>06795000
   m2334   = 2334,                                             <<*8393>>06800000
   m2350   = 2350,                                             <<*8393>>06805000
   m2351   = 2351,                                             <<*8393>>06810000
   m2352   = 2352,                                             <<*8393>>06815000
   m2353   = 2353,                                             <<*8393>>06820000
   m2354   = 2354,                                             <<*8393>>06825000
   m2355   = 2355,                                             <<*8393>>06830000
   m2356   = 2356,                                             <<*8393>>06835000
   m2357   = 2357,                                             <<*8393>>06840000
   m2400   = 2400,                                             <<*8393>>06845000
   m2401   = 2401,                                             <<*8393>>06850000
   m2402   = 2402,                                             <<*8393>>06855000
   m2403   = 2403,                                             <<*8393>>06860000
   m2404   = 2404,                                             <<*8393>>06865000
   m2405   = 2405,                                             <<*8393>>06870000
   m2406   = 2406,                                             <<*8393>>06875000
   m2407   = 2407,                                             <<*8393>>06880000
   m2408   = 2408,                                             <<*8393>>06885000
   m2409   = 2409,                                             <<*8393>>06890000
   m2410   = 2410,                                             <<*8393>>06895000
   m2411   = 2411,                                             <<*8393>>06900000
   m2412   = 2412,                                             <<*8393>>06905000
   m2413   = 2413,                                             <<*8393>>06910000
   m2450   = 2450,                                             <<*8393>>06915000
   m2451   = 2451,                                             <<*8393>>06920000
   m2452   = 2452,                                             <<*8393>>06925000
   m2453   = 2453,                                             <<*8393>>06930000
   m2454   = 2454,                                             <<*8393>>06935000
   m2455   = 2455,                                             <<*8393>>06940000
   m2456   = 2456,                                             <<*8393>>06945000
   m2457   = 2457,                                             <<*8393>>06950000
   m2458   = 2458,                                             <<*8393>>06955000
   m2459   = 2459,                                             <<*8393>>06960000
   m2460   = 2460,                                             <<*8393>>06965000
   m2461   = 2461,                                             <<*8393>>06970000
   m2462   = 2462,                                             <<*8393>>06975000
   m2463   = 2463,                                             <<*8393>>06980000
   m2464   = 2464,                                             <<*8393>>06985000
   m2465   = 2465,                                             <<*8393>>06990000
   m2466   = 2466,                                             <<*8393>>06995000
   m2467   = 2467,                                             <<*8393>>07000000
   m2468   = 2468,                                             <<*8393>>07005000
   m2469   = 2469,                                             <<*8393>>07010000
   m2500   = 2500,                                             <<*8393>>07015000
   m2501   = 2501,                                             <<*8393>>07020000
   m2502   = 2502,                                             <<*8393>>07025000
   m2503   = 2503,                                             <<*8393>>07030000
   m2504   = 2504,                                             <<*8393>>07035000
   m2505   = 2505,                                             <<*8393>>07040000
   m2506   = 2506,                                             <<*8393>>07045000
   m2550   = 2550,                                             <<*8393>>07050000
   m2600   = 2600,                                             <<*8393>>07055000
   m2601   = 2601,                                             <<*8393>>07060000
   m2602   = 2602,                                             <<*8393>>07065000
   m2603   = 2603,                                             <<*8393>>07070000
   m2604   = 2604,                                             <<*8393>>07075000
   m2605   = 2605,                                             <<*8393>>07080000
   m2606   = 2606,                                             <<*8393>>07085000
   m2607   = 2607,                                             <<*8393>>07090000
   m2608   = 2608,                                             <<*8393>>07095000
   m2609   = 2609,                                             <<*8393>>07100000
   m2610   = 2610,                                             <<*8393>>07105000
   m2611   = 2611,                                             <<*8393>>07110000
   m2612   = 2612,                                             <<*8393>>07115000
   m2650   = 2650,                                             <<*8393>>07120000
   m2651   = 2651,                                             <<*8393>>07125000
   m2652   = 2652,                                             <<*8393>>07130000
   m2653   = 2653,                                             <<*8393>>07135000
   m2654   = 2654,                                             <<*8393>>07140000
   m2655   = 2655,                                             <<*8393>>07145000
   m2656   = 2656,                                             <<*8393>>07150000
   m2657   = 2657,                                             <<*8393>>07155000
   m2700   = 2700,                                             <<*8393>>07160000
   m2701   = 2701,                                             <<*8393>>07165000
   m2702   = 2702,                                             <<*8393>>07170000
   m2703   = 2703,                                             <<*8393>>07175000
   m2704   = 2704,                                             <<*8393>>07180000
   m2705   = 2705,                                             <<*8393>>07185000
   m2706   = 2706,                                             <<*8393>>07190000
   m2707   = 2707,                                             <<*8393>>07195000
   m2708   = 2708,                                             <<*8393>>07200000
   m2709   = 2709,                                             <<*8393>>07205000
   m2710   = 2710,                                             <<*8393>>07210000
   m2711   = 2711,                                             <<*8393>>07215000
   m2712   = 2712,                                             <<*8393>>07220000
   m2713   = 2713,                                             <<*8393>>07225000
   m2714   = 2714,                                             <<*8393>>07230000
   m2715   = 2715,                                             <<*8393>>07235000
   m2716   = 2716,                                             <<*8393>>07240000
   m2717   = 2717,                                             <<*8393>>07245000
   m2718   = 2718,                                             <<*8393>>07250000
   m2719   = 2719,                                             <<*8393>>07255000
   m2720   = 2720,                                             <<*8393>>07260000
   m2750   = 2750,                                             <<*8393>>07265000
   m2751   = 2751,                                             <<*8393>>07270000
   m2752   = 2752,                                             <<*8393>>07275000
   m2753   = 2753,                                             <<*8393>>07280000
   m2754   = 2754,                                             <<*8393>>07285000
   m2755   = 2755,                                             <<*8393>>07290000
   m2756   = 2756,                                             <<*8393>>07295000
   m2757   = 2757,                                             <<*8393>>07300000
   m2758   = 2758,                                             <<*8393>>07305000
   m2801   = 2801,                                             <<*8393>>07310000
   m2802   = 2802,                                             <<*8393>>07315000
   m2803   = 2803,                                             <<*8393>>07320000
   m2804   = 2804,                                             <<*8393>>07325000
   m3000   = 3000,                                             <<*8393>>07330000
   m3001   = 3001,                                             <<*8393>>07335000
   m3002   = 3002,                                             <<*8393>>07340000
   m3003   = 3003,                                             <<*8393>>07345000
   m3004   = 3004,                                             <<*8393>>07350000
   m3005   = 3005,                                             <<*8393>>07355000
   m3006   = 3006,                                             <<*8393>>07360000
   m3007   = 3007,                                             <<*8393>>07365000
   m3008   = 3008,                                             <<*8393>>07370000
   m3009   = 3009,                                             <<*8393>>07375000
   m3010   = 3010,                                             <<*8393>>07380000
   m3011   = 3011,                                             <<*8393>>07385000
   m3012   = 3012,                                             <<*8393>>07390000
   m3013   = 3013,                                             <<*8393>>07395000
   m3014   = 3014,                                             <<*8393>>07400000
   m3015   = 3015,                                             <<*8393>>07405000
   m3016   = 3016,                                             <<*8393>>07410000
   m3017   = 3017;                                             <<*8393>>07415000
$page "INTRINSICS"                                             <<04659>>07420000
intrinsic          <<in alphabetic order, one per line!!!!!>>  <<04659>>07425000
   activate,                                                   <<04659>>07430000
   altdseg,                                                    <<06814>>07435000
   calendar,                                                   <<*8393>>07440000
   clock,                                                      <<*8393>>07445000
   create,                                                     <<*8393>>07450000
   createprocess,                                              <<04659>>07455000
   ffileinfo,                                                  <<04659>>07460000
   findjcw,                                                    <<m9096>>07465000
   freedseg,                                                   <<06762>>07470000
   getdseg,                                                    <<06762>>07475000
   getjcw,                                                     <<*8393>>07480000
   receivemail,                                                <<*8393>>07485000
   setjcw;                                                     <<*8393>>07490000
  double procedure logicalcst(cstn);                                    07495000
    value cstn;                                                         07500000
    integer cstn;                                                       07505000
    option external;                                                    07510000
$page "EXTERNAL PROCEDURE DECLARATIONS"                                 07515000
                                                                        07520000
  procedure debug;                                                      07525000
    option external;                                                    07530000
                                                                        07535000
  procedure systemdebug;                                                07540000
    option external;                                                    07545000
                                                                        07550000
  logical procedure binary(string,length);                              07555000
    value length;                                                       07560000
    byte array string;                                                  07565000
    integer length;                                                     07570000
    option external;                                                    07575000
                                                                        07580000
   double procedure dbinary(string,length);                             07585000
         value length;                                                  07590000
         byte array string;                                             07595000
         integer length;                                                07600000
         option external;                                               07605000
                                                                        07610000
   integer procedure dascii(dword,base,string);                         07615000
         value dword,base;                                              07620000
         double dword;                                                  07625000
         integer base;                                                  07630000
         byte array string;                                             07635000
         option external;                                               07640000
                                                                        07645000
  double procedure attachio(ldev,qmisc,dstx,buf,func,count,p1,p2,flags);07650000
    value ldev,qmisc,dstx,buf,func,count,p1,p2,flags;                   07655000
    integer ldev,qmisc,dstx,buf,func,count,p1,p2,flags;                 07660000
    option external;                                                    07665000
                                                                        07670000
double procedure p'attachio(ld,q,dst,buf,fc,cnt,p1,p2,f,eb,es);<<07443>>07675000
value ld,q,dst,buf,fc,cnt,p1,p2,f,eb,es;                       <<07443>>07680000
integer ld,q,dst,buf,fc,cnt,p1,p2,f,es;                        <<07443>>07685000
double eb;                                                     <<07443>>07690000
option external,variable;                                      <<07443>>07695000
                                                               <<07443>>07700000
  integer procedure read(message,length);                               07705000
    value length;                                                       07710000
    array message;                                                      07715000
    integer length;                                                     07720000
    option external;                                                    07725000
                                                                        07730000
  procedure print(message,length,control);                              07735000
    value length,control;                                               07740000
    array message;                                                      07745000
    integer length;                                                     07750000
    logical control;                                                    07755000
    option external;                                                    07760000
                                                                        07765000
  integer procedure fopen(filedesignator,foptions,aoptions,recsize,     07770000
          device,formmsg,userlabels,blockfactor,numbuffers,filesize,    07775000
          numextents,initalloc,filecode);                               07780000
    value foptions,aoptions,recsize,userlabels,blockfactor,numbuffers,  07785000
          filesize,numextents,initalloc,filecode;                       07790000
    byte array filedesignator,device,formmsg;                           07795000
    logical foptions,aoptions;                                          07800000
    integer recsize,userlabels,blockfactor,numbuffers,initalloc,        07805000
          numextents,filecode;                                          07810000
    double filesize;                                                    07815000
    option variable,external;                                           07820000
                                                                        07825000
  integer procedure fread(filenum,target,tcount);                       07830000
    value filenum,tcount;                                               07835000
    integer filenum,tcount;                                             07840000
    array target;                                                       07845000
    option external;                                                    07850000
                                                                        07855000
  procedure fwrite(filenum,target,tcount,control);                      07860000
    value filenum,tcount,control;                                       07865000
    integer filenum,tcount;                                             07870000
    array target;                                                       07875000
    logical control;                                                    07880000
    option external;                                                    07885000
                                                                        07890000
  procedure fpoint(filenum,recnum);                                     07895000
    value filenum,recnum;                                               07900000
    integer filenum;                                                    07905000
    double recnum;                                                      07910000
    option external;                                                    07915000
                                                                        07920000
  procedure freaddir(filenum,target,tcount,recnum);                     07925000
    value filenum,tcount,recnum;                                        07930000
    integer filenum,tcount;                                             07935000
    array target;                                                       07940000
    double recnum;                                                      07945000
    option external;                                                    07950000
                                                                        07955000
  procedure fwritedir(filenum,target,tcount,recnum);                    07960000
    value filenum,tcount,recnum;                                        07965000
    integer filenum,tcount;                                             07970000
    array target;                                                       07975000
    double recnum;                                                      07980000
    option external;                                                    07985000
                                                                        07990000
  procedure fclose(filenum,disposition,seccode);                        07995000
    value filenum,disposition,seccode;                                  08000000
    integer filenum,disposition,seccode;                                08005000
    option external;                                                    08010000
                                                                        08015000
  procedure flock(filenum,t);                                           08020000
    value filenum,t;                                                    08025000
    integer filenum;                                                    08030000
    logical t;                                                          08035000
    option external;                                                    08040000
                                                                        08045000
procedure funlock(fn);                                         <<00598>>08050000
  value fn;                                                    <<00598>>08055000
  integer fn;                                                  <<00598>>08060000
  option external;                                             <<00598>>08065000
                                                               <<00598>>08070000
  procedure fcheck(filenum,errorcode,tlog,blknum,numrecs);              08075000
    value filenum;                                                      08080000
    integer filenum,errorcode,tlog,numrecs;                             08085000
    double blknum;                                                      08090000
    option variable,external;                                           08095000
                                                                        08100000
    procedure fgetinfo(filenum,filename,foptions,aoptions,recsize,      08105000
          devtype,ldnum,hdaddr,filecode,recptr,eof,flimit,logcount,     08110000
          physcount,blksize,extsize,numextents,userlabels,              08115000
          creatorid,diskadr);                                           08120000
    value filenum;                                                      08125000
    integer filenum,recsize,devtype,filecode,blksize,numextents,        08130000
          userlabels;                                                   08135000
    byte array filename,creatorid;                                      08140000
    logical foptions,aoptions,ldnum,hdaddr,extsize;                     08145000
    double recptr,eof,flimit,logcount,physcount,diskadr;                08150000
    option variable,external;                                           08155000
                                                                        08160000
  procedure fcontrol(filenum,controlcode,param);                        08165000
    value filenum,controlcode;                                          08170000
    integer filenum,controlcode;                                        08175000
    logical param;                                                      08180000
    option external;                                                    08185000
                                                                        08190000
  intrinsic ferrmsg;                                           <<01109>>08195000
                                                               <<01109>>08200000
  procedure disablebreak(ldev);                                         08205000
    value ldev;                                                         08210000
    integer ldev;                                                       08215000
    option external;                                                    08220000
                                                                        08225000
  procedure enablebreak(ldev);                                          08230000
    value ldev;                                                         08235000
    integer ldev;                                                       08240000
    option external;                                                    08245000
                                                                        08250000
  procedure who(mode,capability,lattr,usern,groupn,acctn,homen,termnum);08255000
    logical mode;                                                       08260000
    double capability,lattr;                                            08265000
    byte array usern,groupn,acctn,homen;                                08270000
    logical termnum;                                                    08275000
    option variable,external;                                           08280000
                                                                        08285000
  procedure command(comimage,error,parm);                               08290000
    byte array comimage;                                                08295000
    integer error,parm;                                                 08300000
    option external;                                                    08305000
                                                                        08310000
  logical procedure exchangedb(dstn);                                   08315000
    value dstn;                                                         08320000
    logical dstn;                                                       08325000
    option external;                                                    08330000
                                                                        08335000
  integer procedure setsysdb;                                           08340000
    option external;                                                    08345000
                                                                        08350000
  procedure resetdb(olddb);                                             08355000
    value olddb;                                                        08360000
    integer olddb;                                                      08365000
    option external;                                                    08370000
                                                                        08375000
  integer procedure zsize(size);                                        08380000
    value size;                                                         08385000
    integer size;                                                       08390000
    option external;                                                    08395000
                                                                        08400000
  integer procedure dlsize(size);                                       08405000
    value size;                                                         08410000
    integer size;                                                       08415000
    option external;                                                    08420000
                                                                        08425000
  logical procedure dmove(dstn,disp,number,loc,intostack,num);          08430000
    value dstn,disp,number,loc,intostack,num;                           08435000
    logical dstn,intostack;                                             08440000
    integer disp,number,loc,num;                                        08445000
    option external;                                                    08450000
                                                                        08455000
  integer procedure getsir(sirnum);                                     08460000
    value sirnum;                                                       08465000
    integer sirnum;                                                     08470000
    option external;                                                    08475000
                                                                        08480000
  procedure relsir(sirnum,getsir);                                      08485000
    value sirnum,getsir;                                                08490000
    integer sirnum,getsir;                                              08495000
    option external;                                                    08500000
                                                                        08505000
  procedure segmenter(pin,command,error,num1,num2,num3,num4,num5,       08510000
          num6,string1,string2,fname1,fname2);                 <<00629>>08515000
    value command,num1,num2,num3,num4,num5,num6;               <<00629>>08520000
    integer pin,command,error,num1,num2,num3,num4,num5,num6;   <<00629>>08525000
    byte array string1,string2,fname1,fname2;                           08530000
    option variable,external;                                           08535000
                                                                        08540000
  procedure quit(num);                                                  08545000
    value num;                                                          08550000
    integer num;                                                        08555000
    option external;                                                    08560000
                                                                        08565000
  double procedure istore(ptr,enum,gnum,pdate,retval,fcllim,fculim,     08570000
          flag);                                                        08575000
    value enum,gnum,pdate,fcllim,fculim,flag;                           08580000
    integer enum,gnum,fcllim,fculim;                                    08585000
    integer array retval;                                               08590000
    byte array ptr;                                                     08595000
    logical pdate,flag;                                                 08600000
    option external;                                                    08605000
                                                                        08610000
  double procedure fstore(tnum,gnum);                                   08615000
    value tnum,gnum;                                                    08620000
    integer tnum,gnum;                                                  08625000
    option external;                                                    08630000
                                                                        08635000
procedure store'user'files (systape, show, syntax'only,        <<04659>>08640000
                            error'code, error'subclass);       <<04659>>08645000
         value   show, systape, syntax'only;                   <<04659>>08650000
         logical show, syntax'only;                            <<04659>>08655000
         integer error'code, error'subclass, systape;          <<04659>>08660000
         option forward;                                       <<04659>>08665000
                                                               <<04659>>08670000
   logical procedure setcritical;                                       08675000
     option external;                                                   08680000
                                                                        08685000
   procedure resetcritical(c);                                          08690000
     value c;logical c;                                                 08695000
     option external;                                                   08700000
                                                                        08705000
   procedure setservice(a);                                             08710000
     value a;logical a;                                                 08715000
      option external;                                                  08720000
                                                                        08725000
  double procedure printdfile(pnum,dnum,count,gore,chr,show);           08730000
    value pnum,dnum,count,gore,show;                                    08735000
    integer pnum,dnum,count;                                            08740000
    logical gore,show;                                                  08745000
    byte array chr;                                                     08750000
    option external;                                                    08755000
                                                               <<00134>>08760000
integer procedure genmsg(setno,msgno,mask,parm1,parm2,         <<00134>>08765000
parm3,parm4,parm5,dest,reply,offset,dst,iotype);               <<00134>>08770000
value setno,msgno,mask,parm1,parm2,parm3,parm4,parm5,          <<00134>>08775000
dest,reply,offset,dst,iotype;                                  <<00134>>08780000
integer setno,msgno,dest,dst;                                  <<00134>>08785000
logical mask,parm1,parm2,parm3,parm4,parm5,reply,offset,       <<00134>>08790000
iotype;                                                        <<00134>>08795000
option variable external;                                      <<00134>>08800000
                                                                        08805000
  procedure movedltables;                                               08810000
    option forward;                                                     08815000
                                                               <<00072>>08820000
  double procedure l'padr(discaddress);                        <<00072>>08825000
  value discaddress;                                           <<00072>>08830000
  double discaddress;                                          <<00072>>08835000
  option forward;                                              <<00072>>08840000
                                                                        08845000
  procedure mycommand(commimage,delimiters,maxparms,                    08850000
                 numparms,parms,dict,defn);                             08855000
       value maxparms;                                                  08860000
       byte array commimage,delimiters,dict;                            08865000
       integer maxparms,numparms;                                       08870000
       double array parms;                                              08875000
       byte pointer defn;                                               08880000
       option variable,external;                                        08885000
                                                                        08890000
  procedure vtabtoldev (target,source,count,mvtabx);           <<rv.pv>>08895000
    value count,mvtabx;                                        <<rv.pv>>08900000
    double array target,source;                                         08905000
    integer count,mvtabx;                                      <<rv.pv>>08910000
    option external;                                                    08915000
  integer procedure findsdiscgap(ldev,controlcode,s1,s2);               08920000
  value ldev,controlcode;                                               08925000
  integer ldev,controlcode;                                             08930000
  double s1,s2;                                                         08935000
  option variable,external;                                             08940000
                                                                        08945000
  integer procedure thiscpu;                                   <<tp.00>>08950000
    option external;                                           <<tp.00>>08955000
                                                               <<00072>>08960000
                                                               <<tp.00>>08965000
  logical procedure dirallocate (ppsize);                      <<00173>>08970000
      value ppsize;  integer ppsize;                           <<00173>>08975000
      option external;                                         <<00173>>08980000
                                                               <<00173>>08985000
  procedure dirdeallocate (pntr,ppsize);                       <<00173>>08990000
      value pntr,ppsize;                                       <<00173>>08995000
      logical pntr;                                            <<00173>>09000000
      integer ppsize;                                          <<00173>>09005000
      option external;                                         <<00173>>09010000
                                                               <<00173>>09015000
  procedure dirxxxbitmap (function);                           <<00173>>09020000
      value function;  integer function;                       <<00173>>09025000
      option external;                                         <<00173>>09030000
  double procedure direcscan (type, linkage'indexp, aname,     <<de>>   09035000
      guname, fname, recip, parms, mvtabx);                    <<de>>   09040000
      value   type, linkage'indexp, mvtabx;                    <<de>>   09045000
      integer type, mvtabx;                                    <<de>>   09050000
      double  linkage'indexp;                                  <<de>>   09055000
      integer procedure recip;                                 <<de>>   09060000
      array   aname, guname, fname, parms;                     <<de>>   09065000
      option  external, variable;                              <<de>>   09070000
                                                               <<de>>   09075000
  integer procedure getdataseg (msize, vmsize);                <<de>>   09080000
      value   msize, vmsize;                                   <<de>>   09085000
      integer msize, vmsize;                                   <<de>>   09090000
      option  external;                                        <<de>>   09095000
                                                               <<de>>   09100000
  integer procedure reldataseg (en);                           <<de>>   09105000
      value   en;                                              <<de>>   09110000
      integer en;                                              <<de>>   09115000
      option  external;                                        <<de>>   09120000
                                                               <<01591>>09125000
procedure date'line(string);                                   <<01591>>09130000
byte array string;                                             <<01591>>09135000
option external;                                               <<01591>>09140000
  procedure ioerrcheck(b,a);                                   <<02509>>09145000
     value b,a;                                                <<02509>>09150000
     integer b,a;                                              <<02509>>09155000
     option forward;                                           <<02509>>09160000
  procedure writetape(buf,len,contig);                         <<02509>>09165000
     value len,contig;                                         <<02509>>09170000
     integer array buf;                                        <<02509>>09175000
     integer len;                                              <<03604>>09180000
     logical contig;                                           <<03604>>09185000
     option forward;                                           <<02509>>09190000
  procedure io'config'ch;                                      <<03006>>09195000
      option forward;                                          <<03006>>09200000
  integer procedure process'cold'load'info(func,word,p1,p2,p3);<<*8393>>09205000
    value func,word;                                           <<*8393>>09210000
    integer func,word;                                         <<*8393>>09215000
    logical p1,p2,p3;                                          <<*8393>>09220000
    option external,variable;                                  <<*8393>>09225000
                                                               <<s7849>>09230000
integer procedure xretpmask(n1,n2,n3,pmaskhi,pmasklo);         <<s7849>>09235000
   logical pmaskhi,pmasklo;                                    <<s7849>>09240000
   byte array n1,n2,n3;                                        <<s7849>>09245000
   option external;                                            <<s7849>>09250000
                                                               <<s7849>>09255000
$page "MESSAGE ROUTINE"                                                 09260000
$control segment=sysdump                                       <<01073>>09265000
integer procedure wordaddress( byteaddress );                  <<03704>>09270000
   value byteaddress;                                          <<03704>>09275000
   byte pointer byteaddress;                                   <<03704>>09280000
begin                                                          <<03704>>09285000
   tos := wordaddress := @byteaddress &lsr(1);                 <<03704>>09290000
   push( z );                                                  <<03704>>09295000
   << if word address > z force to dl area >>                  <<03704>>09300000
   if tos > tos then wordaddress.(0:1) := 1;                   <<03704>>09305000
end;                                                           <<03704>>09310000
$control segment=sysdump                                       <<03702>>09315000
        <<---------------------------------------->>           <<03702>>09320000
        <<  convert word address to byte address  >>           <<03702>>09325000
        <<---------------------------------------->>           <<03702>>09330000
integer procedure byteaddress(wordaddress);                    <<03702>>09335000
value wordaddress;                                             <<03702>>09340000
pointer                                                        <<03702>>09345000
   wordaddress;    << pointer to be converted >>               <<03702>>09350000
comment                                                        <<03702>>09355000
this procedure returns the given word address converted to     <<03702>>09360000
a byte address.  it works no matter where the address is       <<03702>>09365000
located -- in db+ or db- area.                                 <<03702>>09370000
;                                                              <<03702>>09375000
begin                                                          <<03702>>09380000
byteaddress := @wordaddress&lsl(1);                            <<03702>>09385000
end;   << byteaddress >>                                       <<03702>>09390000
procedure mfds( buf, dstn, offset, count);                     <<06453>>09395000
   value dstn, offset, count;                                  <<06453>>09400000
   array buf;                                                  <<06453>>09405000
   integer dstn, offset, count;                                <<06453>>09410000
begin                                                          <<06453>>09415000
   tos := @buf;                                                <<06453>>09420000
   tos := dstn;                                                <<06453>>09425000
   tos := offset;                                              <<06453>>09430000
   tos := count;                                               <<06453>>09435000
   assemble( mfds );                                           <<06453>>09440000
end;                                                           <<06453>>09445000
procedure mtds( dstn, offset, buf, count);                     <<06453>>09450000
   value dstn, offset, count;                                  <<06453>>09455000
   array buf;                                                  <<06453>>09460000
   integer dstn, offset, count;                                <<06453>>09465000
begin                                                          <<06453>>09470000
   tos := dstn;                                                <<06453>>09475000
   tos := offset;                                              <<06453>>09480000
   tos := @buf;                                                <<06453>>09485000
   tos := count;                                               <<06453>>09490000
   assemble( mtds );                                           <<06453>>09495000
end;                                                           <<06453>>09500000
procedure mds( targetdstn,toffset,sourcedstn,soffset,count);   <<06453>>09505000
   value targetdstn, toffset, sourcedstn, soffset, count;      <<06453>>09510000
   integer targetdstn, toffset, sourcedstn, soffset, count;    <<06453>>09515000
begin                                                          <<06453>>09520000
   tos := targetdstn;                                          <<06453>>09525000
   tos := toffset;                                             <<06453>>09530000
   tos := sourcedstn;                                          <<06453>>09535000
   tos := soffset;                                             <<06453>>09540000
   tos := count;                                               <<06453>>09545000
   assemble( mds );                                            <<06453>>09550000
end;                                                           <<06453>>09555000
          <<------------------                                          09560000
            output a message                                            09565000
          ------------------>>                                          09570000
$include inclmsg                                               <<*8393>>09575000
$page "ERROR ROUTINES"                                                  09580000
procedure message( msgnr,num1,num2,num3,num4,string1,string2); <<*8393>>09585000
   value msgnr, num1, num2, num3, num4;                        <<*8393>>09590000
   integer msgnr;                                              <<*8393>>09595000
   logical num1, num2, num3, num4;                             <<*8393>>09600000
   byte array string1, string2;                                <<*8393>>09605000
   option variable;                                            <<*8393>>09610000
begin                                                          <<*8393>>09615000
   array buf(0:65)=q; << direct array - db setting unknown >>  <<*8393>>09620000
   byte array bbuf(*) = buf;                                   <<*8393>>09625000
                                                               <<*8393>>09630000
   tos := exchangedb(0);                                       <<*8393>>09635000
   db'index := tos;                                            <<*8393>>09640000
   x := genmessage( \msgnr\,bbuf,double(num1),double(num2),    <<*8393>>09645000
                   double(num3),double(num4),string1,string2); <<*8393>>09650000
   if <> then << cca generated by stax >>                      <<*8393>>09655000
      begin   << the message exists >>                         <<*8393>>09660000
      if msgnr < 0 then                                        <<*8393>>09665000
         begin  << it's a question >>                          <<*8393>>09670000
         bbuf(x) := "?";                                       <<*8393>>09675000
         bbuf(x:=x+1) := " ";                                  <<*8393>>09680000
         print( buf, -x-1, %320);                              <<*8393>>09685000
         end                                                   <<*8393>>09690000
      else                                                     <<*8393>>09695000
         print( buf, -x, 0);                                   <<*8393>>09700000
      end;                                                     <<*8393>>09705000
   exchangedb(db'index);                                       <<*8393>>09710000
end;  << message >>                                            <<*8393>>09715000
$control segment=sysdump                                       <<01073>>09720000
                                                                        09725000
          <<----------------------------------                          09730000
            purge temporary sl file and quit                            09735000
          ---------------------------------->>                          09740000
  procedure purgetempsl;                                                09745000
    option privileged,uncallable;                                       09750000
      begin                                                             09755000
          if tempslsaved then                                           09760000
            begin  <<must purge>>                                       09765000
              if not tempslopen then                                    09770000
                tslfnum := fopen(tslfile,%(2)10);                       09775000
              fclose(tslfnum,4,0);   <<release>>                        09780000
            end;                                                        09785000
          if sirs then                                         <<01890>>09790000
            begin   <<release sirs>>                           <<01890>>09795000
              relsir(dirsir,dsir);                             <<01890>>09800000
              relsir(flabsir,fsir);                            <<01890>>09805000
              relsir(fmavtsir,fmsir);                          <<01890>>09810000
            end;                                               <<01890>>09815000
          resetcritical(0);  <<in case in critical mode>>               09820000
          quit(0);                                                      09825000
      end <<purgetempsl>> ;                                             09830000
$control segment=sysdump                                       <<06762>>09835000
comment                                                        <<06762>>09840000
      <<------------------------------------------             <<06762>>09845000
        get table entries for a logical device                 <<06762>>09850000
      ------------------------------------------>>             <<06762>>09855000
;                                                              <<06762>>09860000
procedure get'ldev'entries(ldev);                              <<06762>>09865000
value ldev;                                                    <<06762>>09870000
integer ldev;                                                  <<06762>>09875000
comment                                                        <<06762>>09880000
   this procedure will return the entries for the ldt,lpdt,    <<06762>>09885000
   ldtx, and dvrtab from thier dsegs to their arrays in the    <<06762>>09890000
   stack;                                                      <<06762>>09895000
                                                               <<06762>>09900000
begin                                                          <<06762>>09905000
mfds( ldt, ldt'dst'index, (ldev * ldtsize), ldtsize);          <<06762>>09910000
mfds( lpdt, lpdt'dst'index, (ldev * lpdtsize), lpdtsize);      <<06762>>09915000
mfds( ldtx, ldtx'dst'index, (ldev * ldtxsize), ldtxsize);      <<06762>>09920000
mfds( dvrtab, dvrtab'dst'index, (ldev*dvrsize), dvrsize);      <<06762>>09925000
end;                                                           <<06762>>09930000
                                                               <<06762>>09935000
$control segment=sysdump                                       <<06762>>09940000
comment                                                        <<06762>>09945000
      <<------------------------------------------             <<06762>>09950000
        put table entries for a logical device                 <<06762>>09955000
      ------------------------------------------>>             <<06762>>09960000
;                                                              <<06762>>09965000
procedure put'ldev'entries(ldev);                              <<06762>>09970000
value ldev;                                                    <<06762>>09975000
integer ldev;                                                  <<06762>>09980000
comment                                                        <<06762>>09985000
   this procedure will return the entries for the ldt, lpdt,   <<06762>>09990000
   ldtx, and dvrtab from their arrays in the stack to their    <<06762>>09995000
   respective data segments;                                   <<06762>>10000000
                                                               <<06762>>10005000
begin                                                          <<06762>>10010000
mtds( ldt'dst'index, (ldev*ldtsize), ldt, ldtsize);            <<06762>>10015000
mtds( lpdt'dst'index, (ldev*lpdtsize), lpdt, lpdtsize);        <<06762>>10020000
mtds( ldtx'dst'index, (ldev*ldtxsize), ldtx, ldtxsize);        <<06762>>10025000
mtds( dvrtab'dst'index, (ldev*dvrsize),dvrtab, dvrsize);       <<06762>>10030000
end;                                                           <<06762>>10035000
                                                               <<06762>>10040000
$control segment=sysdump                                       <<03544>>10045000
       <<---------------------------------->>                  <<03544>>10050000
       <<      see if ldev exists          >>                  <<03544>>10055000
       <<---------------------------------->>                  <<03544>>10060000
logical procedure ldev'exists( ldev);                          <<03544>>10065000
value ldev;                                                    <<03544>>10070000
integer ldev;   << ldev to be checked >>                       <<03544>>10075000
comment                                                        <<03544>>10080000
this procedure returns true if the given ldev is               <<03544>>10085000
actually configured, false otherwise.                          <<03544>>10090000
;                                                              <<03544>>10095000
begin                                                          <<03544>>10100000
if 0 <= ldev <= 999   then   get'ldev'entries(ldev);           << 9097>>10105000
if 1 <= ldev <= hldev and                                      <<03544>>10110000
   (dvrdrtnum <> 0 or                                          <<06762>>10115000
    dvrdsbit=1) then                                           <<06762>>10120000
   ldev'exists := true                                         <<03544>>10125000
else                                                           <<03544>>10130000
   ldev'exists := false;                                       <<03544>>10135000
end;  << ldev'exists >>                                        <<03544>>10140000
$control segment=sysdump                                       <<03544>>10145000
      <<----------------------------------------->>            <<03544>>10150000
      << see if ldev exists and is not ds device >>            <<03544>>10155000
      <<----------------------------------------->>            <<03544>>10160000
logical procedure non'ds'ldev(ldev);                           <<03544>>10165000
value ldev;                                                    <<03544>>10170000
integer ldev;   << ldev to be checked >>                       <<03544>>10175000
comment                                                        <<03544>>10180000
this procedure returns true if the given ldev is actually      <<03544>>10185000
configured and is not a ds device.  it returns false           <<03544>>10190000
otherwise.                                                     <<03544>>10195000
;                                                              <<03544>>10200000
begin                                                          <<03544>>10205000
get'ldev'entries(ldev);                                        <<06762>>10210000
if 1 <= ldev <= hldev and                                      <<03544>>10215000
   dvrdsbit = 0 and                                            <<06762>>10220000
   dvrdrtnum <> 0 then                                         <<06762>>10225000
   non'ds'ldev := true                                         <<03544>>10230000
else                                                           <<03544>>10235000
   non'ds'ldev := false;                                       <<03544>>10240000
end;  << non'ds'ldev >>                                        <<03544>>10245000
$control segment=dumptape                                      <<01073>>10250000
          <<-------------------------                                   10255000
            fully qualify file name                                     10260000
          ------------------------->>                                   10265000
  procedure addpubsys(name);                                            10270000
    byte array name;                                                    10275000
    option privileged,uncallable;                                       10280000
      begin                                                             10285000
          move fullname := name while an,1;                             10290000
          move * := ".PUB.SYS ";                                        10295000
      end <<addpubsys>> ;                                               10300000
procedure add'to'sysprog'chg'table(progname,newname);          <<04253>>10305000
                                                               <<04253>>10310000
value progname,newname;                                        <<04253>>10315000
byte pointer progname,newname;                                 <<04253>>10320000
                                                               <<04253>>10325000
begin                                                          <<04253>>10330000
                                                               <<04253>>10335000
integer i;                                                     <<04253>>10340000
                                                               <<04253>>10345000
i:= 0;                                                         <<04253>>10350000
                                                               <<04253>>10355000
while i<sysprog'chg'table'limit do                             <<04253>>10360000
  begin                                                        <<04253>>10365000
  if bspc(i)=0 then                                            <<04253>>10370000
    begin                                                      <<04253>>10375000
    move bspc(i):= progname,(8);                               <<04253>>10380000
    move bspc(i+8):= newname,(26);                             <<04253>>10385000
    return;                                                    <<04253>>10390000
    end;                                                       <<04253>>10395000
  i:= i+34;                                                    <<04253>>10400000
  end;                                                         <<04253>>10405000
end;                                                           <<04253>>10410000
logical procedure search'sysfile(filename);                    <<04253>>10415000
   byte array filename;                                        <<04253>>10420000
begin                                                          <<04253>>10425000
   <<  search if a system program change has been made  >>     <<04253>>10430000
   <<  for "FILENAME".  if a change has been made,      >>     <<04253>>10435000
   <<  the new name will be returned in "FULLNAME"      >>     <<04253>>10440000
   <<  otherwise "FILENAME" will be fully qualified     >>     <<04253>>10445000
   <<  and returned in "FULLNAME".                      >>     <<04253>>10450000
   x := 0;                                                     <<04253>>10455000
   while x < sysprog'chg'table'limit do                        <<04253>>10460000
      begin  << search for new system file >>                  <<04253>>10465000
      if bspc(x) = filename,(8) then                           <<04253>>10470000
         begin << must use different system file >>            <<04253>>10475000
         move fullname:= bspc(x+8),(26);                       <<04253>>10480000
         search'sysfile := true;                               <<04253>>10485000
         return;                                               <<04253>>10490000
         end;                                                  <<04253>>10495000
      x:=x+34;                                                 <<04253>>10500000
      end;                                                     <<04253>>10505000
   << a system program change does not exist for this file >>  <<04253>>10510000
   addpubsys( filename);                                       <<04253>>10515000
end;                                                           <<04253>>10520000
$control segment=sysdump                                       <<02509>>10525000
          <<-------------------                                         10530000
            handle file error                                           10535000
          ------------------->>                                         10540000
  procedure ferror(fnum,fname);                                         10545000
    value fnum;                                                         10550000
    integer fnum;       <<file number>>                                 10555000
    byte array fname;   <<file name>>                                   10560000
    option privileged,uncallable;                                       10565000
    comment                                                             10570000
      outputs a message following a file error;                         10575000
      begin                                                             10580000
        byte array eofmess(0:2)=pb := "EOF";                            10585000
        byte array inuse(0:23)=pb:="FILE IN USE - CAN'T DUMP";          10590000
        integer errorcode, len;                                <<01109>>10595000
          if fnum=1024 then                                             10600000
            begin                                                       10605000
              move binbuf := inuse,(24),2;                              10610000
              goto movename;                                            10615000
            end;                                                        10620000
          if fnum<0 then                                                10625000
            begin   <<i/o error>>                                       10630000
              move binbuf := "ATTACHIO ERROR - ";              <<01209>>10635000
              print(inbuf, -17, %320);                         <<01209>>10640000
              if 0<=(-fnum).(10:3) and (-fnum).(10:3)<7 then   <<01209>>10645000
                case (-fnum).(10:3) of                         <<01209>>10650000
                  begin                                        <<01209>>10655000
                    message(m453);  << invalid function >>     <<*8393>>10660000
                    message(m454);  << transmission error >>   <<*8393>>10665000
                    message(m455); << undefined error number >><<*8393>>10670000
                    message(m454); << transmission error >>    <<*8393>>10675000
                    message(m456);  << sio not ready >>        <<*8393>>10680000
                    message(m457);  << unit failure >>         <<*8393>>10685000
                    message(m458);  << invalid disc address >> <<*8393>>10690000
                  end                                          <<01209>>10695000
              else                                             <<01209>>10700000
                message(m455); << undefined error number >>    <<*8393>>10705000
              move binbuf := " - FILE:",2;                     <<01209>>10710000
              goto movename;                                            10715000
            end;                                                        10720000
          fcheck(fnum,errorcode);                                       10725000
          ferrmsg(errorcode, inbuf, len);                      <<01109>>10730000
          print(inbuf, -len, %40);                             <<01109>>10735000
          move binbuf := "FILENAME -",2;                       <<01109>>10740000
  movename:                                                             10745000
          bps0 := " ";                                                  10750000
          tos := @inbuf;      <<for print>>                             10755000
          assemble(incb,xch);                                           10760000
          tos := @fname;                                                10765000
  next:   move * := * while an,0;                                       10770000
          if bps0 = "." then                                            10775000
            begin                                                       10780000
              move * := *,(1),1;                                        10785000
              goto next;                                                10790000
            end;                                                        10795000
          assemble(del,neg);                                            10800000
          tos := tos+@binbuf;   <<char count>>                          10805000
          print(*,*,0);                                                 10810000
          purgetempsl;                                                  10815000
      end <<ferror>> ;                                                  10820000
$page "TERMINAL INPUT PROCEDURES"                                       10825000
$control segment=sysdump                                       <<01073>>10830000
           <<---------------------->>                          <<03544>>10835000
           <<   zero a buffer      >>                          <<03544>>10840000
           <<---------------------->>                          <<03544>>10845000
procedure zerobuf( buf, len);                                  <<03544>>10850000
value len;                                                     <<03544>>10855000
array buf;     << buffer to be zeroed >>                       <<03544>>10860000
integer len;   << length to zero      >>                       <<03544>>10865000
comment                                                        <<03544>>10870000
zeroes a logical array for the specified length                <<03544>>10875000
(in words).                                                    <<03544>>10880000
;                                                              <<03544>>10885000
begin                                                          <<03544>>10890000
if len > 0 then         << if length <= 0 don't   >>           <<03544>>10895000
   begin                <<     do anything        >>           <<03544>>10900000
   buf := 0;            << otherwise, zero it out >>           <<03544>>10905000
   move buf(1) := buf,(len-1);                                 <<03544>>10910000
   end;                                                        <<03544>>10915000
end;     << zerobuf >>                                         <<03544>>10920000
procedure fill' (buf', len, char);                             <<04659>>10925000
         value len, char;                                      <<04659>>10930000
         byte array buf';                                      <<04659>>10935000
         integer len;                                          <<04659>>10940000
         byte char;                                            <<04659>>10945000
   begin                                                       <<04659>>10950000
                                                               <<04659>>10955000
   buf':=char;                                                 <<04659>>10960000
   if len > 1 then                                             <<04659>>10965000
      move buf'(1):=buf'(0),(len-1);                           <<04659>>10970000
                                                               <<04659>>10975000
   end <<fill' proc>>;                                         <<04659>>10980000
    <<------------------------------------->>                  <<dl.01>>10985000
    <<delete comments from terminal buffers>>                  <<dl.01>>10990000
    <<------------------------------------->>                  <<dl.01>>10995000
                                                               <<dl.01>>11000000
  procedure deletecomment(buffer,maxlength);                   <<dl.01>>11005000
  value maxlength;                                             <<dl.01>>11010000
  integer maxlength;                                           <<dl.01>>11015000
  byte array buffer;                                           <<dl.01>>11020000
                                                               <<dl.01>>11025000
  comment:this routine will delete comments from               <<dl.01>>11030000
  terminal input buffers by physically compressing             <<dl.01>>11035000
  the character string.  it assumes that the valid             <<dl.01>>11040000
  data in the string is delimited by a cr (%15).;              <<dl.01>>11045000
                                                               <<dl.01>>11050000
  begin                                                        <<dl.01>>11055000
  logical endfound,closed;                                     <<dl.01>>11060000
  integer index;                                               <<dl.01>>11065000
  equate cropen=%6474, crclose=%6476;                          <<dl.01>>11070000
                                                               <<dl.01>>11075000
  tos:=@buffer; <<set start for scan>>                         <<dl.01>>11080000
  endfound:=false;                                             <<dl.01>>11085000
  do                                                           <<dl.01>>11090000
    begin <<search for comments>>                              <<dl.01>>11095000
    scan * until cropen,1;                                     <<dl.01>>11100000
    if carry then endfound:=true;                              <<dl.01>>11105000
    if bps0="<<" then                                          <<dl.01>>11110000
      begin <<valid comment started>>                          <<dl.01>>11115000
      assemble(dup,dup);                                       <<dl.01>>11120000
      closed:=false;                                           <<dl.01>>11125000
      do                                                       <<dl.01>>11130000
        begin <<search for end of comment>>                    <<dl.01>>11135000
        scan * until crclose,1;                                <<dl.01>>11140000
        if carry then                                          <<dl.01>>11145000
          begin <<closed by end of data>>                      <<dl.01>>11150000
          ddel;                                                <<dl.01>>11155000
          bps0:=%15;<<move end of data mark>>                  <<dl.01>>11160000
          closed:=true;                                        <<dl.01>>11165000
          endfound:=true;                                      <<dl.01>>11170000
          end;  <<closed by end of data>>                      <<dl.01>>11175000
        if bps0=">>" then                                      <<dl.01>>11180000
          begin <<closed by carots>>                           <<dl.01>>11185000
          tos:=tos+2; <<step over carots>>                     <<dl.01>>11190000
          index:=s0;<<next non-comment char>>                  <<dl.01>>11195000
          move *:=*,(@buffer+maxlength-index);                 <<dl.01>>11200000
          closed:=true;                                        <<dl.01>>11205000
          end   <<closed by carots>>                           <<dl.01>>11210000
        else                                                   <<dl.01>>11215000
          <<false close-only one carot>>                       <<dl.01>>11220000
          tos:=tos+1; <<step over carot>>                      <<dl.01>>11225000
        end   <<search for end of comment>>                    <<dl.01>>11230000
      until closed;                                            <<dl.01>>11235000
      end;  <<valid comment>>                                  <<dl.01>>11240000
    tos:=tos+1; <<bump search start address>>                  <<dl.01>>11245000
    end   <<search for comments>>                              <<dl.01>>11250000
  until endfound;                                              <<dl.01>>11255000
  del; <<get rid of search start pointer>>                     <<dl.01>>11260000
  end;  <<deletecomment>>                                      <<dl.01>>11265000
$control segment=sysdump                                       <<01073>>11270000
                                                               <<dl.01>>11275000
          <<----------------------                                      11280000
            read a line of input                                        11285000
          ---------------------->>                                      11290000
  procedure readinput;                                                  11295000
    option privileged,uncallable;                                       11300000
    comment                                                             11305000
      reads a line of input from the job input device;                  11310000
      begin                                                             11315000
          @bpinbuf := @inbuf&lsl(1);                                    11320000
          tos:=read(inbuf,-72);                                <<+0.05>>11325000
          if <> then purgetempsl;  <<quit>>                             11330000
          <<debug may be invoked by responding>>               <<01.00>>11335000
          <<"DEBUG" to any question in the>>                   <<01.00>>11340000
          <<sysdump dialog while in a session>>                <<01.00>>11345000
          if logical(mode) then  <<session?>>                  <<01.00>>11350000
            if binbuf="DEBUG" and s0=5 then                    <<01.00>>11355000
              begin <<invoke debug and recall read>>           <<01.00>>11360000
              debug;                                           <<01.00>>11365000
              del; <<length of "READ" response>>               <<01.00>>11370000
              message(m2465); <<read pending>>                 <<*8393>>11375000
              readinput;                                       <<dl.01>>11380000
              return;                                          <<dl.01>>11385000
              end;                                             <<dl.01>>11390000
          if not logical(mode) then                                     11395000
            begin  <<batch>>                                            11400000
            tos:=@inbuf;                                       <<dl.01>>11405000
              tos := -s1;                                               11410000
              print(*,*,0);                                             11415000
            end;                                                        11420000
          x := tos;                                                     11425000
          binbuf(x):=%15;  <<carriage return terminator>>      <<dl.01>>11430000
          deletecomment(binbuf,binbuflen);                     <<dl.01>>11435000
      end <<readinput>> ;                                               11440000
$control segment=sysdump                                       <<01073>>11445000
                                                                        11450000
          <<-----------------                                           11455000
            get input value                                             11460000
          ----------------->>                                           11465000
  integer procedure inval(errlabel,delim,doubl);                        11470000
    value errlabel,delim,doubl;                                         11475000
    integer errlabel,     <<label for error return>>                    11480000
            delim;        <<allowed delimiter>>                         11485000
    logical doubl;         <<if passed then return double>>             11490000
    option privileged,uncallable;                                       11495000
    option variable;                                                    11500000
    comment                                                             11505000
      converts a number pointed to by bpinbuf to binary. if an error    11510000
    is detected returns to errlabel. otherwise returns value and sets   11515000
    condition code as follows:                                          11520000
         cce - no value input                                           11525000
         ccg - followed by carriage return                              11530000
         ccl - followed by delimiter;                                   11535000
      begin                                                             11540000
      double dinval=q-9;                                                11545000
      logical dble=q-4;                                                 11550000
        equate blank=%6440;                                             11555000
        integer concode:=ccl;                                           11560000
        integer base:=10;                                      <<00266>>11565000
          tos := 0d;  <<for binary or dbinary return>>                  11570000
          scan bpinbuf while blank,1;  <<delete leading blanks>>        11575000
          if carry then                                                 11580000
            begin       <<carriage return input>>                       11585000
              @bpinbuf := tos+1;                                        11590000
              concode := cce;                                           11595000
              goto fin;                                                 11600000
            end;                                                        11605000
          if bps0="%" then                                     <<00266>>11610000
            begin                                              <<00266>>11615000
            base:=8;                                           <<00266>>11620000
            tos:=tos+1;                                        <<00266>>11625000
            end;                                               <<00266>>11630000
          assemble(dup,ddup);                                           11635000
          move * := * while n,0;   <<find first non-numeric>>           11640000
          scan * while blank,1;    <<delete trailing blanks>>           11645000
          if carry then concode := ccg    <<cr follows>>                11650000
          else if integer(bps0)<>delim then goto error;                 11655000
          @bpinbuf := tos+1;     <<update buffer pointer>>              11660000
          assemble(xch,sub);     <<compute length>>                     11665000
          if s0>7 and not dble then go error;                           11670000
          if s0>11 then go to error;<<for doubles>>;                    11675000
          if base=8 then                                       <<00266>>11680000
            begin                                              <<00266>>11685000
            s1:=s1-1; <<set back to include "%">>              <<00266>>11690000
            s0:=s0+1; <<increment length>>                     <<00266>>11695000
            end;                                               <<00266>>11700000
          if dble and doubl then                                        11705000
            begin                                                       11710000
         dinval := dbinary(*,*);                                        11715000
            go fin;                                                     11720000
            end;                                                        11725000
          inval := binary(*,*);  <<compute value>>                      11730000
          if <> then                                                    11735000
            begin    <<error in conversion>>                            11740000
  error:      returnp := errlabel;     <<error return label>>           11745000
              assemble(exit 5);        <<delete inval's value>><<01165>>11750000
            end;                                                        11755000
  fin:    stat.(6:2) := concode;       <<set condition code>>           11760000
      end <<inval>> ;                                                   11765000
$control segment=sysdump                                       <<01073>>11770000
                                                                        11775000
          <<--------------------------                                  11780000
            get "YES" or "NO" answer                                    11785000
          -------------------------->>                                  11790000
  procedure getyesno(nolabel,messn);                                    11795000
    value nolabel,messn;                                                11800000
    integer nolabel,    <<label of return for "NO" response>>           11805000
            messn;      <<message number>>                              11810000
    option privileged,uncallable;                                       11815000
    comment                                                             11820000
      outputs a message and looks for a "Y" response (normal return)    11825000
    or a "N" or carriage return response (return to nolabel);           11830000
      begin                                                             11835000
        equate blank = %6440;                                           11840000
  again:  message(-messn);    <<output message>>                        11845000
          readinput;                                                    11850000
          scan binbuf while blank,1;                                    11855000
          assemble(dup,dup);                                            11860000
          move * := * while ans;  <<upshift lower case>>                11865000
          if carry or (bps0="N") then                                   11870000
            begin    <<"NO" response>>                                  11875000
              returnp := nolabel;                                       11880000
              return;                                                   11885000
            end                                                         11890000
          else                                                          11895000
          if bps0<>"Y" then                                             11900000
            begin    <<error>>                                          11905000
              del;                                                      11910000
              message(m2453);  <<illegal input>>               <<*8393>>11915000
              go again;                                                 11920000
            end;                                                        11925000
                    <<falls through in "Y" case>>                       11930000
      end <<getyesno>> ;                                                11935000
$control segment=sysdump                                       <<01073>>11940000
     logical procedure yesanswer(messn);                       <<01073>>11945000
     value messn;                                              <<01073>>11950000
     integer messn;                                            <<01073>>11955000
     option privileged,uncallable;                             <<01073>>11960000
     begin                                                     <<01073>>11965000
      getyesno(@noanswer,messn);                               <<01073>>11970000
      yesanswer := true;                                       <<01073>>11975000
      return;                                                  <<01073>>11980000
 noanswer:                                                     <<01073>>11985000
      yesanswer := false;                                      <<01073>>11990000
      return;                                                  <<01073>>11995000
     end;                                                      <<01073>>12000000
                                                               <<t8393>>12005000
logical procedure defyesanswer(mode, messn, defchosen);        <<d8821>>12010000
   value mode, messn;                                          <<t8393>>12015000
   integer mode, messn, defchosen;                             <<d8821>>12020000
   option variable, privileged, uncallable;                    <<d8821>>12025000
   begin                                                       <<t8393>>12030000
                                                               <<d8821>>12035000
   logical pmap = q - 4;  << option variable parameter map>>   <<d8821>>12040000
                                                               <<t8393>>12045000
   equate blank = %6440;                                       <<t8393>>12050000
                                                               <<d8821>>12055000
   again:                                                      <<d8821>>12060000
   fill'(binbuf, 80, " ");                                     <<d8821>>12065000
   binbuf(0) := %3; <<count for genmessage string>>            <<t8393>>12070000
   if pmap then defchosen := false;                            <<d8821>>12075000
   if logical(mode) then                                       <<t8393>>12080000
      move binbuf(1) := " Y "                                  <<t8393>>12085000
   else move binbuf(1) := " N ";                               <<t8393>>12090000
   message(-messn,,,,,binbuf);                                 <<d8821>>12095000
   readinput;                                                  <<t8393>>12100000
   scan binbuf while blank, 1;                                 <<t8393>>12105000
   assemble(dup, dup);                                         <<t8393>>12110000
   move * := * while ans; <<upshift lower case>>               <<t8393>>12115000
   if carry  then                                              <<d8821>>12120000
      begin                                                    <<d8821>>12125000
      if pmap then defchosen := true;                          <<d8821>>12130000
      defyesanswer := logical(mode);                           <<d8821>>12135000
      end                                                      <<d8821>>12140000
   else if bps0 = "Y" then                                     <<d8821>>12145000
      defyesanswer := true                                     <<d8821>>12150000
   else if bps0 = "N" then                                     <<t8393>>12155000
      defyesanswer := false                                    <<d8821>>12160000
   else begin                                                  <<t8393>>12165000
        del;                                                   <<t8393>>12170000
        message (m2453); <<illegal input>>                     <<t8393>>12175000
        go again;                                              <<t8393>>12180000
        end;                                                   <<t8393>>12185000
                                                               <<t8393>>12190000
    end; <<defyesanswer>>                                      <<t8393>>12195000
$control segment=iochange                                      <<01073>>12200000
                                                                        12205000
          <<-----------                                                 12210000
            get value                                                   12215000
          ----------->>                                                 12220000
  integer procedure getval(messn,llim,ulim,term);                       12225000
    value messn,llim,ulim,term;                                         12230000
    integer messn,   <<message number>>                                 12235000
            llim,    <<lower limit>>                                    12240000
            ulim,    <<upper limit>>                                    12245000
            term;    <<terminating control:                             12250000
                          2 - cr only (no value input ok)               12255000
                          1 - cr only (no value input is error)         12260000
                          0 - comma only                                12265000
                         -1 - cr or comma  >>                           12270000
    option privileged,uncallable;                                       12275000
    comment                                                             12280000
      outputs a message and looks for the input of a number in the      12285000
    range  llim <= n <= ulim.                                  <<00.04>>12290000
    the condition code is set as follows:                      <<00.04>>12295000
         ccg - value followed by carriage return               <<00.04>>12300000
         ccl - value followed by comma                         <<00.04>>12305000
         cce - no value input and terminating control=2;       <<00.04>>12310000
      begin                                                             12315000
        integer termtemp;                                               12320000
  again:  message(-messn);       <<output message>>                     12325000
          readinput;                                                    12330000
          tos := inval(@error1,",");                                    12335000
          if = then if term<>2 then goto error                          12340000
          else                                                          12345000
            begin  <<<<no value input>>                                 12350000
              stat.(6:2) := cce;                                        12355000
              return;                                                   12360000
            end;                                                        12365000
          push(status);                                                 12370000
          tos := tos.(6:2);                                             12375000
          stat.(6:2) := s0;        <<set condition code>>               12380000
          termtemp := (if term=2 then 1 else term);                     12385000
          if tos=termtemp then goto error;<<wrong following char>>      12390000
          if (llim<=s0<=ulim) then                                      12395000
            begin                                                       12400000
              getval := tos;                                            12405000
              return;                                                   12410000
            end;                                                        12415000
  error:  del;                                                          12420000
  error1: message(m2453);                                      <<*8393>>12425000
          go again;                                                     12430000
      end <<getval>> ;                                                  12435000
$control segment=sysdump                                       <<01073>>12440000
                                                                        12445000
          <<----------------------->>                          <<*8393>>12450000
          << get replacement value >>                          <<*8393>>12455000
          <<----------------------->>                          <<*8393>>12460000
  procedure getnewval(messn,val,llim,ulim,num'used,no'min'max);<<m8954>>12465000
    value messn,llim,ulim,num'used;                            <<*8393>>12470000
    integer messn;      <<message number>>                     <<*8393>>12475000
    logical                                                    <<*8393>>12480000
            val,        <<value to be replaced>>               <<*8393>>12485000
            llim,       <<lower limit>>                        <<*8393>>12490000
            ulim,       <<upper limit>>                        <<*8393>>12495000
            num'used,   << number used >>                      <<m8954>>12500000
            no'min'max; << suppress min/max printing >>        <<m8954>>12505000
    option variable;                                           <<m8954>>12510000
    comment                                                    <<*8393>>12515000
        outputs a message followed by the current value, a     <<*8393>>12520000
      period and a question mark(?). looks for the input of a  <<*8393>>12525000
      carriage return, which leaves the value the same, or an  <<*8393>>12530000
      integer in the range  llim <= n <= ulim;                 <<*8393>>12535000
      begin                                                    <<*8393>>12540000
          array buf(0:39);                                     <<*8393>>12545000
          byte array bbuf(*) = buf;                            <<*8393>>12550000
          integer len;                                         <<*8393>>12555000
          define num'used'passed  =logical(parmq4.(14:1))#,    <<m8954>>12560000
                 no'min'max'passed=logical(parmq4.(15:1))#;    <<m8954>>12565000
                                                               <<m8954>>12570000
                                                               <<*8393>>12575000
          x := genmessage( messn, bbuf,0d,0d,0d,0d,bbuf,bbuf); <<*8393>>12580000
          if = then message( m374, 1); << fatal error - no mess<<*8393>>12585000
          move bbuf(x) := " = ",2;                             <<*8393>>12590000
          tos := tos+ascii( val,10, bps0);                     <<*8393>>12595000
          if no'min'max'passed then                            <<m8954>>12600000
             move * := "?",2                                   <<m8954>>12605000
          else begin                                           <<m8954>>12610000
               move * := " (MIN=",2;                           <<m8954>>12615000
               tos := tos+ascii(llim,10,bps0);                 <<m8954>>12620000
               move * := ", MAX=",2;                           <<m8954>>12625000
               tos := tos+ascii(ulim,10,bps0);                 <<m8954>>12630000
               if num'used'passed then                         <<m8954>>12635000
                  begin                                        <<m8954>>12640000
                  move * := ", USED=",2;                       <<m8954>>12645000
                  tos := tos+ascii(num'used,10,bps0);          <<m8954>>12650000
                  end;                                         <<m8954>>12655000
               move * := ")?",2;                               <<m8954>>12660000
               end;                                            <<m8954>>12665000
          len := tos-@bbuf;   << len of message >>             <<m8954>>12670000
again:    print( buf, -len, %320);                             <<*8393>>12675000
          readinput;                                           <<*8393>>12680000
          tos := 0;                                            <<*8393>>12685000
          tos := @error1;                                      <<*8393>>12690000
          tos := inval(*);                                     <<*8393>>12695000
          if = then return;                                    <<*8393>>12700000
          if < then goto error;                                <<*8393>>12705000
          if (llim<=ls0) and (ls0<=ulim) then                  <<*8393>>12710000
          begin                                                <<*8393>>12715000
              val := tos;                                      <<*8393>>12720000
              return;                                          <<*8393>>12725000
            end;                                               <<*8393>>12730000
          message(m2458,llim,ulim);                            <<*8393>>12735000
          del;                                                 <<*8393>>12740000
          go again;                                            <<*8393>>12745000
  error:  del;                                                 <<*8393>>12750000
  error1: message(m2453);                                      <<*8393>>12755000
          go again;                                            <<*8393>>12760000
      end <<getnewval>> ;                                      <<*8393>>12765000
                                                               <<*8393>>12770000
          <<------------------------------>>                   <<*8393>>12775000
          << get double replacement value >>                   <<*8393>>12780000
          <<------------------------------>>                   <<*8393>>12785000
  procedure getnewval'doub(messn,val,llim,ulim,num'used);      <<*8393>>12790000
    value messn,llim,ulim,num'used;                            <<*8393>>12795000
    integer messn;      <<message number>>                     <<*8393>>12800000
    double                                                     <<*8393>>12805000
            val,        <<value to be replaced>>               <<*8393>>12810000
            llim,       <<lower limit>>                        <<*8393>>12815000
            ulim,       <<upper limit>>                        <<*8393>>12820000
            num'used;   << number used >>                      <<*8393>>12825000
    option variable;                                           <<*8393>>12830000
    comment                                                    <<*8393>>12835000
        outputs a message followed by the current value, a     <<*8393>>12840000
      period and a question mark(?). looks for the input of a  <<*8393>>12845000
      carriage return, which leaves the value the same, or an  <<*8393>>12850000
      integer in the range  llim <= n <= ulim;                 <<*8393>>12855000
      begin                                                    <<*8393>>12860000
          array buf(0:39);                                     <<*8393>>12865000
          byte array bbuf(*) = buf;                            <<*8393>>12870000
          integer len;                                         <<*8393>>12875000
          define num'used'passed=logical(parmq4.(15:1))#;      <<*8393>>12880000
                                                               <<*8393>>12885000
          x := genmessage( messn, bbuf,0d,0d,0d,0d,bbuf,bbuf); <<*8393>>12890000
          if = then message( m374, 1); << fatal error - no mess<<*8393>>12895000
          move bbuf(x) := " = ",2;                             <<*8393>>12900000
          tos := tos+dascii( val,10, bps0);                    <<*8393>>12905000
          move * := " (MIN=",2;                                <<*8393>>12910000
          tos := tos+dascii(llim,10,bps0);                     <<*8393>>12915000
          move * := ", MAX=",2;                                <<*8393>>12920000
          tos := tos+dascii(ulim,10,bps0);                     <<*8393>>12925000
          if num'used'passed then                              <<*8393>>12930000
             begin                                             <<*8393>>12935000
             move * := ", USED=",2;                            <<*8393>>12940000
             tos := tos+dascii(num'used,10,bps0);              <<*8393>>12945000
             end;                                              <<*8393>>12950000
          move * := ")?",2;                                    <<*8393>>12955000
          len := tos-@bbuf;   << len of message >>             <<*8393>>12960000
again:    print( buf, -len, %320);                             <<*8393>>12965000
          readinput;                                           <<*8393>>12970000
          tos := inval(@error1,,true);                         <<*8393>>12975000
          if = then return;                                    <<*8393>>12980000
          if < then goto error;                                <<*8393>>12985000
          if (llim<=ds0) and (ds0<=ulim) then                  <<*8393>>12990000
          begin                                                <<*8393>>12995000
              val := tos;                                      <<*8393>>13000000
              return;                                          <<*8393>>13005000
            end;                                               <<*8393>>13010000
          x:=genmessage(m2458,binbuf,llim,ulim,0d,0d,          <<*8393>>13015000
              binbuf,binbuf);                                  <<*8393>>13020000
          if = then message(m374,1);                           <<*8393>>13025000
          print(inbuf,-x,%40);                                 <<*8393>>13030000
          del;                                                 <<*8393>>13035000
          go again;                                            <<*8393>>13040000
  error:  del;                                                 <<*8393>>13045000
  error1: message(m2453);                                      <<*8393>>13050000
          go again;                                            <<*8393>>13055000
      end <<getnewval>> ;                                      <<*8393>>13060000
                                                               <<t8393>>13065000
          <<*************************>>                        <<t8393>>13070000
          << verify device values    >>                        <<t8393>>13075000
          <<*************************>>                        <<t8393>>13080000
                                                               <<t8393>>13085000
                                                               <<t8393>>13090000
procedure verify'values(messn,val,llim,ulim,term);             <<t8393>>13095000
   value messn,llim,ulim,term;                                 <<t8393>>13100000
   integer messn,val,llim,ulim,term;                           <<t8393>>13105000
   begin                                                       <<t8393>>13110000
                                                               <<m8954>>13115000
   equate no'min'max = 1;  << suppress min/max printing >>     <<m8954>>13120000
                                                               <<m8954>>13125000
   if dev'defaults then                                        <<t8393>>13130000
      getnewval(messn,val,llim,ulim,,no'min'max)               <<m8954>>13135000
   else                                                        <<t8393>>13140000
      val := getval(messn,llim,ulim,term);                     <<t8393>>13145000
   end; << verify'values >>                                    <<t8393>>13150000
                                                               <<t8393>>13155000
$control segment=iochange                                      <<01073>>13160000
          <<--------------------------                                  13165000
            convert ascii and ebcdic                                    13170000
          -------------------------->>                                  13175000
procedure convert(code,instring,outstring,stringlength);                13180000
value code,stringlength;                                                13185000
integer code,stringlength;                                              13190000
byte array instring,outstring;                                          13195000
begin                                                                   13200000
     integer i := -1;                                                   13205000
     array asci(0:255)=pb:=                                             13210000
                                                                        13215000
          << ebcdic to ascii conversion table >>                        13220000
                                                                        13225000
          %000, %001, %002, %003, %000, %011, %000, %177,               13230000
          %000, %000, %000, %013, %014, %015, %016, %017,               13235000
          %020, %021, %022, %023, %000, %000, %010, %000,               13240000
          %030, %031, %000, %000, %034, %035, %036, %037,               13245000
          %000, %000, %000, %000, %000, %012, %027, %033,               13250000
          %000, %000, %000, %000, %000, %005, %006, %007,               13255000
          %000, %000, %026, %000, %000, %000, %000, %004,               13260000
          %000, %000, %000, %000, %024, %025, %000, %032,               13265000
          %040, %000, %000, %000, %000, %000, %000, %000,               13270000
          %000, %000, %133, %056, %074, %050, %053, %041,               13275000
          %046, %000, %000, %000, %000, %000, %000, %000,               13280000
          %000, %000, %135, %044, %052, %051, %073, %136,               13285000
          %055, %057, %000, %000, %000, %000, %000, %000,               13290000
          %000, %000, %174, %054, %045, %137, %076, %077,               13295000
          %000, %000, %000, %000, %000, %000, %000, %000,               13300000
          %000, %140, %072, %043, %100, %047, %075, %042,               13305000
          %000, %141, %142, %143, %144, %145, %146, %147,               13310000
          %150, %151, %000, %000, %000, %000, %000, %000,               13315000
          %000, %152, %153, %154, %155, %156, %157, %160,               13320000
          %161, %162, %000, %000, %000, %000, %000, %000,               13325000
          %000, %176, %163, %164, %165, %166, %167, %170,               13330000
          %171, %172, %000, %000, %000, %000, %000, %000,               13335000
          %000, %000, %000, %000, %000, %000, %000, %000,               13340000
          %000, %000, %000, %000, %000, %000, %000, %000,               13345000
          %173, %101, %102, %103, %104, %105, %106, %107,               13350000
          %110, %111, %000, %000, %000, %000, %000, %000,               13355000
          %175, %112, %113, %114, %115, %116, %117, %120,               13360000
          %121, %122, %000, %000, %000, %000, %000, %000,               13365000
          %134, %000, %123, %124, %125, %126, %127, %130,               13370000
          %131, %132, %000, %000, %000, %000, %000, %000,               13375000
          %060, %061, %062, %063, %064, %065, %066, %067,               13380000
          %070, %071, %000, %000, %000, %000, %000, %000;               13385000
                                                                        13390000
     array ebcdic(0:255)=pb:=                                           13395000
                                                                        13400000
          << ascii to ebcdic conversion table >>                        13405000
                                                                        13410000
          %000, %001, %002, %003, %067, %055, %056, %057,               13415000
          %026, %005, %045, %013, %014, %015, %016, %017,               13420000
          %020, %021, %022, %023, %074, %075, %062, %046,               13425000
          %030, %031, %077, %047, %034, %035, %036, %037,               13430000
          %100, %117, %177, %173, %133, %154, %120, %175,               13435000
          %115, %135, %134, %116, %153, %140, %113, %141,               13440000
          %360, %361, %362, %363, %364, %365, %366, %367,               13445000
          %370, %371, %172, %136, %114, %176, %156, %157,               13450000
          %174, %301, %302, %303, %304, %305, %306, %307,               13455000
          %310, %311, %321, %322, %323, %324, %325, %326,               13460000
          %327, %330, %331, %342, %343, %344, %345, %346,               13465000
          %347, %350, %351, %112, %340, %132, %137, %155,               13470000
          %171, %201, %202, %203, %204, %205, %206, %207,               13475000
          %210, %211, %221, %222, %223, %224, %225, %226,               13480000
          %227, %230, %231, %242, %243, %244, %245, %246,               13485000
          %247, %250, %251, %300, %152, %320, %241, %007,               13490000
          %000, %000, %000, %000, %000, %000, %000, %000,               13495000
          %000, %000, %000, %000, %000, %000, %000, %000,               13500000
          %000, %000, %000, %000, %000, %000, %000, %000,               13505000
          %000, %000, %000, %000, %000, %000, %000, %000,               13510000
          %000, %000, %000, %000, %000, %000, %000, %000,               13515000
          %000, %000, %000, %000, %000, %000, %000, %000,               13520000
          %000, %000, %000, %000, %000, %000, %000, %000,               13525000
          %000, %000, %000, %000, %000, %000, %000, %000,               13530000
          %000, %000, %000, %000, %000, %000, %000, %000,               13535000
          %000, %000, %000, %000, %000, %000, %000, %000,               13540000
          %000, %000, %000, %000, %000, %000, %000, %000,               13545000
          %000, %000, %000, %000, %000, %000, %000, %000,               13550000
          %000, %000, %000, %000, %000, %000, %000, %000,               13555000
          %000, %000, %000, %000, %000, %000, %000, %000,               13560000
          %000, %000, %000, %000, %000, %000, %000, %000,               13565000
          %000, %000, %000, %000, %000, %000, %000, %000;               13570000
                                                                        13575000
     case * code of                                                     13580000
     begin                                                              13585000
          while(i:=i+1)<stringlength do                                 13590000
          begin     <<case 0, convert ebcdic to ascii>>                 13595000
               x := instring(i);                                        13600000
               tos := asci(x);                                          13605000
               outstring(i) := tos;                                     13610000
          end;                                                          13615000
          while(i:=i+1)<stringlength do                                 13620000
          begin     <<case 1, convert ascii to ebcdic>>                 13625000
               x := instring(i);                                        13630000
               tos := ebcdic(x);                                        13635000
               outstring(i) := tos;                                     13640000
          end;                                                          13645000
     end;                                                               13650000
end <<convert>>;                                                        13655000
                                                               <<d8821>>13660000
procedure hexout(number, outstring, length);                   <<d8821>>13665000
   value number, length;                                       <<d8821>>13670000
   double number;                                              <<d8821>>13675000
   integer length;                                             <<d8821>>13680000
   byte array outstring;                                       <<d8821>>13685000
                                                               <<d8821>>13690000
   begin                                                       <<d8821>>13695000
                                                               <<d8821>>13700000
   <<------------------------------------------------------>>  <<d8821>>13705000
   << characters for hexadecimal conversion: 0,1,2,...9,a, >>  <<d8821>>13710000
   <<------------------------------------------------------>>  <<d8821>>13715000
   integer array chars(*) = pb :=                              <<d8821>>13720000
           %60, %61, %62, %63,                                 <<d8821>>13725000
           %64, %65, %66, %67,                                 <<d8821>>13730000
           %70, %71, %101,%102,                                <<d8821>>13735000
          %103, %104,%105,%106;                                <<d8821>>13740000
                                                               <<d8821>>13745000
                                                               <<d8821>>13750000
   while length > 0 do                                         <<d8821>>13755000
      begin                                                    <<d8821>>13760000
      length := length - 1;                                    <<d8821>>13765000
      outstring(length) := chars(logical(number).(12:4));      <<d8821>>13770000
      number := number & dcsr(4);                              <<d8821>>13775000
      end;                                                     <<d8821>>13780000
                                                               <<d8821>>13785000
end; <<hexout>>                                                <<d8821>>13790000
                                                               <<d8821>>13795000
$control segment=sysdump                                       <<01073>>13800000
                                                                        13805000
          <<------------                                                13810000
            get string                                                  13815000
          ------------>>                                                13820000
  integer procedure getstr(errlabel,addr,term,spec,maxlen);             13825000
    value errlabel,term,spec,maxlen;                                    13830000
    byte array addr;    <<destination array>>                           13835000
    integer errlabel,   <<error return>>                                13840000
            spec,       <<allowed special character>>                   13845000
            maxlen,     <<max permitted length>>                        13850000
            term;       <<terminating control                           13855000
                           0 - comma only                               13860000
                           1 - cr only                                  13865000
                          -1 - cr or comma(no input not ok)             13870000
                           2 - cr or comma(no input ok)                 13875000
                           3 - cr only(no input ok) >>                  13880000
    option privileged,uncallable;                                       13885000
    comment                                                             13890000
      extracts an up-to-8 character string from the input buffer        13895000
    pointed to by bpinbuf and moves it to byte array addr. if an        13900000
    error is encountered, it exits to errlabel.                <<00.04>>13905000
    condition code is set as follows:                          <<00.04>>13910000
         ccg - followed by carriage return                              13915000
         ccl - followed by comma                               <<00.04>>13920000
         cce - no input and terminating control=2 or 3;        <<00.04>>13925000
      begin                                                             13930000
        equate blank=%6440;                                             13935000
        integer concode;                                                13940000
          tos := @addr;       <<destination for final move>>            13945000
          scan bpinbuf while blank,1;  <<delete leading blanks>>        13950000
          if carry and (term=3 or term=2)  then                         13955000
            begin                                                       13960000
            getstr := 0;                                                13965000
            stat.(6:2) := cce;                                          13970000
            return;                                                     13975000
            end;                                                        13980000
          if term=2 then term:=-1 else                                  13985000
          if term=3 then term:=1;                                       13990000
          if bps0<>alpha then goto error;                               13995000
          assemble(dup,ddup);                                           14000000
  moveup: move * := * while ans,0;  <<upshift lower case>>              14005000
          if integer(bps0) = spec then                                  14010000
            begin                                                       14015000
              if s0 = s2 then goto error;                               14020000
              assemble(inca,incb);   <<bump buffer pointers>>           14025000
              goto moveup;                                              14030000
            end;                                                        14035000
          scan * while blank,1;     <<delete trailing blanks>>          14040000
          if carry then concode := ccg                                  14045000
          else if bps0="," then concode := ccl                          14050000
          else goto error;                                              14055000
          if concode=term then goto error;                              14060000
          stat.(6:2) := concode;  <<set condition code>>                14065000
          @bpinbuf := tos+1;  <<update buffer pointer>>                 14070000
          assemble(xch,sub; dup,stax);  <<compute length>>              14075000
          assemble(dup,dup);                                            14080000
          getstr := tos;   <<length>>                                   14085000
          if = or tos>maxlen then                                       14090000
            begin    <<length out of range>>                            14095000
  error:      message(m2453);                                  <<*8393>>14100000
              returnp := errlabel;                                      14105000
              assemble(exit 6);  <<get rid of return value>>            14110000
            end;                                                        14115000
          assemble(mvb 3);   <<transfer string>>                        14120000
          while x < maxlen do                                           14125000
            begin    <<fill with blanks>>                               14130000
              addr(x) := " ";                                           14135000
              x := x+1;                                                 14140000
            end;                                                        14145000
      end <<getstr>> ;                                                  14150000
$page "DEVICE TABLES MANIPULATION PROCEDURES"                           14155000
                                                                        14160000
$control segment=iochange                                      <<01073>>14165000
          <<------------------                                          14170000
            get phone number                                            14175000
          ------------------>>                                          14180000
  integer procedure getphnb(errlabel,addr,spec);                        14185000
    value errlabel,spec;                                                14190000
    integer errlabel,spec;                                              14195000
    byte array addr;                                                    14200000
      begin                                                             14205000
        equate blank=%6440;                                             14210000
        equate space=%40;                                      <<04260>>14215000
        equate delete=%177;                                    <<04260>>14220000
        integer concode:=ccg;                                           14225000
          tos := @addr;                                                 14230000
          scan bpinbuf while blank,1;                                   14235000
          if carry then concode:=cce;                                   14240000
          assemble(dup,ddup);                                           14245000
  moveups:move *:=* while ans,0;  <<upshift lower case>>       <<04260>>14250000
          if integer(bps0) >= space and integer(bps0) < delete <<04260>>14255000
            then                                               <<04260>>14260000
            begin                                                       14265000
            assemble(inca,incb);                                        14270000
            go moveups;                                                 14275000
            end;                                                        14280000
          scan * while blank;                                           14285000
          if nocarry  then                                              14290000
  error:    begin                                                       14295000
            message(m2453);                                    <<*8393>>14300000
            returnp:=errlabel;                                          14305000
            assemble(exit 4);                                           14310000
            end;                                                        14315000
          assemble(xch,sub);  <<calculate length>>                      14320000
          if s0>30 then go error;                              <<04260>>14325000
          getphnb := s0;                                                14330000
          assemble(mvb 3);                                              14335000
          stat.(6:2):=concode;                                          14340000
      end  <<getphnb>>;                                                 14345000
$control segment=iochange                                      <<01073>>14350000
                                                                        14355000
          <<----------------------------                                14360000
            list addiiional cs drivers                                  14365000
          ---------------------------->>                                14370000
                                                                        14375000
  procedure listdvrs;                                                   14380000
    begin                                                               14385000
        array hed(0:10)=pb:="ADDITIONAL CS DRIVERS";                    14390000
        integer i:=-1,j:=0,k,l;                                         14395000
          inbuf := "  ";                                                14400000
          move inbuf(1) := inbuf,(35);                                  14405000
          move inbuf(12) := hed,(11);                                   14410000
          fwrite(listfnum,inbuf,-47,0);                                 14415000
  listerr:if <> then ferror(listfnum,listfile);                         14420000
          l := comm(numadvrs);                                 <<07039>>14425000
          while i<l do                                                  14430000
            begin                                                       14435000
            k:=-1;                                                      14440000
            inbuf := "  ";                                              14445000
            move inbuf(1):=inbuf,(35);                                  14450000
            while (k:=k+1)<=5 and (i:=i+1)<l do                         14455000
              move inbuf(k*6):=csdvr(i*4),(4);                          14460000
            fwrite(listfnum,inbuf,-72,0);                               14465000
            if <> then go listerr;                                      14470000
            end;                                                        14475000
          fwrite(listfnum,inbuf,0,%61);                                 14480000
          if <> then go listerr;                                        14485000
    end  <<listdvrs>>;                                                  14490000
$control segment=iochange                                      <<03544>>14495000
       <<------------------------------------>>                <<03544>>14500000
       << check for system-disc type devices >>                <<03544>>14505000
       <<------------------------------------>>                <<03544>>14510000
logical procedure sysdisc'type( type, subtyp);                 <<03544>>14515000
value type, subtyp;                                            <<03544>>14520000
integer type,     << device type >>                            <<03544>>14525000
        subtyp;   << device subtype >>                         <<03544>>14530000
comment                                                        <<03544>>14535000
this procedure returns true if the device with                 <<03544>>14540000
the given type and subtype is a valid system-                  <<03544>>14545000
domain disc.  it returns false otherwise.                      <<03544>>14550000
;                                                              <<03544>>14555000
begin                                                          <<03544>>14560000
if type = disc0 or                                             <<03544>>14565000
   type = disc1 or                                             <<03544>>14570000
   type = disc3 and                                            <<*8393>>14575000
   subtyp <> linus and subtyp <> buffalo then                  <<l8870>>14580000
   sysdisc'type := true                                        <<03544>>14585000
else                                                           <<03544>>14590000
   sysdisc'type := false;                                      <<03544>>14595000
end;   << sysdisc'type >>                                      <<03544>>14600000
$control segment=iochange                                      <<03544>>14605000
        <<----------------------------------->>                <<03544>>14610000
        << check for serial-disc type device >>                <<03544>>14615000
        <<----------------------------------->>                <<03544>>14620000
logical procedure sdisc'type( type, subtyp);                   <<03544>>14625000
value type, subtyp;                                            <<03544>>14630000
integer type,     << device type >>                            <<03544>>14635000
        subtyp;   << device subtype >>                         <<03544>>14640000
comment                                                        <<03544>>14645000
this procedure returns true if the device with                 <<03544>>14650000
the given type and subtype can be a serial disc.               <<03544>>14655000
it returns false otherwise.  all removable discs               <<03544>>14660000
except the 7900 can be serial discs.                           <<03544>>14665000
;                                                              <<03544>>14670000
begin                                                          <<03544>>14675000
if type=disc0 and (subtyp=uh7905 or subtyp=uh7906              <<03544>>14680000
                or subtyp=s7920  or subtyp=s7925 ) or          <<03544>>14685000
   type=disc2 or                                               <<03544>>14690000
   type=disc3 then                                             <<06143>>14695000
                                                               <<03544>>14700000
   sdisc'type := true    << it can be a serial disc >>         <<03544>>14705000
else                                                           <<03544>>14710000
   sdisc'type := false;  << it can't be serial >>              <<03544>>14715000
end;   << sdisc'type >>                                        <<03544>>14720000
                                                               <<d9068>>14725000
                                                               <<d9068>>14730000
logical procedure rs232'printer(type, subtype);                <<d9068>>14735000
    value type, subtype;                                       <<d9068>>14740000
    integer type, subtype;                                     <<d9068>>14745000
                                                               <<d9068>>14750000
    begin                                                      <<d9068>>14755000
                                                               <<d9068>>14760000
    if type = ldt'printer and                                  <<d9068>>14765000
       (subtype = 14 or subtype = 15)                          <<d9068>>14770000
       then rs232'printer := true                              <<d9068>>14775000
    else rs232'printer := false;                               <<d9068>>14780000
                                                               <<d9068>>14785000
    end; << rs232'printer >>                                   <<d9068>>14790000
                                                               <<d9068>>14795000
$control segment=iochange                                      <<01073>>14800000
          <<-----------------                                           14805000
            get class index                                             14810000
          ----------------->>                                           14815000
  integer procedure clindex(clname);                                    14820000
    byte array clname;                                                  14825000
    option privileged,uncallable;                                       14830000
      begin                                                             14835000
        integer i:=0;                                          <<06762>>14840000
        @dct := @dct'head + dcth'dct'base;                     <<06762>>14845000
        @dct'b := @dct & lsl(1);                               <<06762>>14850000
          while (i:=i+1) <= dcth'num'dct'entries do            <<06762>>14855000
          if dctb'class'name = clname,(8) then                 <<06762>>14860000
            begin   <<found it>>                                        14865000
              clindex := i;                                             14870000
              return;                                                   14875000
            end                                                         14880000
          else                                                          14885000
            begin   <<bump index>>                                      14890000
              @dct := @dct + dct'next'entry;                   <<06762>>14895000
              @dct'b := @dct & lsl(1);                         <<06762>>14900000
            end;                                                        14905000
      end <<clindex>> ;                                                 14910000
$control segment=iochange                                      <<03702>>14915000
          <<------------------------------->>                  <<03702>>14920000
          <<  check input terminal speed   >>                  <<03702>>14925000
          <<------------------------------->>                  <<03702>>14930000
logical procedure checkspeed( tspeed, speedcde );              <<03702>>14935000
integer                                                        <<03702>>14940000
   tspeed,       << speed (chars/sec), passed or returned >>   <<03702>>14945000
   speedcde;     << baudrate code, passed or returned >>       <<03702>>14950000
comment                                                        <<03702>>14955000
this procedure converts the terminal speed (chars/sec)         <<03702>>14960000
to its internal baud rate code and vice-versa.                 <<03702>>14965000
if 'tspeed' is negative, we convert 'speedcde' to              <<03702>>14970000
chars/sec, returning the result in 'tspeed'.  if               <<03702>>14975000
'tspeed' is positive, we convert it to the baudrate            <<03702>>14980000
code, returning the result in 'speedcde'.  in either           <<03702>>14985000
case, the procedure returns true if the conversion was         <<03702>>14990000
valid, false otherwise.                                        <<03702>>14995000
;                                                              <<03702>>15000000
begin                                                          <<03702>>15005000
equate                                                         <<03702>>15010000
   unused  = 32000;    << indicates unused speed code >>       <<03702>>15015000
equate                                                         <<03702>>15020000
   start'iii = 0,    << starting array index >>                <<03702>>15025000
   high'iii  = 7;    << ending array index   >>                <<03702>>15030000
integer array                        << allowed speeds for >>  <<03702>>15035000
   speeds'iii(start'iii:high'iii) = pb :=                      <<03702>>15040000
   0,240,120,60,30,15,10,14;         << atc in chars/sec   >>  <<03702>>15045000
equate                                                         <<03702>>15050000
   start'33 = 6,    << starting array index >>                 <<03702>>15055000
   high'33  = 18;   << ending array index for atp >>           <<03702>>15060000
integer array                       << allowed speeds for  >>  <<03702>>15065000
   speeds'33(start'33:high'33) = pb :=                         <<03702>>15070000
   60,240,960,480,unused,120,       << adcc, atp.   (codes >>  <<03702>>15075000
   unused,30,15,10,1920,3840,180;   << 10,12 are not used) >>  <<03702>>15080000
integer                                                        <<03702>>15085000
   i,             << index var. >>                             <<03702>>15090000
   startspeed,    << index of first speed >>                   <<03702>>15095000
   highspeed;     << index of last speed  >>                   <<03702>>15100000
integer array                                                  <<03702>>15105000
   speeds(0:high'33);     << local array for speeds >>         <<03702>>15110000
                                                               <<03702>>15115000
checkspeed := false;                                           <<03702>>15120000
                                                               <<03702>>15125000
if seriesii'iii then                                           <<03702>>15130000
   begin              << set up parameters for atc speeds >>   <<03702>>15135000
   startspeed := start'iii;                                    <<03702>>15140000
   highspeed := high'iii;                                      <<03702>>15145000
   move speeds(start'iii) :=                                   <<03702>>15150000
        speeds'iii(start'iii),(high'iii - start'iii + 1);      <<03702>>15155000
   end                                                         <<03702>>15160000
                                                               <<03702>>15165000
else                                                           <<03702>>15170000
   begin         << set up parameters for adcc, atp speeds >>  <<03702>>15175000
   startspeed := start'33;                                     <<03702>>15180000
   highspeed := high'33;                                       <<03702>>15185000
   move speeds(start'33) :=                                    <<03702>>15190000
        speeds'33(start'33),(high'33 - start'33 + 1);          <<03702>>15195000
   end;                                                        <<03702>>15200000
                                                               <<03702>>15205000
if tspeed < 0 then                                             <<03702>>15210000
   begin   << convert from baudrate code to chars/sec >>       <<03702>>15215000
   if startspeed <= speedcde <= highspeed then                 <<03702>>15220000
      begin                                                    <<03702>>15225000
      tspeed := speeds(speedcde);                              <<03702>>15230000
      if tspeed < unused then                                  <<03702>>15235000
         checkspeed := true;                                   <<03702>>15240000
      end;                                                     <<03702>>15245000
   end                                                         <<03702>>15250000
                                                               <<03702>>15255000
else                                                           <<03702>>15260000
   begin   << convert from chars/sec to baudrate code >>       <<03702>>15265000
   i := startspeed - 1;                                        <<03702>>15270000
   while (i:=i+1) <= highspeed do    << compare against >>     <<03702>>15275000
      if speeds(i) = tspeed then     <<    all speeds   >>     <<03702>>15280000
         begin      << valid speed >>                          <<03702>>15285000
         speedcde  := i;                                       <<03702>>15290000
         checkspeed := true;                                   <<03702>>15295000
         end;                                                  <<03702>>15300000
   end;                                                        <<03702>>15305000
end;   << checkspeed >>                                        <<03702>>15310000
$control segment=iochange1                                     <<06068>>15315000
                                                                        15320000
          <<-----------------                                           15325000
            list cs devices                                             15330000
          ----------------->>                                           15335000
                                                                        15340000
  procedure listcsdev;                                                  15345000
    begin                                                               15350000
     array genhed1(0:35)=pb:=                                           15355000
      "LDN PM PRT LCL TC  RCV   LCL   CON  MODE   TRANSMIT ",           15360000
      " TM BUFFER D DRIVER ";                                           15365000
     array genhed2(0:35)=pb:=                                           15370000
      "           MOD    TMOUT TMOUT TMOUT          SPEED    ",         15375000
      "   SIZE  C OPTIONS";                                             15380000
     array swhed1(0:23)=pb:=                                            15385000
      "LDN CTRL  PHONE NUMBER LIST    LOCAL ID SEQUENCE";               15390000
     array swhed2(0:26)=pb:=                                            15395000
      "     LEN                          REMOTE ID SEQUENCES ";         15400000
     array nswhed1(0:25)=pb:=                                           15405000
      "LDN INCOM POLL   CIR  C/S NUM C P COMPONENT SEQUENCE";           15410000
     array nswhed2(0:16)=pb:=                                           15415000
      "    DELAY REPET DELAY     COM T L ";                             15420000
     logical swtched:=false,nonswtched:=false,remote:=false;            15425000
     array bufr(0:35);                                                  15430000
     byte pointer phone,idlist,cntrlseq=phone;                          15435000
     integer i,j,n,temp,phinx,idinx,len,cinx=phinx;                     15440000
     integer k,start,type,len1,nums,nump;                               15445000
     equate  quot   = %42,                                              15450000
             atyp   = 0,                                                15455000
             etyp   = 1,                                                15460000
             otyp   = 2,                                                15465000
             htyp   = 3;                                                15470000
     byte array outtemp(0:71),octdigit(0:5);                            15475000
     integer pointer control;                                           15480000
     double pointer                                            <<06813>>15485000
             dblptr;                                           <<06813>>15490000
                                                                        15495000
  subroutine octtoasci(instring,outstring,length);                      15500000
     integer length;                                                    15505000
     byte array instring,outstring;                                     15510000
       begin                                                            15515000
       move outstring := "O(";                                          15520000
       i := -1;                                                         15525000
       j := 2;                                                          15530000
       while(i:=i+1)<length do                                          15535000
         begin                                                          15540000
         tos := ascii(instring(i),8,octdigit);                          15545000
         k := tos;                                                      15550000
         move outstring(j):=octdigit(6-k),(k);                          15555000
         tos := j+k;                                                    15560000
         j := s0+1;                                                     15565000
         x := tos;                                                      15570000
         outstring(x) := ",";                                           15575000
         end;                                                           15580000
       outstring(x) := ")";                                             15585000
       length := j;                                                     15590000
       end;  <<octtoasci>>                                              15595000
                                                                        15600000
  subroutine hextoasci(instring,outstring,length);                      15605000
    integer length;                                                     15610000
    byte array instring,outstring;                                      15615000
      begin                                                             15620000
      move outstring := "H(";                                           15625000
      i := -1;                                                          15630000
      j := 2;                                                           15635000
      while(i:=i+1)<length do                                           15640000
        begin                                                           15645000
        tos := instring(i);                                             15650000
        tos := %20;                                                     15655000
        assemble(div);                                                  15660000
        if s1=0 then                                                    15665000
          begin  <<one hex digit>>                                      15670000
          x := tos;                                                     15675000
          del;                                                          15680000
          outstring(j) := hex(x);                                       15685000
          j := j+1;                                                     15690000
          end                                                           15695000
        else                                                            15700000
          begin                                                         15705000
          assemble(xch);                                                15710000
          x := tos;                                                     15715000
          k := tos;                                                     15720000
          outstring(j) := hex(x);                                       15725000
          j := j+1;                                                     15730000
          outstring(j) := hex(k);                                       15735000
          j := j+1;                                                     15740000
          end;                                                          15745000
        outstring(j) := ",";                                            15750000
        j := j+1;                                                       15755000
        end;                                                            15760000
      outstring(x) := ")";                                              15765000
      length := j;                                                      15770000
      end;   <<hextoasci>>                                              15775000
                                                                        15780000
          move inbuf := genhed1,(36);                                   15785000
          fwrite(listfnum,inbuf,-72,0);                                 15790000
  listerr:if <> then ferror(listfnum,listfile);                         15795000
          move inbuf := genhed2,(36);                                   15800000
          fwrite(listfnum,inbuf,-72,0);                                 15805000
          if <> then go listerr;                                        15810000
          ldev:=0;                                                      15815000
          while(ldev:=ldev+1)<=hldev do                                 15820000
            begin                                                       15825000
            get'ldev'entries(ldev);                            <<06762>>15830000
            if csdevice then                                   <<01165>>15835000
              begin  <<cs device>>                                      15840000
              inbuf := "  ";                                            15845000
              move inbuf(1):=inbuf,(35);  <<blank buffer>>              15850000
              ascii(ldev,10,binbuf);   <<logical device #>>             15855000
              n := csdef(ldev);                                         15860000
              @csldtx := @cstab+csxstart;                               15865000
              i:=-1;                                                    15870000
              while(i:=i+1)<n do  <<find csldtx entry>>                 15875000
                @csldtx := @csldtx+csldtx;                              15880000
              ascii(csldtxhsi'chan,10,binbuf(4));<<port mask>>          15885000
              if ldt'device'type=csdev17 then                  <<06762>>15890000
                begin                                          <<01165>>15895000
                binbuf(7):="X"; binbuf(12):="X";               <<01165>>15900000
                binbuf(15):="X";                               <<01165>>15905000
                end                                            <<01165>>15910000
              else                                             <<01165>>15915000
                begin                                          <<01165>>15920000
              ascii(csldtxprotocol,10,binbuf(7)); <<protocol>>          15925000
              ascii(csldtxmode,10,binbuf(12)); <<local mode>>           15930000
              ascii(csldtxcode,10,binbuf(15));  <<transmission code>>   15935000
                end;                                           <<01165>>15940000
              ascii(csldtxrecv'timeout,10,binbuf(18));                  15945000
                                 <<receive timeout>>                    15950000
              ascii(csldtxlocal'timeout,10,binbuf(24));                 15955000
                                 <<local timeout>>                      15960000
              ascii(csldtxconct'timeout,10,binbuf(30));                 15965000
                                 <<connect timeout>>                    15970000
              if logical(csldtxdial) then binbuf(36):="O";              15975000
              if 1<=csldtxanswer<=2 then binbuf(37):="I";               15980000
              if csldtxanswer=autoanswer then binbuf(38):="A";          15985000
              if logical(csldtxdual'speed) then                         15990000
                begin                                                   15995000
                binbuf(39) := "D";                                      16000000
                if logical(csldtxhalf'speed) then binbuf(40):="H";      16005000
                end;                                                    16010000
              if logical(csldtxspeedchngble) then binbuf(41):="C";      16015000
              @dblptr := @csldtxinspeed;                       <<06813>>16020000
              dascii(dblptr,10,binbuf(43));                    <<06813>>16025000
              ascii(csldtxxmsnmode,10,binbuf(54));                      16030000
              ascii(csldtxpbuffsize,10,binbuf(57));                     16035000
              if logical(csldtxdvrchangable) then binbuf(63):="Y"       16040000
                else binbuf(63):="N";                                   16045000
              ascii(csldtxdoptions,10,binbuf(66));                      16050000
              fwrite(listfnum,inbuf,-72,0);                             16055000
              if <> then go listerr;                                    16060000
              if switched then swtched:=true                            16065000
                else if nonswitched and supervised                      16070000
                     then nonswtched:=true;                             16075000
              end;                                                      16080000
            end;                                                        16085000
          fwrite(listfnum,inbuf,0,%61);                                 16090000
          if <> then go listerr;                                        16095000
          if swtched then                                               16100000
            begin  <<switched devices present>>                         16105000
            move inbuf:=swhed1,(24);                                    16110000
            fwrite(listfnum,inbuf,-48,0);                               16115000
            if <> then go listerr;                                      16120000
            move inbuf:=swhed2,(26);                                    16125000
            fwrite(listfnum,inbuf,-52,0);                               16130000
            if <> then go listerr;                                      16135000
            ldev := 0;                                                  16140000
            while(ldev:=ldev+1)<=hldev do                               16145000
              begin                                            <<06762>>16150000
              get'ldev'entries(ldev);                          <<06762>>16155000
              if csdevice then                                 <<06762>>16160000
                if lpdt'subtype=0 then                         <<06762>>16165000
                  begin   <<switched device>>                           16170000
                  inbuf := "  ";                                        16175000
                  move inbuf(1):=inbuf,(35);                            16180000
                  ascii(ldev,10,binbuf);                                16185000
                  @csldtx := @cstab+csxstart;                           16190000
                  i:=-1;                                                16195000
                  while(i:=i+1)<csdef(ldev) do                          16200000
                    @csldtx := @csldtx+csldtx;                          16205000
                  ascii(0,10,binbuf(4));<<control size>>       <<00.06>>16210000
                  if csldtxphlistptr<>0 then                            16215000
                    begin <<point to phone list>>                       16220000
                    @phone:=(@csldtx+csldtxphlistptr)&lsl(1);  <<03704>>16225000
                                    <<byte pointer to phone list>>      16230000
                    nump := phone(numseq);  <<# of phone sequences>>    16235000
                    end                                                 16240000
                  else nump:=0;                                         16245000
                  if csldtxidlistptr<>0 then                            16250000
                    begin                                               16255000
                    @idlist :=(@csldtx+csldtxidlistptr)&lsl(1);<<03704>>16260000
                              <<byte pointer to id list>>               16265000
                    nums := idlist(numseq);   <<# of id sequences>>     16270000
                    end                                                 16275000
                  else nums:=0;                                         16280000
                  temp := 0;                                            16285000
                  phinx:=idinx:=3;                                      16290000
                  while((nump>0) or (nums>0)) do                        16295000
                    begin  <<more sequences or a continuation>>         16300000
                    if nump>0 then                                      16305000
                      begin      <<more phone sequences>>               16310000
                      move binbuf(10):=phone(phinx+1),(phone(phinx));   16315000
                      phinx:=phinx+integer(phone(phinx))+1;             16320000
                      nump := nump-1;                                   16325000
                      end;                                              16330000
                    if nums>0 or temp>0 then                            16335000
                      begin      <<more id sequences>>                  16340000
                      if temp>0 then                                    16345000
                        begin <<continuation of sequence>>              16350000
                        n:=(if remote then 35 else 32);                 16355000
                        start := len;                                   16360000
                        len := temp;                                    16365000
                        temp := 0;                                      16370000
                        nums := nums-1;                                 16375000
                        remote := true;                                 16380000
                        end                                             16385000
                      else                                              16390000
                        begin <<new sequences>>                         16395000
                        start := 0;                                     16400000
                        tos := idlist(idinx);                           16405000
                        duplicate;                                      16410000
                        tos := tos land %77;                            16415000
                        len := s0;                                      16420000
                        len1 := tos;                                    16425000
                        type := tos&lsr(6);                             16430000
                        if type=otyp then octtoasci                     16435000
                           (idlist(idinx+1),outtemp,len)                16440000
                        else if type=htyp then hextoasci                16445000
                                (idlist(idinx+1),outtemp,len)           16450000
                             else                                       16455000
                               begin                                    16460000
                               if type=etyp then                        16465000
                                 begin                                  16470000
                                 outtemp := "E";                        16475000
                                 convert(0,idlist(idinx+1),             16480000
                                         outtemp(2),len);               16485000
                                 end                                    16490000
                               else                                     16495000
                                 begin                                  16500000
                                 outtemp := "A";                        16505000
                                 move outtemp(2):=idlist                16510000
                                      (idinx+1),(len);                  16515000
                                 end;                                   16520000
                               outtemp(1):=outtemp(len+2):=quot;        16525000
                               len := len+3;                            16530000
                               end;                                     16535000
                        idinx := idinx+len1+1;                          16540000
                        if remote then                                  16545000
                          begin                                         16550000
                          n := 34;                                      16555000
                          if len>38 then                                16560000
                            begin                                       16565000
                            temp := len-38;                             16570000
                            len := 38;                                  16575000
                            end                                         16580000
                          else nums:=nums-1;                            16585000
                          end                                           16590000
                        else                                            16595000
                          begin <<local>>                               16600000
                          n := 31;                                      16605000
                          if len>41 then                                16610000
                            begin                                       16615000
                            temp := len-41;                             16620000
                            len := 41;                                  16625000
                            end                                         16630000
                          else                                          16635000
                            begin                                       16640000
                            nums := nums-1;                             16645000
                            remote := true;                             16650000
                            end;                                        16655000
                          end;                                          16660000
                        end; <<new sequences>>                          16665000
                      move binbuf(n):=outtemp(start),(len);             16670000
                      end;<<more id sequences>>                         16675000
                    fwrite(listfnum,inbuf,-72,0);                       16680000
                    if <> then goto listerr;                            16685000
                    inbuf := "  ";                                      16690000
                    move inbuf(1) := inbuf,(35);                        16695000
                    end;<<more sequences or a contiuation>>             16700000
                  remote := false; <<finished with device>>             16705000
                  if csldtxphlistptr=csldtxidlistptr then               16710000
                    begin <<no phone #'s or id sequences>>              16715000
                    fwrite(listfnum,inbuf,-72,0);                       16720000
                    if <> then go listerr;                              16725000
                    end;                                                16730000
                  end; <<switched device>>                              16735000
            end;  << while >>                                  <<06762>>16740000
            fwrite(listfnum,inbuf,0,%61);                               16745000
            if<> then go listerr;                                       16750000
            end; <<switched devices present>>                           16755000
          if nonswtched then                                            16760000
            begin                                                       16765000
            move  inbuf:=nswhed1,(26);                                  16770000
            fwrite(listfnum,inbuf,-52,0);                               16775000
            if <> then go listerr;                                      16780000
            move inbuf:=nswhed2,(17);                                   16785000
            fwrite(listfnum,inbuf,-33,0);                               16790000
            if <> then go listerr;                                      16795000
            inbuf := "  ";                                              16800000
            move inbuf(1):=inbuf,(35);                                  16805000
            ldev := 0;                                                  16810000
            while(ldev:=ldev+1)<=hldev do                               16815000
              begin                                            <<06762>>16820000
              get'ldev'entries(ldev);                          <<06762>>16825000
              if csdevice then                                 <<06762>>16830000
                if lpdt'subtype<>0 and                         <<l8585>>16835000
                   lpdt'subtype<>9 then                        <<l8585>>16840000
                  begin  <<nonswitched device>>                         16845000
                  @csldtx := @cstab+csxstart;                           16850000
                  i:=-1;                                                16855000
                  while(i:=i+1)<csdef(ldev) do                          16860000
                    @csldtx := @csldtx+csldtx;                          16865000
                  if not(supervised) then goto nextnsw;                 16870000
                  tos := @csldtx+csldtxcontptr;                         16875000
                  @control  := s0;                                      16880000
                  if controlst then @cntrlseq :=               <<03704>>16885000
                     (tos+conseqstart)&lsl(1)                  <<03704>>16890000
                  else @cntrlseq:=(tos+1)&lsl(1); <<tributary>><<03704>>16895000
                  cinx := 0;                                            16900000
                  ascii(ldev,10,binbuf);                                16905000
                  if tributary then                                     16910000
                    begin                                               16915000
                    ascii(n:=control.(8:8),10,binbuf(26));              16920000
                    go around;                                          16925000
                    end;                                                16930000
                  ascii(control(intcomdelay),10,binbuf(4));             16935000
                  ascii(control,10,binbuf(10));                         16940000
                  ascii(control(cirpdelay),10,binbuf(16));              16945000
                  tos := 0;                                             16950000
                  tos:=(control(numcomp)+control(remostat)-1)/          16955000
                        control(remostat);                              16960000
                  ascii(*,10,binbuf(22));                               16965000
                  ascii((n:=control(numcomp)),10,binbuf(26));           16970000
  around:         nums := 0;                                            16975000
                  while(nums:=nums+1)<=n do                             16980000
                    begin                                               16985000
                    tos:=0;                                             16990000
                    tos := cntrlseq(cinx); <<sequence type>>            16995000
                    tos := tos land 3;                                  17000000
                    ascii(*,10,binbuf(30));                             17005000
                    tos := cntrlseq(cinx);                              17010000
                    tos:=tos&lsr(2);                                    17015000
                    if tos>0 then binbuf(32):="Y"                       17020000
                      else binbuf(32):="N";                             17025000
                    tos := cntrlseq(cinx+1);                            17030000
                    duplicate;                                          17035000
                    type := tos&lsr(6);                                 17040000
                    tos := tos land %77;                                17045000
                    len1 := len := tos;                                 17050000
                    if type=otyp then octtoasci                         17055000
                       (cntrlseq(cinx+2),binbuf(34),len)                17060000
                    else if type=htyp then hextoasci                    17065000
                            (cntrlseq(cinx+2),binbuf(34),len)           17070000
                         else                                           17075000
                           begin                                        17080000
                           if type=etyp then                            17085000
                             begin                                      17090000
                             binbuf(34) := "E";                         17095000
                             convert(0,cntrlseq(cinx+2),                17100000
                                     binbuf(36),len);                   17105000
                             end                                        17110000
                           else                                         17115000
                             begin                                      17120000
                             binbuf(34) := "A";                         17125000
                             move binbuf(36):=                          17130000
                                  cntrlseq(cinx+2),(len);               17135000
                             end;                                       17140000
                           binbuf(35):=binbuf(len+36):=quot;            17145000
                           end;                                         17150000
                    cinx:=cinx+len1+2;                                  17155000
                    fwrite(listfnum,inbuf,-72,0);                       17160000
                    if<> then go listerr;                               17165000
                    inbuf:="  ";                                        17170000
                    move inbuf(1):=inbuf,(35);                          17175000
                    end;                                                17180000
  nextnsw:        end;                                                  17185000
            end;  << while >>                                  <<06762>>17190000
            fwrite(listfnum,inbuf,0,%61);                               17195000
            if <> then go listerr;                                      17200000
            end;                                                        17205000
          end <<listcsdev>>;                                            17210000
$control segment=iochange1                                              17215000
  <<------------------------------------>>                     <<*7657>>17220000
  << list the termtype descriptor files >>                     <<*7657>>17225000
  <<------------------------------------>>                     <<*7657>>17230000
                                                               <<*7657>>17235000
procedure list'ttdt;                                           <<*7657>>17240000
                                                               <<*7657>>17245000
comment                                                        <<*7657>>17250000
  lists the termtype descriptor files followed by a list of    <<*7657>>17255000
  ldevs that use that file;                                    <<*7657>>17260000
                                                               <<*7657>>17265000
  begin                                                        <<*7657>>17270000
  integer array hed1(0:17)=pb:=                                <<*7657>>17275000
    "  FILE                       LOGICAL";                    <<*7657>>17280000
  integer array hed2(0:17)=pb:=                                <<*7657>>17285000
    "  NAME                       DEVICES";                    <<*7657>>17290000
  integer                                                      <<*7657>>17295000
    i,                                                         <<*7657>>17300000
    k;                                                         <<*7657>>17305000
  integer  bindx := 29;                                        <<*7657>>17310000
  move inbuf := hed1,(18);                                     <<*7657>>17315000
  fwrite(listfnum,inbuf,-36,0);                                <<*7657>>17320000
listerr:                                                       <<*7657>>17325000
  if <> then ferror(listfnum,listfile);                        <<*7657>>17330000
  move inbuf := hed2,(18);                                     <<*7657>>17335000
  fwrite(listfnum,inbuf,-36,0);                                <<*7657>>17340000
  if <> then goto listerr;                                     <<*7657>>17345000
  i := 0;                                                      <<*7657>>17350000
  @tdt := @dct'head + dcth'tdt'base;                           <<*7657>>17355000
  @tdt'b := @tdt & lsl(1);                                     <<*7657>>17360000
  while (i:=i+1) <= dcth'num'tdt'entries do                    <<*7657>>17365000
    begin                                                      <<*7657>>17370000
    fill'(binbuf,80," ");                                      <<*7657>>17375000
    move binbuf := tdtb'file'name,(8);                         <<*7657>>17380000
    move binbuf(8) := ".";                                     <<*7657>>17385000
    move binbuf(9) := tdtb'group'name,(8);                     <<*7657>>17390000
    move binbuf(17) := ".";                                    <<*7657>>17395000
    move binbuf(18) := tdtb'acct'name,(8);                     <<*7657>>17400000
    k := 0;                                                    <<*7657>>17405000
    while (k:=k+1) <= tdt'num'devices do                       <<*7657>>17410000
      begin                                                    <<*7657>>17415000
      ldev := tdt(tdt'first'ldev + k);                         <<*7657>>17420000
      if (ldev>99) and (bindx>69) or                           <<*7657>>17425000
         (ldev>9)  and (bindx>70) or                           <<*7657>>17430000
         (bindx>71) then                                       <<*7657>>17435000
        begin  <<won't fit on this line>>                      <<*7657>>17440000
        fwrite(listfnum,inbuf,-72,0);                          <<*7657>>17445000
        if <> then goto listerr;                               <<*7657>>17450000
        bindx := 29;                                           <<*7657>>17455000
        fill'(binbuf,80," ");                                  <<*7657>>17460000
        end;                                                   <<*7657>>17465000
      m := ascii(ldev,10,binbuf(bindx));                       <<*7657>>17470000
      bindx := bindx + m;                                      <<*7657>>17475000
      if k < tdt'num'devices then                              <<*7657>>17480000
        begin                                                  <<*7657>>17485000
        binbuf(bindx) := ",";                                  <<*7657>>17490000
        bindx := bindx + 1;                                    <<*7657>>17495000
        end;                                                   <<*7657>>17500000
      end;                                                     <<*7657>>17505000
    fwrite(listfnum,inbuf,-bindx,0);                           <<*7657>>17510000
    if <> then goto listerr;                                   <<*7657>>17515000
    @tdt := @tdt + tdt'next'entry;                             <<*7657>>17520000
    @tdt'b := @tdt & lsl(1);                                   <<*7657>>17525000
    bindx := 29;                                               <<*7657>>17530000
    end;                                                       <<*7657>>17535000
  fwrite(listfnum,inbuf,0,%61);                                <<*7657>>17540000
  if <> then goto listerr;                                     <<*7657>>17545000
end; <<list'ttdt>>                                             <<*7657>>17550000
$control segment=iochange                                      <<01073>>17555000
                                                                        17560000
          <<----------------                                            17565000
            get class name                                              17570000
          ---------------->>                                            17575000
  procedure clname(clindex,name);                                       17580000
    value clindex;                                                      17585000
    integer clindex;                                                    17590000
    byte array name;                                                    17595000
    option privileged,uncallable;                                       17600000
      begin                                                             17605000
        integer i:=0;                                                   17610000
          @dct := @dct'head + dcth'dct'base;                   <<06762>>17615000
          while (i:=i+1) < clindex do                                   17620000
            @dct := @dct + dct'next'entry;                     <<06762>>17625000
          @dct'b := @dct & lsl(1);                             <<06762>>17630000
          move name := dctb'class'name,(8);                    <<06762>>17635000
      end <<clname>> ;                                                  17640000
  logical procedure name'found(dev'name);                      <<t8393>>17645000
  byte array dev'name;                                         <<t8393>>17650000
  begin                                                        <<t8393>>17655000
     logical found = name'found;                               <<t8393>>17660000
     integer                                                   <<t8393>>17665000
             i;                                                <<t8393>>17670000
                                                               <<t8393>>17675000
     @tl'ent := @tl'buf;                                       <<t8393>>17680000
     @tl'entb := @tl'ent & lsl(1);                             <<t8393>>17685000
     found := false;                                           <<t8393>>17690000
     i := 0;                                                   <<t8393>>17695000
     while (i := i + 1) <= tlh'num'entries and not found do    <<t8393>>17700000
        if tl'dev'name = dev'name,(16)                         <<t8393>>17705000
           then found := true                                  <<t8393>>17710000
        else                                                   <<t8393>>17715000
           begin                                               <<t8393>>17720000
           @tl'ent := @tl'ent + tl'ent'size;                   <<t8393>>17725000
           @tl'entb := @tl'ent &lsl(1);                        <<t8393>>17730000
           end;                                                <<t8393>>17735000
  end;                                                         <<t8393>>17740000
$control segment=iochange1                                              17745000
                                                                        17750000
   <<--------------                                                     17755000
     list classes                                                       17760000
   -------------->>                                                     17765000
   procedure listclasses;                                               17770000
   <<lists device classes followed class type and logical dev. #'s>>    17775000
     begin                                                              17780000
       integer array hed1(0:13)=pb:=                                    17785000
           "  CLASS     ACCESS  LOGICAL ";                              17790000
       integer array hed2(0:13)=pb:=                                    17795000
           "  NAME      TYPE    DEVICES ";                              17800000
       integer bindx:=20;                                      <<06762>>17805000
          @dct := @dct'head + dcth'dct'base;                   <<06762>>17810000
          @dct'b := @dct & lsl(1);                             <<06762>>17815000
          move inbuf := hed1,(14);                                      17820000
          fwrite(listfnum,inbuf,-27,0);                                 17825000
   listerr:if <> then ferror(listfnum,listfile);                        17830000
          move inbuf := hed2,(14);                                      17835000
          fwrite(listfnum,inbuf,-27,0);                                 17840000
          if <> then go listerr;                                        17845000
          i := -1;                                                      17850000
          while (i:=i+1) < dcth'num'dct'entries do             <<06762>>17855000
            begin                                                       17860000
            inbuf := "  ";                                              17865000
            move inbuf(1):=inbuf,(35);                                  17870000
            move binbuf:= dctb'class'name,(8);                 <<06762>>17875000
            tos := dct'class'acc'type;                         <<06762>>17880000
            tos := tos land 7;                                          17885000
            if tos <> 0 then                                   <<06762>>17890000
              begin <<all devices are discs of some kind >>    <<06762>>17895000
              if dct'class'acc'type = ldt'serial'disc then     <<06762>>17900000
                 move binbuf(12):="SD"                         <<06762>>17905000
              else                                             <<sd.00>>17910000
              if dct'class'acc'type = ldt'foreign'disc then    <<06762>>17915000
                 move binbuf(12):="FD"                         <<06762>>17920000
              else                                             <<01115>>17925000
                 ascii(dct'class'acc'type,10,binbuf(12))       <<06762>>17930000
              end                                                       17935000
            else                                                        17940000
              case dct'access'type of                          <<06762>>17945000
                begin                                                   17950000
                move binbuf(12):="DA";                                  17955000
                move binbuf(12):="IN";                                  17960000
                move binbuf(12):="I/O,C";                               17965000
                move binbuf(12):="I/O,NC";                              17970000
                move binbuf(12):="OUT";                                 17975000
                end;                                                    17980000
            if dct'num'devices <> 0 then                       <<06762>>17985000
              begin                                                     17990000
              k := -1;                                         <<06762>>17995000
              while (k:=k+1) < dct'num'devices do              <<06762>>18000000
                begin                                                   18005000
                ldev := dct(dct'first'ldev + k);               <<06762>>18010000
                if (ldev>99) and (bindx>69) or                          18015000
                   (ldev>9) and (bindx>70) or (bindx>71)                18020000
                then                                                    18025000
                  begin <<won't fit on this line>>                      18030000
                  fwrite(listfnum,inbuf,-72,0);                         18035000
                  if<>then go listerr;                                  18040000
                  bindx := 20;                                          18045000
                  inbuf := "  ";                                        18050000
                  move inbuf(1):=inbuf,(35);                            18055000
                  end;                                                  18060000
                m := ascii(ldev,10,binbuf(bindx));                      18065000
                bindx := bindx + m;                                     18070000
                if k < (dct'num'devices-1) then                <<06762>>18075000
                  begin                                                 18080000
                  binbuf(bindx) := ",";                                 18085000
                  bindx :=bindx+1;                                      18090000
                  end;                                                  18095000
                end;                                                    18100000
              fwrite(listfnum,inbuf,-bindx,0);                          18105000
              if <> then go listerr;                                    18110000
              end;                                                      18115000
            @dct := @dct + dct'next'entry;                     <<06762>>18120000
            @dct'b := @dct & lsl(1);                           <<06762>>18125000
            bindx := 20;                                                18130000
            end;                                                        18135000
          fwrite(listfnum,inbuf,0,%61);                                 18140000
          if <> then go listerr;                                        18145000
     end  <<listclasses>>;                                              18150000
$control segment=iochange1                                              18155000
procedure list'defaults;                                       <<t8393>>18160000
   option privileged,uncallable;                               <<t8393>>18165000
   comment                                                     <<t8393>>18170000
      prints a listing of the default devices supported on the <<t8393>>18175000
      device;                                                  <<t8393>>18180000
   begin                                                       <<t8393>>18185000
   integer array head1(0:39)=pb:=                              <<t8393>>18190000
     "DEVICE          ID    C T  SUB          REC OUTPUT   ",  <<s8966>>18195000
     "       DRIVER   DEVICE    ";                             <<t8393>>18200000
   integer array head2(0:39)=pb:=                              <<t8393>>18205000
     "NAME           CODE   H Y  TYPE        WIDTH DEV      ", <<t8393>>18210000
     "MODE     NAME    CLASSES   ";                            <<s8966>>18215000
   integer array head3(0:8)=pb:=                               <<t8393>>18220000
       "A P      TERMINAL ";                                   <<t8393>>18225000
   integer array head4(0:8)=pb:=                               <<t8393>>18230000
       "N E     TYPE SPEED";                                   <<t8393>>18235000
   integer                                                     <<t8393>>18240000
       i,                                                      <<t8393>>18245000
       j,                                                      <<t8393>>18250000
       speedcde,                                               <<t8393>>18255000
       tspeed;                                                 <<t8393>>18260000
   logical                                                     <<t8393>>18265000
       firstclass;                                             <<t8393>>18270000
   double                                                      <<d8821>>18275000
       dblptr;                                                 <<d8821>>18280000
   integer                                                     <<d8952>>18285000
       name'ptr;                                               <<t8393>>18290000
   move inbuf := head1,(40);                                   <<t8393>>18295000
   print(inbuf,-78,0);                                         <<t8393>>18300000
   move inbuf := head2,(40);                                   <<t8393>>18305000
   print(inbuf,-78,0);                                         <<t8393>>18310000
   fill'(binbuf,80," ");                                       <<t8393>>18315000
   move inbuf(11) := head3,(9);                                <<t8393>>18320000
   print(inbuf,-78,0);                                         <<t8393>>18325000
   fill'(binbuf,80," ");                                       <<t8393>>18330000
   move inbuf(11) := head4,(9);                                <<t8393>>18335000
   print(inbuf,-78,0);                                         <<t8393>>18340000
   @tl'ent := @tl'buf ;                                        <<t8393>>18345000
   @tl'entb := @tl'ent & lsl(1);                               <<t8393>>18350000
   j := 0;                                                     <<t8393>>18355000
   while (j := j + 1) <= tlh'num'entries do                    <<t8393>>18360000
      begin                                                    <<t8393>>18365000
      fill'(binbuf,80," ");                                    <<t8393>>18370000
      move binbuf := tl'dev'name,(12);                         <<d8821>>18375000
      tos := 0; tos := tl'id'code; dblptr := ds0;              <<d8821>>18380000
      move binbuf(14) := "!";                                  <<d8821>>18385000
      hexout(dblptr,binbuf(15), 4);                            <<d8821>>18390000
      ascii(tl'chan'num,10,binbuf(22));<<channel#>>            <<t8393>>18395000
      ascii(tl'dev'type,10,binbuf(24));<<type>>                <<t8393>>18400000
      ascii(tl'dev'subtype,10,binbuf(27));<<subtype>>          <<t8393>>18405000
      i := tl'dev'subtype;  <<dev. subtype>>                   <<t8393>>18410000
      if tl'dev'type = 16 or                                   <<t8393>>18415000
         tl'dev'type = 32 and                                  <<t8393>>18420000
         ( i=14 or i=15) then                                  <<t8393>>18425000
         begin <<terminal>>                                    <<t8393>>18430000
         if tl'term'type=%37 then                              <<t8393>>18435000
            move binbuf(32) := "??"                            <<t8393>>18440000
         else ascii(tl'term'type,10,binbuf(32));               <<t8393>>18445000
         if tl'ttdf'ptr <>  0 then                             <<t8393>>18450000
            binbuf(34) := "*";   <<there is a ttdf ref>>       <<t8393>>18455000
          speedcde := tl'term'speed;                           <<t8393>>18460000
          tspeed := -1;                                        <<t8393>>18465000
          checkspeed(tspeed,speedcde);                         <<t8393>>18470000
          if speedcde = 0 then                                 <<t8393>>18475000
             move binbuf(36) := "??"                           <<t8393>>18480000
          else ascii(tspeed,10,binbuf(36));                    <<t8767>>18485000
         end;                                                  <<t8393>>18490000
      ascii(tl'rec'width,10,binbuf(40));                       <<t8393>>18495000
      if logical(tl'def'out'class) then                        <<t8393>>18500000
         begin    <<output device is class index>>             <<t8393>>18505000
         name'ptr := tl'def'out'dev & lsl(1);                  <<t8393>>18510000
         move binbuf(44) := tl'entb(name'ptr),(8);             <<t8393>>18515000
         end                                                   <<t8393>>18520000
       else if tl'def'out'dev = -1                             <<t8393>>18525000
               then binbuf(46) := "&"                          <<t8393>>18530000
      else ascii(tl'def'out'dev,10,binbuf(46));                <<t8393>>18535000
      if logical(tl'job'accept) then binbuf(53):="J";          <<s8966>>18540000
              <<accept jobs/sessions>>                         <<t8393>>18545000
      if logical(tl'data'accept) then binbuf(54):="A";         <<s8966>>18550000
               <<accept data>>                                 <<t8393>>18555000
      if logical(tl'interactive) then binbuf(55):="I";         <<s8966>>18560000
                  <<interactive>>                              <<t8393>>18565000
      if logical(tl'duplicative) then binbuf(56):="D";         <<s8966>>18570000
                  <<duplicative>>                              <<t8393>>18575000
      if tl'spool'state<>0 then binbuf(57) := "S";             <<s8966>>18580000
      if logical(tl'auto'reply) then binbuf(58) := "R";        <<s8966>>18585000
      if logical(tl'core'res) then binbuf(60):="*";            <<t8393>>18590000
                  <<core resident driver>>                     <<t8393>>18595000
      move binbuf(61) := tl'driver'name,(8); <<driver name>>   <<t8393>>18600000
      firstclass := true;                                      <<t8393>>18605000
      name'ptr := tl'dev'class'ptr & lsl(1);                   <<t8393>>18610000
      i := 0;                                                  <<t8393>>18615000
      while (i:=i+1) <= tl'num'dev'class do                    <<t8393>>18620000
         begin                                                 <<t8393>>18625000
         if firstclass then firstclass := false                <<t8393>>18630000
         else                                                  <<t8393>>18635000
            begin                                              <<t8393>>18640000
            print(inbuf,-78,0);                                <<t8393>>18645000
            fill'(binbuf,80," ");                              <<t8393>>18650000
            end;                                               <<t8393>>18655000
         move binbuf(70) := tl'entb(name'ptr),(8);             <<t8393>>18660000
                <<move device class to buffer>>                <<t8393>>18665000
         name'ptr := name'ptr + 8;                             <<t8393>>18670000
         end;                                                  <<t8393>>18675000
      print(inbuf,-78,0);                                      <<t8393>>18680000
      @tl'ent := @tl'ent + tl'ent'size;                        <<t8393>>18685000
      @tl'entb := @tl'ent & lsl(1);                            <<t8393>>18690000
   end;  << while >>                                           <<t8393>>18695000
   print(inbuf,0,%61);                                         <<t8393>>18700000
   end <<list'defaults>>;                                      <<t8393>>18705000
$control segment=iochange1                                     <<06068>>18710000
                                                                        18715000
          <<-----------------                                           18720000
            list i/o devices                                            18725000
          ------------------>>                                          18730000
  procedure listiodev;                                                  18735000
    option privileged,uncallable;                                       18740000
    comment                                                             18745000
      prints a listing of the i/o device configuration on the job       18750000
    list device;                                                        18755000
      begin                                                             18760000
        integer array head1(0:34)=pb:=                                  18765000
         "LOG DRT U  C T SUB              REC   OUTPUT ",      <<03007>>18770000
         "MODE    DRIVER   DEVICE ";                           <<s8966>>18775000
        integer array head2(0:35)=pb:=                                  18780000
         "DEV  #  N  H Y TYPE  TERMINAL   WIDTH  DEV ",        <<03007>>18785000
         "           NAME    CLASSES ";                                 18790000
        integer array head3(0:15)=pb:=                         <<03007>>18795000
         " #      I  A P      TYPE SPEED  ";                   <<03702>>18800000
        integer array head4(0:6)=pb:=                          <<00.06>>18805000
         "        T  N E";                                     <<00.06>>18810000
        integer tspeed,                                        <<03702>>18815000
                speedcde;                                      <<03702>>18820000
        logical firstclass;                                             18825000
        integer i;                                             <<02509>>18830000
           move inbuf := head1,(35);                                    18835000
           fwrite(listfnum,inbuf,-69,0);                                18840000
  listerr:if <> then ferror(listfnum,listfile);                         18845000
           move inbuf := head2,(35);                                    18850000
           fwrite(listfnum,inbuf,-70,0);                                18855000
          if <> then goto listerr;                                      18860000
          move inbuf := head3,(16);                            <<03007>>18865000
          fwrite(listfnum,inbuf,-32,0);                        <<03007>>18870000
          if <> then goto listerr;                             <<00.06>>18875000
          move inbuf:=head4,(7);                               <<00.06>>18880000
          fwrite(listfnum,inbuf,-14,0);                        <<00.06>>18885000
          if <> then goto listerr;                             <<00.06>>18890000
          ldev:=0;                                                      18895000
          while (ldev:=ldev+1) <= hldev do                              18900000
          begin                                                <<06762>>18905000
          get'ldev'entries(ldev);                              <<06762>>18910000
          drtn := dvrdrtnum;                                   <<06762>>18915000
          unitn := dvrunitnum;                                 <<06762>>18920000
          if drtn<>0 or unitn<>0                               <<06762>>18925000
              or dvrdsbit=1 <<ds dev>>                         <<06762>>18930000
          then begin                                           <<03006>>18935000
              inbuf:="  ";                                              18940000
              move inbuf(1) := inbuf,(35);   <<blank out buffer>>       18945000
              ascii(ldev,10,binbuf);  <<logical device #>>              18950000
              if dvrdsbit=1  then                              <<06762>>18955000
                begin  <<ds device>>                                    18960000
                binbuf(3) := "#";                                       18965000
                ascii(dvrmasterldev,10,binbuf(4));             <<06762>>18970000
                end                                                     18975000
              else ascii(drtn,10,binbuf(4)); <<drt #>>         <<06762>>18980000
              ascii(unitn,10,binbuf(8));   <<unit #>>          <<06762>>18985000
              ascii(dvrchannum,10,binbuf(11));<<channel#>>     <<06762>>18990000
              ascii(ldt'device'type,10,binbuf(13));<<type>>    <<06762>>18995000
              ascii(lpdt'subtype,10,binbuf(16));<<subtype>>    <<06762>>19000000
              i := lpdt'subtype;  <<dev. subtype>>             <<06762>>19005000
              if ldt'device'type = termdevtype or              <<06762>>19010000
                 ldt'device'type = 32 and                      <<06762>>19015000
                 ( i=14 or i=15) then                          <<03007>>19020000
                begin <<terminal>>                             <<00.06>>19025000
                if ldt'dflt'term'type=%37 then                 <<06762>>19030000
                  move binbuf(21) := "??"                      <<03702>>19035000
                else ascii(ldt'dflt'term'type,10,binbuf(21));  <<06762>>19040000
                if ldtx'tdt'offset <> -1 then                  <<06762>>19045000
                  binbuf(23) := "*";   <<there is a ttdf ref>> <<06068>>19050000
                speedcde := ldtx'baud'rate'code;<<speed code>> <<06762>>19055000
                                                               <<03702>>19060000
                tspeed := -1;       << set parameter for >>    <<03702>>19065000
                                    <<    checkspeed     >>    <<03702>>19070000
                checkspeed(tspeed,speedcde);  <<convert code>> <<03702>>19075000
                                              <<   to speed >> <<03702>>19080000
                if speedcde = 0 then                           <<03702>>19085000
                   move binbuf(26) := "??"                     <<03702>>19090000
                else                           << convert to>> <<03702>>19095000
                   ascii(tspeed,10,binbuf(26));  <<  ascii  >> <<03702>>19100000
                                                               <<03702>>19105000
                end;                                           <<03702>>19110000
              ascii(ldt'record'width,10,binbuf(33));           <<06762>>19115000
              if logical(ldt'class'index) then                 <<06762>>19120000
                begin    <<output device is class index>>               19125000
                  tos := ldt'dflt'out'class;                   <<06762>>19130000
                  if = then del                                         19135000
                  else clname(*,binbuf(38));                            19140000
                end                                                     19145000
              else ascii(ldt'dflt'out'class,10,binbuf(40));    <<06762>>19150000
              if logical(ldtx'seek'ahead) then binbuf(45):="E";<<s8966>>19155000
              if logical(lpdt'job'accept) then binbuf(46):="J";<<s8966>>19160000
                      <<accept jobs/sessions>>                          19165000
            if logical(lpdt'data'accept) then binbuf(47):="A"; <<s8966>>19170000
                          <<accept data>>                               19175000
            if logical(lpdt'interactive) then binbuf(48):="I"; <<s8966>>19180000
                                      <<interactive>>                   19185000
              if logical(lpdt'duplicative)                     <<06762>>19190000
                then binbuf(49):="D";                          <<s8966>>19195000
                                      <<duplicative>>                   19200000
              if ldt'spool'state<>0 then binbuf(50) := "S";    <<s8966>>19205000
              if logical(lpdt'auto'alloc) then binbuf(51):="R";<<s8966>>19210000
              if logical(dvrcoreres) then binbuf(53):="*";     <<06762>>19215000
                                      <<core resident driver>>          19220000
              tos := @binbuf(54);                                       19225000
              tos := @dvrname&lsl(1);                          <<06762>>19230000
              move * := *,(8); <<driver name>>                          19235000
              firstclass := true;                                       19240000
              i := 0;                                                   19245000
              @dct := @dct'head+dcth'dct'base;                 <<06762>>19250000
              @dct'b := @dct & lsl(1);                         <<06762>>19255000
              while (i:=i+1) <= dcth'num'dct'entries do        <<06762>>19260000
                begin   <<scan device classes>>                         19265000
                  j := -1;                                     <<06762>>19270000
                  while (j:=j+1) < dct'num'devices do          <<06762>>19275000
                  if dct(dct'first'ldev + j) = ldev then       <<06762>>19280000
                    begin    <<device is in this class>>                19285000
                      if firstclass then firstclass := false            19290000
                      else                                              19295000
                        begin                                           19300000
                          fwrite(listfnum,inbuf,36,0);                  19305000
                          if <> then goto listerr;                      19310000
                          inbuf := "  ";                                19315000
                          move inbuf(1) := inbuf,(35);  <<blank buffer>>19320000
                        end;                                            19325000
                      move binbuf(63) := dctb'class'name,(8);  <<06762>>19330000
                                         <<move device class to buffer>>19335000
                    end;                                                19340000
                  @dct := @dct + dct'next'entry;               <<06762>>19345000
                  @dct'b := @dct & lsl(1);                     <<06762>>19350000
                end;                                                    19355000
              fwrite(listfnum,inbuf,36,0);                              19360000
              if <> then goto listerr;                                  19365000
            end;                                                        19370000
          end;  << while >>                                    <<06762>>19375000
          fwrite(listfnum,inbuf,0,%61);                                 19380000
          if <> then goto listerr;                                      19385000
      end <<listiodev>>;                                                19390000
$control segment=iochange                                      <<01073>>19395000
                                                                        19400000
  procedure putintempclass(devclass,ldev);                     <<06812>>19405000
  value ldev;                                                  <<06812>>19410000
  byte array devclass;                                         <<06812>>19415000
  integer ldev;                                                <<00.03>>19420000
  option forward;                                              <<00.03>>19425000
                                                               <<00.03>>19430000
          <<--------------------------------                            19435000
            remove device class references                              19440000
          -------------------------------->>                            19445000
  procedure removeclassrefs;                                            19450000
    option privileged,uncallable;                                       19455000
    comment                                                             19460000
      remove references to logical device ldev from device class table; 19465000
      begin                                                             19470000
        integer i:=0,        <<device class number>>           <<06762>>19475000
                j,                   <<index within class>>             19480000
                k,           <<logical device number index>>   <<06762>>19485000
                count;       << number of words to move   >>   <<06762>>19490000
          @dct := @dct'head + dcth'dct'base;                   <<06762>>19495000
          @dct'b := @dct & lsl(1);                             <<06762>>19500000
          while(i:=i+1) <= dcth'num'dct'entries do             <<06762>>19505000
            begin                                                       19510000
              j := -1;                                         <<06762>>19515000
              while (j:=j+1) < dct'num'devices do              <<06762>>19520000
              if dct(dct'first'ldev + j) = ldev then           <<06762>>19525000
                  if dct'num'devices = 1 then                  <<06762>>19530000
                    begin  <<class must be removed>>                    19535000
                      move devclass:=dctb'class'name,(8);      <<06762>>19540000
                                                               <<06762>>19545000
                      << move the rest of the table >>         <<06762>>19550000
                                                               <<06762>>19555000
                      count := (@dct'head+dcth'tdt'base) -     <<*7657>>19560000
                                 (@dct+dct'next'entry);        <<*7657>>19565000
                                                               <<06762>>19570000
                      move dct := dct(dct'next'entry),(count); <<06762>>19575000
                                                               <<06762>>19580000
                      dctabincr := dctabincr - 7;              <<06762>>19585000
                      dcth'num'dct'entries :=                  <<06762>>19590000
                           dcth'num'dct'entries - 1;           <<06762>>19595000
                      dcth'segment'size:=dcth'segment'size-7;  <<06762>>19600000
                      dcth'tdt'base := dcth'tdt'base - 7;      <<06762>>19605000
                      movedltables;                            <<06812>>19610000
                      @dct := @dct + 7;                        <<06812>>19615000
                      @dct'b := @dct & lsl(1);                 <<06812>>19620000
                      k := 0;                                           19625000
                      while (k:=k+1)<=hldev do <<search ldt for class>> 19630000
                        begin                                  <<06762>>19635000
                        get'ldev'entries(k);                   <<06762>>19640000
                        if logical(ldt'class'index) then       <<06762>>19645000
                          begin <<output device is class>>     <<06762>>19650000
                          tos := ldt'dflt'out'class;  <<index>><<06762>>19655000
                          if s0=i then                         <<00.03>>19660000
                            begin <<outpt dev is deletd clas>> <<00.03>>19665000
                            ldt'dflt'out'class := 0;           <<06762>>19670000
                            putintempclass(devclass,k);        <<06812>>19675000
                            end                                <<00.03>>19680000
                          else if s0>i                         <<06762>>19685000
                            then ldt'dflt'out'class := s0-1;   <<06762>>19690000
                          del;                                          19695000
                          end;                                 <<06762>>19700000
                      put'ldev'entries(k);                     <<06762>>19705000
                      end;                                     <<06762>>19710000
                      i := i-1;  <<one less class>>                     19715000
                      goto nextcl;                                      19720000
                    end                                        <<06762>>19725000
                  else                                         <<06762>>19730000
                    begin                                      <<06762>>19735000
                                                               <<06762>>19740000
                    << remove ldev from class               >> <<06762>>19745000
                    << by moving rest of this class over it >> <<06762>>19750000
                                                               <<06762>>19755000
                      count := dct'num'devices - (j+1);        <<06762>>19760000
                      move dct(dct'first'ldev + j) :=          <<06762>>19765000
                           dct(dct'first'ldev + j + 1),        <<06762>>19770000
                           (count);                            <<06762>>19775000
                                                               <<06762>>19780000
                    << now move the rest of the table >>       <<06762>>19785000
                                                               <<06762>>19790000
                      count := (@dct'head+dcth'tdt'base) -     <<*7657>>19795000
                                 (@dct+dct'next'entry);        <<*7657>>19800000
                      move dct(dct'next'entry - 1) :=          <<06762>>19805000
                           dct(dct'next'entry),(count);       <<<06762>>19810000
                                                               <<06762>>19815000
                      dct'cyclical'ptr := 1;                   <<06762>>19820000
                      dctabincr := dctabincr-1;                <<06762>>19825000
                      dct'num'devices := dct'num'devices - 1;  <<06762>>19830000
                      dcth'segment'size:=dcth'segment'size - 1;<<06762>>19835000
                      dcth'tdt'base := dcth'tdt'base - 1;      <<06762>>19840000
                      movedltables;                            <<06812>>19845000
                      @dct := @dct + 1;                        <<06812>>19850000
                      @dct'b := @dct & lsl(1);                 <<06812>>19855000
                      j := j-1;                                <<06762>>19860000
                    end;                                       <<06762>>19865000
              @dct := @dct + dct'next'entry;                   <<06762>>19870000
              @dct'b := @dct & lsl(1);                         <<06762>>19875000
  nextcl:   end;                                                        19880000
      end <<removeclassrefs>> ;                                         19885000
                                                                        19890000
procedure clean'tclasses;                                      <<06812>>19895000
   begin                                                       <<06812>>19900000
   comment                                                     <<06812>>19905000
     tempclass is a integer array which contains in word zero, <<06812>>19910000
   the number of undefined classes used as output devices and, <<06812>>19915000
   in word 1, the size of tempclass( in words ).  the remainder<<06812>>19920000
   of tempclass in similar to the device class table except    <<06812>>19925000
   the cyclical pointer and the access type are not included in<<06812>>19930000
   tempclass.  the name is followed by the number of devices   <<06812>>19935000
   and the device number's that require this class as an output<<06812>>19940000
   device                                                      <<06812>>19945000
   ;                                                           <<06812>>19950000
                                                               <<06812>>19955000
   << tempclass declarations >>                                <<06812>>19960000
                                                               <<06812>>19965000
   equate                                                      <<06812>>19970000
      temp'first'ldev = 5;                                     <<06812>>19975000
                                                               <<06812>>19980000
   define                                                      <<06812>>19985000
      num'temp'entries    = tempclass'h(0)#,                   <<06812>>19990000
      temp'table'size     = tempclass'h(1)#,                   <<06812>>19995000
      temp'class'name     = tempclass'b(0)#,                   <<06812>>20000000
      num'temp'devices    = tempclass'w(4)#,                   <<06812>>20005000
      next'temp'entry     = num'temp'devices + 5#;             <<06812>>20010000
                                                               <<06812>>20015000
   comment                                                     <<06812>>20020000
     we use tempclass'h to point to the header portion of      <<06812>>20025000
   tempclass and to access those variables associated with     <<06812>>20030000
   the header.  tempclass'w is used to access the current      <<06812>>20035000
   entry and tempclass'b to access the current class name.     <<06812>>20040000
   ;                                                           <<06812>>20045000
                                                               <<06812>>20050000
   integer pointer                                             <<06812>>20055000
      tempclass'h,                                             <<06812>>20060000
      tempclass'w;                                             <<06812>>20065000
                                                               <<06812>>20070000
   byte pointer                                                <<06812>>20075000
      tempclass'b;                                             <<06812>>20080000
                                                               <<06812>>20085000
   integer                                                     <<06812>>20090000
      i,                                                       <<06812>>20095000
      j,                                                       <<06812>>20100000
      l,                                                       <<06812>>20105000
      m;                                                       <<06812>>20110000
                                                               <<06812>>20115000
   byte array e1(0:15)=pb:="UNDEFINED CLASS ";                 <<06812>>20120000
   byte array e2(0:41)=pb:="USED AS OUTPUT DEVICE BY ",        <<06812>>20125000
                           "FOLLOWING DEVICES";                <<06812>>20130000
                                                               <<06812>>20135000
   @tempclass'h := @tclass;                                    <<06812>>20140000
   @tempclass'w := @tempclass'h + 2;                           <<06812>>20145000
   @tempclass'b := @tempclass'w & lsl(1);                      <<06812>>20150000
   i := 0;                                                     <<06812>>20155000
   while (i := i + 1 ) <= num'temp'entries do                  <<06812>>20160000
      begin                                                    <<06812>>20165000
      move binbuf:=e1,(16),2;                                  <<06812>>20170000
      move * := temp'class'name,(8),2;                         <<06812>>20175000
      move * := e2,(44);                                       <<06812>>20180000
      print(inbuf,-67,0);                                      <<06812>>20185000
      j :=-1;                                                  <<06812>>20190000
      m:=l:=0;                                                 <<06812>>20195000
      while (j := j + 1 ) < num'temp'devices do                <<06812>>20200000
         begin                                                 <<06812>>20205000
         l := ascii(tempclass'w(temp'first'ldev+j),10,         <<06812>>20210000
                      binbuf(m));                              <<06812>>20215000
         x := m + l;                                           <<06812>>20220000
         binbuf(x) := ",";                                     <<06812>>20225000
         m := x + 1;                                           <<06812>>20230000
         if m > 69 and j < num'temp'devices then               <<06812>>20235000
            begin                                              <<06812>>20240000
            print(inbuf,-m+1,0);                               <<06812>>20245000
            m := 0;                                            <<06812>>20250000
            end;                                               <<06812>>20255000
         end;                                                  <<06812>>20260000
      @tempclass'w := @tempclass'w + next'temp'entry;          <<06812>>20265000
      @tempclass'b := @tempclass'w & lsl(1);                   <<06812>>20270000
      print(inbuf,-m+1,0);                                     <<06812>>20275000
      end;                                                     <<06812>>20280000
   tclassincr := -(temp'table'size - 2);                       <<06812>>20285000
   movedltables;                                               <<06812>>20290000
   @tempclass'h := @tclass;                                    <<06812>>20295000
   num'temp'entries := 0;                                      <<06812>>20300000
   temp'table'size  := 2;                                      <<06812>>20305000
   end;  << clean tempclass >>                                 <<06812>>20310000
                                                               <<06812>>20315000
                                                               <<06812>>20320000
                                                               <<06812>>20325000
                                                               <<06812>>20330000
procedure cktempclass(devclass);                               <<06812>>20335000
   byte array devclass;                                        <<06812>>20340000
   begin                                                       <<06812>>20345000
   comment                                                     <<06812>>20350000
     tempclass is a integer array which contains in word zero, <<06812>>20355000
   the number of undefined classes used as output devices and, <<06812>>20360000
   in word 1, the size of tempclass( in words ).  the remainder<<06812>>20365000
   of tempclass in similar to the device class table except    <<06812>>20370000
   the cyclical pointer and the access type are not included in<<06812>>20375000
   tempclass.  the name is followed by the number of devices   <<06812>>20380000
   and the device number's that require this class as an output<<06812>>20385000
   device                                                      <<06812>>20390000
   ;                                                           <<06812>>20395000
                                                               <<06812>>20400000
   << tempclass declarations >>                                <<06812>>20405000
                                                               <<06812>>20410000
   equate                                                      <<06812>>20415000
      temp'first'ldev = 5;                                     <<06812>>20420000
                                                               <<06812>>20425000
   define                                                      <<06812>>20430000
      num'temp'entries    = tempclass'h(0)#,                   <<06812>>20435000
      temp'table'size     = tempclass'h(1)#,                   <<06812>>20440000
      temp'class'name     = tempclass'b(0)#,                   <<06812>>20445000
      num'temp'devices    = tempclass'w(4)#,                   <<06812>>20450000
      next'temp'entry     = num'temp'devices + 5#;             <<06812>>20455000
                                                               <<06812>>20460000
   comment                                                     <<06812>>20465000
     we use tempclass'h to point to the header portion of      <<06812>>20470000
   tempclass and to access those variables associated with     <<06812>>20475000
   the header.  tempclass'w is used to access the current      <<06812>>20480000
   entry and tempclass'b to access the current class name.     <<06812>>20485000
   ;                                                           <<06812>>20490000
                                                               <<06812>>20495000
   integer pointer                                             <<06812>>20500000
      tempclass'h,                                             <<06812>>20505000
      tempclass'w;                                             <<06812>>20510000
                                                               <<06812>>20515000
   byte pointer                                                <<06812>>20520000
      tempclass'b;                                             <<06812>>20525000
                                                               <<06812>>20530000
   integer                                                     <<06812>>20535000
      i,                                                       <<06812>>20540000
      class'counter,                                           <<06812>>20545000
      dev'counter,                                             <<06812>>20550000
      classindex,                                              <<06812>>20555000
      ldev,                                                    <<06812>>20560000
      count;                                                   <<06812>>20565000
                                                               <<06812>>20570000
   comment                                                     <<06812>>20575000
      cktempclass is called each time a new device class is    <<06812>>20580000
   defined. if the newly defined device class was present in   <<06812>>20585000
   tempclass, the class index field in the ldt entry for this  <<06812>>20590000
   device is updated appropriatly and the entry is removed     <<06812>>20595000
   from tempclass. if the newly defined class is not present   <<06812>>20600000
   then no action is taken.                                    <<06812>>20605000
   ;                                                           <<06812>>20610000
                                                               <<06812>>20615000
                                                               <<06812>>20620000
   @tempclass'h := @tclass;                                    <<06812>>20625000
   @tempclass'w := @tempclass'h + 2;                           <<06812>>20630000
   @tempclass'b := @tempclass'w & lsl(1);                      <<06812>>20635000
   class'counter := 0;                                         <<06812>>20640000
   while (class'counter := class'counter + 1 )                 <<06812>>20645000
                                      <= num'temp'entries do   <<06812>>20650000
      if devclass = temp'class'name,(8) then                   <<06812>>20655000
         begin                                                 <<06812>>20660000
                                                               <<06812>>20665000
         << update ldt entry for each device in class >>       <<06812>>20670000
                                                               <<06812>>20675000
         classindex := clindex(devclass);                      <<06812>>20680000
         dev'counter := -1;                                    <<06812>>20685000
         while ( dev'counter := dev'counter + 1 )              <<06812>>20690000
                                     < num'temp'devices do     <<06812>>20695000
            begin                                              <<06812>>20700000
            ldev := tempclass'w(temp'first'ldev+dev'counter);  <<06812>>20705000
            get'ldev'entries(ldev);                            <<06812>>20710000
            if dvrdrtnum <> 0 then                             <<06812>>20715000
               ldt'dflt'out'dev := classindex;                 <<06812>>20720000
            put'ldev'entries(ldev);                            <<06812>>20725000
            end;                                               <<06812>>20730000
                                                               <<06812>>20735000
         << remove this tempclass entry               >>       <<06812>>20740000
                                                               <<06812>>20745000
         tclassincr := -(temp'first'ldev + num'temp'devices);  <<06812>>20750000
                                                               <<06812>>20755000
         << move the rest of tempclass over this entry >>      <<06812>>20760000
                                                               <<06812>>20765000
         count := (@tclass + temp'table'size + 1) -            <<06812>>20770000
                        (@tempclass'w + next'temp'entry);      <<06812>>20775000
         move tempclass'w := tempclass'w(next'temp'entry),     <<06812>>20780000
                             (count);                          <<06812>>20785000
         temp'table'size := temp'table'size + tclassincr;      <<06812>>20790000
         num'temp'entries := num'temp'entries - 1;             <<06812>>20795000
         class'counter := num'temp'entries;                    <<06812>>20800000
         end                                                   <<06812>>20805000
      else                                                     <<06812>>20810000
         begin                                                 <<06812>>20815000
         @tempclass'w := @tempclass'w + next'temp'entry;       <<06812>>20820000
         @tempclass'b := @tempclass'w & lsl(1);                <<06812>>20825000
         end;                                                  <<06812>>20830000
   movedltables;                                               <<06812>>20835000
   end;  << cktempclass >>                                     <<06812>>20840000
                                                               <<06812>>20845000
procedure putintempclass(devclass,ldev);                       <<06812>>20850000
   value ldev;                                                 <<06812>>20855000
   integer ldev;                                               <<06812>>20860000
   byte array devclass;                                        <<06812>>20865000
   begin                                                       <<06812>>20870000
   comment                                                     <<06812>>20875000
     tempclass is a integer array which contains in word zero, <<06812>>20880000
   the number of undefined classes used as output devices and, <<06812>>20885000
   in word 1, the size of tempclass( in words ).  the remainder<<06812>>20890000
   of tempclass in similar to the device class table except    <<06812>>20895000
   the cyclical pointer and the access type are not included in<<06812>>20900000
   tempclass.  the name is followed by the number of devices   <<06812>>20905000
   and the device number's that require this class as an output<<06812>>20910000
   device                                                      <<06812>>20915000
   ;                                                           <<06812>>20920000
                                                               <<06812>>20925000
   << tempclass declarations >>                                <<06812>>20930000
                                                               <<06812>>20935000
   equate                                                      <<06812>>20940000
      temp'first'ldev = 5;                                     <<06812>>20945000
                                                               <<06812>>20950000
   define                                                      <<06812>>20955000
      num'temp'entries    = tempclass'h(0)#,                   <<06812>>20960000
      temp'table'size     = tempclass'h(1)#,                   <<06812>>20965000
      temp'class'name     = tempclass'b(0)#,                   <<06812>>20970000
      num'temp'devices    = tempclass'w(4)#,                   <<06812>>20975000
      next'temp'entry     = num'temp'devices + 5#;             <<06812>>20980000
                                                               <<06812>>20985000
   comment                                                     <<06812>>20990000
     we use tempclass'h to point to the header portion of      <<06812>>20995000
   tempclass and to access those variables associated with     <<06812>>21000000
   the header.  tempclass'w is used to access the current      <<06812>>21005000
   entry and tempclass'b to access the current class name.     <<06812>>21010000
   ;                                                           <<06812>>21015000
                                                               <<06812>>21020000
   integer pointer                                             <<06812>>21025000
      tempclass'h,                                             <<06812>>21030000
      tempclass'w,                                             <<06812>>21035000
      dest,                                                    <<06812>>21040000
      source;                                                  <<06812>>21045000
                                                               <<06812>>21050000
   byte pointer                                                <<06812>>21055000
      tempclass'b;                                             <<06812>>21060000
                                                               <<06812>>21065000
   logical found;                                              <<06812>>21070000
                                                               <<06812>>21075000
   integer                                                     <<06812>>21080000
      i,                                                       <<06812>>21085000
      count;                                                   <<06812>>21090000
                                                               <<06812>>21095000
   @tempclass'h := @tclass;                                    <<06812>>21100000
   @tempclass'w := @tempclass'h + 2;                           <<06812>>21105000
   @tempclass'b := @tempclass'w & lsl(1);                      <<06812>>21110000
   found := false;                                             <<06812>>21115000
   i := 0;                                                     <<06812>>21120000
   while (i := i + 1 ) <= num'temp'entries and not found do    <<06812>>21125000
      if temp'class'name = devclass,(8)                        <<06812>>21130000
         then found := true                                    <<06812>>21135000
      else                                                     <<06812>>21140000
         begin                                                 <<06812>>21145000
         @tempclass'w := @tempclass'w + next'temp'entry;       <<06812>>21150000
         @tempclass'b := @tempclass'w & lsl(1);                <<06812>>21155000
         end;                                                  <<06812>>21160000
                                                               <<06812>>21165000
   if found then                                               <<06812>>21170000
      begin                                                    <<06812>>21175000
                                                               <<06812>>21180000
      << must make room to insert new ldev  >>                 <<06812>>21185000
                                                               <<06812>>21190000
      tclassincr := 1;                                         <<06812>>21195000
      movedltables;                                            <<06812>>21200000
      @tempclass'h := @tclass;                                 <<06812>>21205000
      @tempclass'w := @tempclass'w - 1;                        <<06812>>21210000
      @tempclass'b := @tempclass'w & lsl(1);                   <<06812>>21215000
                                                               <<06812>>21220000
      << insert new ldev in tempclass       >>                 <<06812>>21225000
                                                               <<06812>>21230000
      @dest := @tclass + temp'table'size;                      <<06812>>21235000
      @source := @dest - 1;                                    <<06812>>21240000
      count := @dest - @ tempclass'w(next'temp'entry);         <<06812>>21245000
      move dest := source,(-count);                            <<06812>>21250000
      tempclass'w(next'temp'entry) := ldev;                    <<06812>>21255000
      temp'table'size := temp'table'size + 1;                  <<06812>>21260000
      num'temp'devices := num'temp'devices +1;                 <<06812>>21265000
      end                                                      <<06812>>21270000
   else                                                        <<06812>>21275000
                                                               <<06812>>21280000
      << new tempclass entry to be built    >>                 <<06812>>21285000
                                                               <<06812>>21290000
      begin                                                    <<06812>>21295000
      tclassincr := 6;                                         <<06812>>21300000
      movedltables;                                            <<06812>>21305000
      @tempclass'w := @tempclass'w - 6;                        <<06812>>21310000
      @tempclass'b := @tempclass'w & lsl(1);                   <<06812>>21315000
      @tempclass'h := @tclass;                                 <<06812>>21320000
      move temp'class'name := devclass,(8);                    <<06812>>21325000
      num'temp'devices := 1;                                   <<06812>>21330000
      tempclass'w( temp'first'ldev ) := ldev;                  <<06812>>21335000
      num'temp'entries := num'temp'entries + 1;                <<06812>>21340000
      temp'table'size := temp'table'size + 6;                  <<06812>>21345000
      end;                                                     <<06812>>21350000
   end;  << procedure putintempclass >>                        <<06812>>21355000
                                                               <<06812>>21360000
                                                               <<06812>>21365000
                                                               <<06812>>21370000
procedure remtempclass(ldev);                                  <<06812>>21375000
   value ldev;                                                 <<06812>>21380000
   integer ldev;                                               <<06812>>21385000
   begin                                                       <<06812>>21390000
   comment                                                     <<06812>>21395000
     tempclass is a integer array which contains in word zero, <<06812>>21400000
   the number of undefined classes used as output devices and, <<06812>>21405000
   in word 1, the size of tempclass( in words ).  the remainder<<06812>>21410000
   of tempclass in similar to the device class table except    <<06812>>21415000
   the cyclical pointer and the access type are not included in<<06812>>21420000
   tempclass.  the name is followed by the number of devices   <<06812>>21425000
   and the device number's that require this class as an output<<06812>>21430000
   device                                                      <<06812>>21435000
   ;                                                           <<06812>>21440000
                                                               <<06812>>21445000
   << tempclass declarations >>                                <<06812>>21450000
                                                               <<06812>>21455000
   equate                                                      <<06812>>21460000
      temp'first'ldev = 5;                                     <<06812>>21465000
                                                               <<06812>>21470000
   define                                                      <<06812>>21475000
      num'temp'entries    = tempclass'h(0)#,                   <<06812>>21480000
      temp'table'size     = tempclass'h(1)#,                   <<06812>>21485000
      temp'class'name     = tempclass'b(0)#,                   <<06812>>21490000
      num'temp'devices    = tempclass'w(4)#,                   <<06812>>21495000
      next'temp'entry     = num'temp'devices + 5#;             <<06812>>21500000
                                                               <<06812>>21505000
   comment                                                     <<06812>>21510000
     we use tempclass'h to point to the header portion of      <<06812>>21515000
   tempclass and to access those variables associated with     <<06812>>21520000
   the header.  tempclass'w is used to access the current      <<06812>>21525000
   entry and tempclass'b to access the current class name.     <<06812>>21530000
   ;                                                           <<06812>>21535000
                                                               <<06812>>21540000
   integer pointer                                             <<06812>>21545000
      tempclass'h,                                             <<06812>>21550000
      tempclass'w;                                             <<06812>>21555000
                                                               <<06812>>21560000
   byte pointer                                                <<06812>>21565000
      tempclass'b;                                             <<06812>>21570000
                                                               <<06812>>21575000
   integer                                                     <<06812>>21580000
      i,                                                       <<06812>>21585000
      j,                                                       <<06812>>21590000
      count;                                                   <<06812>>21595000
                                                               <<06812>>21600000
   logical                                                     <<06812>>21605000
      found;                                                   <<06812>>21610000
                                                               <<06812>>21615000
   found := false;                                             <<06812>>21620000
   @tempclass'h := @tclass;                                    <<06812>>21625000
   @tempclass'w := @tempclass'h + 2;                           <<06812>>21630000
   @tempclass'b := @tempclass'w & lsl(1);                      <<06812>>21635000
   i := 0;                                                     <<06812>>21640000
   while (i := i + 1 ) <= num'temp'entries and not found do    <<06812>>21645000
      begin                                                    <<06812>>21650000
      j :=-1;                                                  <<06812>>21655000
      while (j := j + 1 ) < num'temp'devices and not found do  <<06812>>21660000
         if ldev = tempclass'w(temp'first'ldev + j) then       <<06812>>21665000
                                                               <<06812>>21670000
            << found appropriate entry, remove it   >>         <<06812>>21675000
                                                               <<06812>>21680000
            if num'temp'devices = 1 then                       <<06812>>21685000
               begin                                           <<06812>>21690000
               << must remove entire class  >>                 <<06812>>21695000
               << move the rest of tempclass over this entry >><<06812>>21700000
                                                               <<06812>>21705000
               count := (@tclass + temp'table'size) -          <<06812>>21710000
                        (@tempclass'w + next'temp'entry);      <<06812>>21715000
               move tempclass'w := tempclass'w(next'temp'entry)<<06812>>21720000
                                    ,(count);                  <<06812>>21725000
               found := true;                                  <<06812>>21730000
               tclassincr := -6;                               <<06812>>21735000
               temp'table'size := temp'table'size - 6;         <<06812>>21740000
               num'temp'entries := num'temp'entries - 1;       <<06812>>21745000
               movedltables;                                   <<06812>>21750000
               end                                             <<06812>>21755000
            else                                               <<06812>>21760000
               begin                                           <<06812>>21765000
               count := num'temp'devices - (j+1);              <<06812>>21770000
               move tempclass'w(temp'first'ldev + j) :=        <<06812>>21775000
                    tempclass'w(temp'first'ldev + j + 1),      <<06812>>21780000
                    (count);                                   <<06812>>21785000
               count := (@tclass + temp'table'size) -          <<06812>>21790000
                        (@tempclass'w + next'temp'entry);      <<06812>>21795000
               move tempclass'w(next'temp'entry - 1) :=        <<06812>>21800000
                    tempclass'w(next'temp'entry),(count);      <<06812>>21805000
               temp'table'size := temp'table'size - 1;         <<06812>>21810000
               num'temp'devices := num'temp'devices - 1;       <<06812>>21815000
               tclassincr := tclassincr - 1;                   <<06812>>21820000
               found := true;                                  <<06812>>21825000
               movedltables;                                   <<06812>>21830000
               end;                                            <<06812>>21835000
      @tempclass'w := @tempclass'w + next'temp'entry;          <<06812>>21840000
      @tempclass'b := @tempclass'w & lsl(1);                   <<06812>>21845000
      end;                                                     <<06812>>21850000
   end; << remtempclassrefs >>                                 <<06812>>21855000
$control segment=iochange                                      <<01073>>21860000
                                                                        21865000
   <<--------------                                                     21870000
     delete class                                              <c0.00   21875000
   -------------->>                                                     21880000
   integer procedure deleteclass(errlabel);                             21885000
       value errlabel;                                                  21890000
       integer errlabel;                                                21895000
       begin                                                            21900000
        integer array err(0:13);                                        21905000
        byte array berr(*)=err;                                         21910000
  integer i,entrysize,count;                                   <<06762>>21915000
                                                               <<06762>>21920000
  logical found;                                               <<06762>>21925000
                                                               <<06762>>21930000
  i := 0;                                                      <<06762>>21935000
  found := false;                                              <<06762>>21940000
  @dct := @dct'head + dcth'dct'base;                           <<06762>>21945000
  @dct'b := @dct & lsl(1);                                     <<06762>>21950000
  while (i:=i+1) <= dcth'num'dct'entries and not found do      <<06762>>21955000
    if dctb'class'name = devclass,(8)  then                    <<06762>>21960000
      begin                                                    <<06762>>21965000
      found := true;                                           <<06762>>21970000
      deleteclass := i;                                        <<06762>>21975000
      end                                                      <<06762>>21980000
    else                                                       <<06762>>21985000
      begin                                                    <<06762>>21990000
      @dct := @dct + dct'next'entry;                           <<06762>>21995000
      @dct'b := @dct & lsl(1);                                 <<06762>>22000000
      end;                                                     <<06762>>22005000
  if found then                                                <<06762>>22010000
    begin                                                      <<06762>>22015000
    << must compact table >>                                   <<06762>>22020000
    entrysize := dct'next'entry;                               <<06762>>22025000
    count := (@dct'head + dcth'tdt'base)                       <<*7657>>22030000
             - (@dct + dct'next'entry);                        <<06762>>22035000
    move dct := dct(dct'next'entry),(count);                   <<06762>>22040000
    dcth'num'dct'entries := dcth'num'dct'entries - 1;          <<06762>>22045000
    dcth'segment'size := dcth'segment'size - entrysize;        <<*7657>>22050000
    dcth'tdt'base := dcth'tdt'base - entrysize;                <<*7657>>22055000
    dctabincr := -entrysize;                                   <<06762>>22060000
    movedltables;                                              <<06762>>22065000
    end                                                        <<06762>>22070000
  else                                                         <<06762>>22075000
    begin                                                      <<06762>>22080000
    << not found >>                                            <<06762>>22085000
    move berr := "CLASS ",2;                                   <<06762>>22090000
    move *    := devclass,(8),2;                               <<06762>>22095000
    move *    := " DOESN'T EXIST";                             <<06762>>22100000
    print( err, -28, 0);                                       <<06762>>22105000
    returnp := errlabel;                                       <<06762>>22110000
    assemble( exit 2);                                         <<06762>>22115000
    end;                                                       <<06762>>22120000
  end;  << deleteclass >>                                      <<06762>>22125000
                                                               <<06762>>22130000
$control segment=iochange                                      <<01073>>22135000
                                                                        22140000
   <<--------------------                                               22145000
     determine class type                                      <c0.00   22150000
   -------------------->>                                               22155000
                                                                        22160000
   procedure determctyp(errlabel,dct,askio);                   <<06762>>22165000
     value errlabel,dct,askio;                                 <<06762>>22170000
     integer errlabel;                                         <<06762>>22175000
     pointer dct;                                              <<06762>>22180000
     logical askio;                                            <<03610>>22185000
        begin                                                           22190000
        <<this procedure determines the type of the class >>            22195000
        <<to which dct points to in dctab.  dct  points  >>    <<06762>>22200000
        << to the class name.                              >>  <<06762>>22205000
        switch sw:=cer,dac,sip,cer,cio,cer,sip,cer,ncio,cer,sip,        22210000
                   cer,ncio,cer,sip,cer,sou,cer,cer,cer,sou,cer,        22215000
                   cer,cer,sou,cer,cer,cer,sou,cer,cer,cer,cer;         22220000
        integer i,j,l,n,temp,dtype,drange,type,subtyp,         <<03610>>22225000
                current'class'access'type;                     <<03610>>22230000
        logical allsame:=true;                                          22235000
        logical all'same'range:= true;                         <<03610>>22240000
        logical canbeserial:=true;                             <<00134>>22245000
          n := dct'num'devices;                                <<06762>>22250000
          i := -1;                                             <<d7981>>22255000
          temp := 0;                                                    22260000
          current'class'access'type:= dct'class'acc'type;      <<06762>>22265000
          get'ldev'entries(dct(dct'first'ldev));               <<06762>>22270000
          dtype := ldt'device'type;<<type of first device>>    <<06762>>22275000
          drange :=ldt'access'type;                            <<06762>>22280000
          while (i:=i+1) < integer(dct'num'devices) do         <<07037>>22285000
            begin                                                       22290000
            get'ldev'entries(dct(dct'first'ldev+i));           <<06762>>22295000
            type := ldt'device'type;                           <<06762>>22300000
            subtyp := lpdt'subtype;                            <<06762>>22305000
            if dtype <> ldt'device'type                        <<06762>>22310000
              then allsame := false;                           <<06762>>22315000
            if drange <> ldt'access'type                       <<06762>>22320000
              then all'same'range:= false;                     <<06762>>22325000
            case ldt'access'type of                            <<06762>>22330000
             begin                                                      22335000
             begin                                             <<00134>>22340000
             temp.diracc:=1;                                   <<00134>>22345000
             if not sdisc'type(type,subtyp) then               <<03544>>22350000
                canbeserial:=false;                            <<00134>>22355000
             end;                                              <<00134>>22360000
             temp.serinp:=1;                                            22365000
             temp.conio :=1;                                            22370000
             temp.nconio:=1;                                            22375000
             temp.serout:=1;                                            22380000
             end;                                                       22385000
            end;                                                        22390000
          go sw(temp);                                                  22395000
   dac:   if current'class'access'type<>ldt'serial'disc and    <<06762>>22400000
             current'class'access'type<>ldt'foreign'disc then  <<06762>>22405000
          if allsame then dct'class'acc'type := dtype          <<06762>>22410000
          else dct'class'acc'type:=ldt'direct'access&lsl(3);   <<06762>>22415000
          if canbeserial and askio then                        <<03610>>22420000
            if yesanswer(m2327) then <<serial disc class>>     <<*8393>>22425000
              dct'class'acc'type := ldt'serial'disc            <<06762>>22430000
            else if yesanswer(m2334) then <<foreign disc class><<*8393>>22435000
              dct'class'acc'type := ldt'foreign'disc;          <<06762>>22440000
          return;                                              <<01073>>22445000
   sip:   if allsame then dct'class'acc'type:=dtype            <<06762>>22450000
          else if all'same'range or askio then                 <<03610>>22455000
                 dct'class'acc'type:=ldt'serial'in&lsl(3);     <<06762>>22460000
          return;                                                       22465000
   cio:   if askio then                                        <<03610>>22470000
            begin                                              <<03610>>22475000
            dct'class'acc'type:= ldt'io'concurrent&lsl(3);     <<06762>>22480000
            go prompt;                                         <<03610>>22485000
            end;                                               <<03610>>22490000
          if current'class'access'type.(13:3)<>0 then          <<03610>>22495000
            dct'class'acc'type:=ldt'io'concurrent&lsl(3);      <<06762>>22500000
          return;                                              <<03610>>22505000
   ncio:  dct'class'acc'type := ldt'io'nonconcur&lsl(3);       <<06762>>22510000
          if askio then go prompt else return;                 <<03610>>22515000
   sou:   if allsame then dct'class'acc'type:=dtype            <<06762>>22520000
          else if all'same'range or askio then                 <<03610>>22525000
                 dct'class'acc'type:=ldt'serial'out&lsl(3);    <<06762>>22530000
          return;                                                       22535000
   cer:                                                        <<00298>>22540000
          if allsame then                                      <<00298>>22545000
             dct'class'acc'type := dtype                       <<06762>>22550000
          else if askio then                                   <<03610>>22555000
             begin                                             <<00298>>22560000
             message(m123,,,,,devclass);                       <<*8393>>22565000
             returnp := errlabel;                              <<00298>>22570000
             end;                                              <<00298>>22575000
          return;                                                       22580000
   prompt:message(-m2350);                                     <<*8393>>22585000
          readinput;                                                    22590000
          m := getstr(@prompt,btyp,1,"/",6);                            22595000
          if btyp="IN    "                                     <<06762>>22600000
            then dct'class'acc'type:=ldt'serial'in&lsl(3)      <<06762>>22605000
          else if btyp="OUT   "                                <<06762>>22610000
            then dct'class'acc'type:=ldt'serial'out&lsl(3)     <<06762>>22615000
               else if btyp<>"IN/OUT" and btyp<>"IO    " then           22620000
                      begin                                             22625000
                      message(m2453);                          <<*8393>>22630000
                      go prompt;                                        22635000
                      end;                                              22640000
          if dct'access'type = ldt'io'concurrent then          <<06762>>22645000
            begin                                                       22650000
   nornc:   message(-m2351);                                   <<*8393>>22655000
            readinput;                                                  22660000
            getstr(@nornc,btyp,1,"A",2);                                22665000
            if btyp="NC"                                       <<06762>>22670000
              then dct'class'acc'type:=ldt'io'nonconcur&lsl(3) <<06762>>22675000
            else if btyp<>"C " and btyp<>"CO" then                      22680000
                   begin                                                22685000
                   message(m2453);                             <<*8393>>22690000
                   go nornc;                                            22695000
                   end;                                                 22700000
            end;                                                        22705000
          end  <<determctyp>>;                                          22710000
$control segment=iochange                                      <<*7657>>22715000
                                                               <<*7657>>22720000
<<------------------------------------------------------->>    <<*7657>>22725000
<<calculate the offset into the termtype descriptor table>>    <<*7657>>22730000
<<------------------------------------------------------->>    <<*7657>>22735000
                                                               <<*7657>>22740000
procedure calc'ttf'offset;                                     <<*7657>>22745000
                                                               <<*7657>>22750000
comment                                                        <<*7657>>22755000
  calculates the offset into the termtype descriptor table     <<*7657>>22760000
  and puts it into the ldtx word 1.                            <<*7657>>22765000
  called from io'config'change, removettdtrefs, and when       <<*7657>>22770000
  adding and deleting filenames;                               <<*7657>>22775000
                                                               <<*7657>>22780000
  begin                                                        <<*7657>>22785000
  integer                                                      <<*7657>>22790000
    i,                                                         <<*7657>>22795000
    index := 0,       << index from begining of table to >>    <<*7657>>22800000
                      << current entry                   >>    <<*7657>>22805000
    j     :=0,        <<points to the list of ldevs>>          <<*7657>>22810000
    ldev  :=0;        <<local copy of ldev>>                   <<*7657>>22815000
                                                               <<*7657>>22820000
  @tdt := @dct'head + dcth'tdt'base;                           <<*7657>>22825000
  @tdt'b := @tdt & lsl(1);                                     <<*7657>>22830000
  i := -1;                                                     <<*7657>>22835000
  while (i:=i+1) < dcth'num'tdt'entries do                     <<*7657>>22840000
    begin                                                      <<*7657>>22845000
    <<go thru each entry>>                                     <<*7657>>22850000
    index := @tdt - (@dct'head + dcth'tdt'base);               <<*7657>>22855000
    j := 0;                                                    <<*7657>>22860000
    while (j:=j+1) <= tdt'num'devices do                       <<*7657>>22865000
      begin                                                    <<*7657>>22870000
      <<calculate offset for each ldev in entry>>              <<*7657>>22875000
      ldev := tdt(tdt'first'ldev + j);                         <<*7657>>22880000
      get'ldev'entries(ldev);                                  <<*7657>>22885000
      ldtx'tdt'offset := index;                                <<*7657>>22890000
      put'ldev'entries(ldev);                                  <<*7657>>22895000
      end;                                                     <<*7657>>22900000
    << bump tdt so its points at beginning of next entry >>    <<*7657>>22905000
    @tdt := @tdt + tdt'next'entry;                             <<*7657>>22910000
    @tdt'b := @tdt & lsl(1);                                   <<*7657>>22915000
    end;                                                       <<*7657>>22920000
  end; <<calc'ttf'offset>>                                     <<*7657>>22925000
$control segment=iochange                                      <<*7657>>22930000
  <<--------------------------------------------->>            <<*7657>>22935000
  << remove term type descriptor file references >>            <<*7657>>22940000
  <<--------------------------------------------->>            <<*7657>>22945000
   procedure removettdtrefs(ldev);                             <<*7657>>22950000
     value ldev;                                               <<*7657>>22955000
     integer ldev;                                             <<*7657>>22960000
     comment                                                   <<*7657>>22965000
       remove references to ldev from the ttdt.                <<*7657>>22970000
       called from io'config'ch when a term is deleted or      <<*7657>>22975000
       replaced, and when a termtype descr file is added to    <<*7657>>22980000
       an ldev that previously had one already.                <<*7657>>22985000
       this proc calls calc'ttf'offset and movedltables;       <<*7657>>22990000
       begin                                                   <<*7657>>22995000
       integer                                                 <<*7657>>23000000
               j        :=0,  <<points to next ldev in ent >>  <<*7657>>23005000
               cnt:=0,        <<# of words to move>>           <<*7657>>23010000
               offset:=0;     <<from ldtx word 1>>             <<*7657>>23015000
       get'ldev'entries(ldev);                                 <<*7657>>23020000
       offset := ldtx'tdt'offset;                              <<*7657>>23025000
       if offset = -1 then                                     <<*7657>>23030000
         return; <<this ldev doesn't have a termtype descr>>   <<*7657>>23035000
       @tdt := @dct'head + dcth'tdt'base + ldtx'tdt'offset;    <<*7657>>23040000
       @tdt'b := @tdt & lsl(1);                                <<*7657>>23045000
       if tdt'num'devices = 1 then                             <<*7657>>23050000
         begin  <<filename entry must be deleted>>             <<*7657>>23055000
         << move the rest of the table with a positive count>> <<*7657>>23060000
         cnt := (dcth'segment'size - dcth'tdt'base)            <<*7657>>23065000
                           - (ldtx'tdt'offset +14);            <<*7657>>23070000
         move tdt := tdt(14),(cnt);                            <<*7657>>23075000
         ldtx'tdt'offset := -1;   <<removed>>                  <<*7657>>23080000
         ttdtincr := -14;           << 14=size of entry with >><<*7657>>23085000
         dcth'num'tdt'entries := dcth'num'tdt'entries - 1;     <<*7657>>23090000
         dcth'segment'size := dcth'segment'size - 14;          <<*7657>>23095000
         end                                                   <<*7657>>23100000
       else                                                    <<*7657>>23105000
         begin  <<delete one ldev out of entry>>               <<*7657>>23110000
         j := 0;                                               <<*7657>>23115000
         do j := j + 1                                         <<*7657>>23120000
           until tdt(tdt'first'ldev + j ) = ldev;              <<*7657>>23125000
                                                               <<*7657>>23130000
         << move the rest of the entry with a positive count >><<*7657>>23135000
         cnt := tdt'num'devices - j;                           <<*7657>>23140000
         move tdt(tdt'first'ldev + j) :=                       <<*7657>>23145000
                 tdt(tdt'first'ldev + j + 1),(cnt);            <<*7657>>23150000
                                                               <<*7657>>23155000
         << move the rest of the table with a positive count >><<*7657>>23160000
         cnt := (@dct'head + dcth'segment'size) -              <<*7657>>23165000
                 (@tdt + tdt'next'entry);                      <<*7657>>23170000
         move tdt(tdt'next'entry - 1) :=                       <<*7657>>23175000
                tdt(tdt'next'entry),(cnt);                     <<*7657>>23180000
                                                               <<*7657>>23185000
         ldtx'tdt'offset := -1;   <<removed>>                  <<*7657>>23190000
         tdt'num'devices := tdt'num'devices - 1;               <<*7657>>23195000
         ttdtincr := -1;                                       <<*7657>>23200000
         dcth'segment'size := dcth'segment'size - 1;           <<*7657>>23205000
         end;                                                  <<*7657>>23210000
       put'ldev'entries(ldev);                                 <<*7657>>23215000
       movedltables;                                           <<*7657>>23220000
       calc'ttf'offset;                                        <<*7657>>23225000
       end <<removettdtrefs>> ;                                <<*7657>>23230000
$control segment=iochange                                      <<*7657>>23235000
   <<------------------------------->>                         <<*7657>>23240000
   <<delete termtype descriptor file>>                         <<*7657>>23245000
   <<------------------------------->>                         <<*7657>>23250000
                                                               <<*7657>>23255000
procedure delete'ttdt;                                         <<*7657>>23260000
  option privileged,uncallable;                                <<*7657>>23265000
                                                               <<*7657>>23270000
comment                                                        <<*7657>>23275000
  removes references to the filename specified.  the entire    <<*7657>>23280000
  entry is removed, and the offsets kept in the ldtx wd 1      <<*7657>>23285000
  are set to -1.                                               <<*7657>>23290000
  called from io'config'ch when deleting classes.              <<*7657>>23295000
  calls calc'ttdt'offset, and movedltables                     <<*7657>>23300000
     assumes that the pointers tdt and tdt'b are set           <<*7657>>23305000
  to the entry being removed prior to calling this             <<*7657>>23310000
  procedure;                                                   <<*7657>>23315000
                                                               <<*7657>>23320000
  begin                                                        <<*7657>>23325000
  integer ldev,             <<points to #ldevs in ent>>        <<*7657>>23330000
          cnt:=0,           <<# of words to move>>             <<*7657>>23335000
          offset,           <<from ldtx word 1>>               <<*7657>>23340000
          nldevs,           <<number of ldevs in ent>>         <<*7657>>23345000
          i:=0;                                                <<*7657>>23350000
  do                                                           <<*7657>>23355000
     begin                                                     <<*7657>>23360000
     i:=i+1;                                                   <<*7657>>23365000
     ldev := tdt(tdt'first'ldev + i);                          <<*7657>>23370000
     get'ldev'entries(ldev);                                   <<*7657>>23375000
     ldtx'tdt'offset := -1;  <<removed>>                       <<*7657>>23380000
     put'ldev'entries(ldev);                                   <<*7657>>23385000
     end                                                       <<*7657>>23390000
  until (i = tdt'num'devices);                                 <<*7657>>23395000
  ttdtincr := -(tdt'next'entry);                               <<*7657>>23400000
  cnt := (@dct'head + dcth'segment'size)                       <<*7657>>23405000
         - (@tdt + tdt'next'entry);                            <<*7657>>23410000
  move tdt := tdt(tdt'next'entry),(cnt);                       <<*7657>>23415000
  dcth'num'tdt'entries := dcth'num'tdt'entries - 1;            <<*7657>>23420000
  dcth'segment'size := dcth'segment'size + ttdtincr;           <<*7657>>23425000
  movedltables;                                                <<*7657>>23430000
  calc'ttf'offsets;                                            <<*7657>>23435000
  end;  <<delete'ttdt>>                                        <<*7657>>23440000
                                                               <<d9021>>23445000
                                                               <<d9021>>23450000
logical procedure compare'words(addr1, addr2, count);          <<d9021>>23455000
                                                               <<d9021>>23460000
  comment                                                      <<d9021>>23465000
                                                               <<d9021>>23470000
     this procedure will compare the memory locations          <<d9021>>23475000
     indicated by word pointers addr1 and addr2.  if           <<d9021>>23480000
     they are the same for the count indicated, a value        <<d9021>>23485000
     of true is returned. if not, a value of false is          <<d9021>>23490000
     returned.                                                 <<d9021>>23495000
                                                               <<d9021>>23500000
  ;                                                            <<d9021>>23505000
                                                               <<d9021>>23510000
    value addr1, addr2, count;                                 <<d9021>>23515000
    pointer addr1, addr2;                                      <<d9021>>23520000
    integer count;                                             <<d9021>>23525000
                                                               <<d9021>>23530000
    begin                                                      <<d9021>>23535000
                                                               <<d9021>>23540000
       integer i;                                              <<d9021>>23545000
       compare'words := true;                                  <<d9021>>23550000
       i := -1;                                                <<d9021>>23555000
       while (i:= i+1) < count do                              <<d9021>>23560000
          if addr1(i) <> addr2(i) then compare'words := false; <<d9021>>23565000
    end ;  << compare'words >>                                 <<d9021>>23570000
                                                               <<d9021>>23575000
$control segment=iochange1                                     <<06068>>23580000
                                                                        23585000
          <<--------------------------                                  23590000
            check device consistency                           <c0.00   23595000
          -------------------------->>                                  23600000
  logical procedure checkdev;                                  <<01073>>23605000
    option privileged,uncallable;                                       23610000
    comment                                                             23615000
      check device tables for non-existent output devices, duplicately  23620000
    defined drt-unit combinations,devices or device classes not         23625000
    allow are defined as output device, and device classes with         23630000
    both sharable and non-sharable devices. if any of these             23635000
    conditions are found, print a message and exit to errlabel;         23640000
      begin                                                             23645000
        equate consoledrt=7,  tapedrt=6;                       <<06762>>23650000
        equate consoleunit=0, tapeunit=0;                      <<06762>>23655000
        equate tpconsdrt=8,   tpconsunit=0;                    <<06762>>23660000
        equate sdisc=31;<<class access type for serial discs>> <<00.sd>>23665000
        equate fdisc=7; <<foreign disc class access type>>     <<01115>>23670000
        integer i,j,k,n,index,ldev:=0,consoleldev:=0,tapeldev:=0;       23675000
        integer ldevrange,dtyp,type,type2,subtyp, subtyp2;     <<d9068>>23680000
        logical allsame;                                                23685000
        byte array errmess0(0:20)=pb:="NO OUTPUT DEVICE FOR ";          23690000
        byte array errmess1(0:14) =pb := "LOGICAL DEVICE ";             23695000
        byte array errmess2(0:14) =pb := " DOES NOT EXIST";             23700000
        byte array errmess3(0:33) = pb :=                      <<03007>>23705000
            "LDEV AND LDEV ON SAME DRT AND UNIT";              <<03007>>23710000
        byte array errmess5(0:41)=pb:=                                  23715000
          "DEVICES OF DIFFERENT TYPE RANGES IN CLASS ";                 23720000
        byte array errmess6(0:37)=pb:=                         <<03006>>23725000
          "USER SPECIFIED MAXIMUM DRT ALLOWED IS ";            <<03006>>23730000
        byte array errmess7(0:23)=pb:="OUTPUT CLASS FOR DEVICE ";       23735000
        byte array errmess8(0:16)=pb:=" NO LONGER EXISTS";              23740000
        byte array errmess9(0:24)=pb:=                                  23745000
                   " CAN NOT BE OUTPUT DEVICE";                         23750000
        byte array errmes10(0:12)=pb:="DEVICE CLASS ";                  23755000
        byte array errmes11(0:34)=pb:=                                  23760000
              "ILLEGAL TYPE COMBINATIONS IN CLASS ";                    23765000
        byte array errmess12(0:45)=pb:=                        <<03006>>23770000
          "WARNING  HIGHEST DRT SUPPORTED BY THIS CPU IS ";    <<03006>>23775000
        byte array errmess13(0:45)=pb:=                        <<03006>>23780000
          "FOLLOWING DRT(S) EXCEED HIGHEST ALLOWABLE DRT:";    <<03006>>23785000
        byte array errmess14(*) = pb :=                        <<06815>>23790000
          "HIGHEST SUPPORTED DISC LDEV IS 255";                <<06815>>23795000
        logical share,errors:=false,toobigdrt:=false;                   23800000
           logical cpubigdrt := false;  <<config has a drt   >><<03006>>23805000
                                        <<higher than local>>  <<03006>>23810000
                                        <<supportable max drt>><<03006>>23815000
           logical bigusermaxdrt := false;  <<user picked a >> <<03006>>23820000
                  << "MAXDRT" which is larger than the max >>  <<03006>>23825000
                  <<drt which this cpu can support, but>>      <<03006>>23830000
                  <<might be ok if config for another cpu >>   <<03006>>23835000
           integer drtcutoff;   <<min of user specified max drt<<03006>>23840000
                                <<and cpu supported max drt>>  <<03006>>23845000
           logical warning:=false;                             <<03006>>23850000
        logical validdrivers := false;                         <<d9068>>23855000
        logical discfound := false;                                     23860000
        integer len1,len2;                                              23865000
        integer acctype;                                       <<00072>>23870000
        integer array dvr'name(0:3);                           <<d9021>>23875000
  do begin  <<loop while user desires to correct config>>      <<03006>>23880000
            <<warnings concerning drts>maxdrt>>                <<03006>>23885000
                                                               <<03006>>23890000
    errors := false;   <<clear these each time around>>        <<03006>>23895000
    warning := false;  <<set if drt value > max drt>>          <<03006>>23900000
                       <<supported by this cpu>>               <<03006>>23905000
                                                               <<03006>>23910000
    bigusermaxdrt:= false;                                     <<03006>>23915000
    toobigdrt := false;                                        <<03006>>23920000
    cpubigdrt := false;                                        <<03006>>23925000
          while (ldev:=ldev+1) <= hldev do                              23930000
           begin                                                        23935000
           get'ldev'entries(ldev);                             <<06762>>23940000
           unitn := dvrunitnum;                                <<06762>>23945000
           drtn := dvrdrtnum;                                  <<06762>>23950000
           move dvr'name := dvrname, (4);                      <<d9021>>23955000
           subtyp := lpdt'subtype;                             <<d9068>>23960000
           if ( drtn<>0 or unitn<>0 ) and dvrdsbit=0 then      <<06762>>23965000
             begin <<non-ds device>>                                    23970000
              if dvrdrtnum > comm(drtnum)                      <<07039>>23975000
              then toobigdrt := true;                          <<03006>>23980000
              if dvrdrtnum > maxdrt  <<can't support >>        <<06762>>23985000
              then cpubigdrt := true;                          <<03006>>23990000
              if comm(drtnum) > maxdrt  <<potential prob>>     <<07039>>23995000
              then bigusermaxdrt := true;                      <<03006>>24000000
              type := ldt'device'type;                         <<06762>>24005000
              i := ldt'dflt'out'dev;     <<output device>>     <<06762>>24010000
     if seriesii'iii then                                      <<02509>>24015000
   begin                                                       <<tp.01>>24020000
              if drtn=consoledrt and unitn=consoleunit         <<06762>>24025000
                  and ldt'device'type=ldt'terminal then        <<06762>>24030000
                  consoleldev := ldev;                         <<03544>>24035000
              if drtn=tapedrt and unitn=tapeunit and           <<06762>>24040000
                ldt'device'type=ldt'mag'tape                   <<06762>>24045000
                then tapeldev := ldev;                                  24050000
   end                                                         <<tp.01>>24055000
else                                                           <<tp.01>>24060000
   if postseries3 then                                         <<01402>>24065000
      begin                                                    <<tp.01>>24070000
      if drtn=tpconsdrt and unitn=tpconsunit and               <<06762>>24075000
         ldt'device'type = ldt'terminal then                   <<06762>>24080000
         consoleldev:=ldev;                                    <<tp.01>>24085000
      end                                                      <<tp.01>>24090000
   else                                                        <<tp.01>>24095000
      message(m2413);                                          <<*8393>>24100000
              if ldev > 255 and 0 <= type <= 7 then            <<07038>>24105000
                 begin                                         <<06815>>24110000
                 move binbuf := errmess14,(34);                <<06815>>24115000
                 print( inbuf, -34, 0);                        <<06815>>24120000
                 errors := true;                               <<06815>>24125000
                 end;                                          <<06815>>24130000
              if logical( lpdt'job'accept)                     <<06762>>24135000
               and i = 0 then                                  <<06762>>24140000
                begin  <<output device doesn't exist>>                  24145000
                  tos := 0;                                             24150000
                  tos := ldev;                                          24155000
                  tos := 10;                                            24160000
                  move binbuf := errmess0,(21),2;                       24165000
                  move * := errmess1,(15),2;                            24170000
                  len1 := ascii(*,*,*);                                 24175000
                  print(inbuf,-36-len1,0);                              24180000
                  errors := true;                                       24185000
                end;                                                    24190000
              if logical(ldt'class'index) then                 <<06762>>24195000
                begin   <<output device is class index>>                24200000
                  if i=0 then                                           24205000
                    begin  <<class doesn't exist>>                      24210000
                      tos := 0;                                         24215000
                      tos := ldev;                                      24220000
                      tos := 10;                                        24225000
                      move binbuf := errmess7,(24),2;                   24230000
                      len1 := ascii(*,*,*);                             24235000
                      move binbuf(len1+24) := errmess8,(17);            24240000
                      print(inbuf,-41-len1,0);                          24245000
                      errors := true;                                   24250000
                    end                                                 24255000
                  else                                                  24260000
                  begin <<illegal class as output device>>              24265000
                   @dct := @dct'head + dcth'dct'base;          <<06762>>24270000
                   j := 0;                                              24275000
                   while (j:=j+1)<i do                                  24280000
                     @dct := @dct + dct'next'entry;            <<06762>>24285000
                   get'ldev'entries(dct(dct'first'ldev));      <<06762>>24290000
                   i:=ldt'device'type;                         <<06762>>24295000
                   if (0<=i<=15) or (24<=i<=31) then           <<06762>>24300000
                    begin                                               24305000
                     @dct'b := @dct & lsl(1);                  <<06762>>24310000
                     move binbuf := errmes10,(13),2;                    24315000
                     move * := dctb'class'name,(8),2;          <<06762>>24320000
                     move * := errmess9,(25);                           24325000
                     print(inbuf,-48,0);                                24330000
                     errors:=true;                                      24335000
                    end;                                                24340000
                 end;                                                   24345000
                end                                                     24350000
              else if i <> 0 then                                       24355000
              begin                                            <<06762>>24360000
              get'ldev'entries(i);                             <<06762>>24365000
              if dvrdrtnum = 0 then                            <<06762>>24370000
                begin   << output device doesn't exist>>                24375000
                  tos := 0;                                             24380000
                  tos := i;                                             24385000
                  tos := 10;                                            24390000
                  move binbuf := errmess1,(15),2;                       24395000
                  len1 := ascii(*,*,*);   <<convert device #>>          24400000
                  move binbuf(len1+15) := errmess2,(15);                24405000
                  print(inbuf, -30-len1,0);                             24410000
                  errors := true;                                       24415000
                end                                                     24420000
              else                                                      24425000
              begin <<illegal output device>>                           24430000
               index := ldt'device'type;                       <<06762>>24435000
               if (0<=index<=15) or (24<=index<=31) then                24440000
                 begin                                                  24445000
                  tos := 0;                                             24450000
                  tos := i;                                             24455000
                  tos := 10;                                            24460000
                  move binbuf := errmess1,(15),2;                       24465000
                  len1 := ascii(*,*,*);                                 24470000
                  move binbuf(len1+15) := errmess9,(25);                24475000
                  print(inbuf,-40-len1,0);                              24480000
                  errors := true;                                       24485000
                 end;                                                   24490000
               end;                                            <<06762>>24495000
              end;                                                      24500000
              index := ldev;                                            24505000
              while (index:=index+1) <= hldev do                        24510000
                begin                                          <<06762>>24515000
                get'ldev'entries(index);                       <<06762>>24520000
                if dvrdrtnum=drtn and dvrunitnum=unitn then    <<06762>>24525000
                begin     << two devices on same drt,unit >>   <<03007>>24530000
                type2 := ldt'device'type;                      <<06762>>24535000
                                                               <<03007>>24540000
                        << not both cs devices >>              <<03007>>24545000
                if not ( csdev17<= type <= csdev19 land        <<03007>>24550000
                         csdev17<= type2<= csdev19)            <<03007>>24555000
                                                               <<03007>>24560000
                and                                            <<03007>>24565000
                        << not both terminals on 33 >>         <<03007>>24570000
                not ( postseries3 land type=termdevtype        <<03007>>24575000
                      land type2=termdevtype)                  <<03007>>24580000
                                                               <<03007>>24585000
                and                                            <<03007>>24590000
                        << not both discs >>                   <<03007>>24595000
                not ( type&lsr(3)   = ldt'direct'access land   <<06762>>24600000
                      type2&lsr(3)  = ldt'direct'access)       <<06762>>24605000
                                                               <<03007>>24610000
                then                                           <<03007>>24615000
                  begin                                        <<03007>>24620000
                  << print message for more than one device >> <<03007>>24625000
                  << on the same drt and unit               >> <<03007>>24630000
                  move binbuf := errmess3,(5);                 <<03007>>24635000
                           << convert first ldev # >>          <<03007>>24640000
                  len1 := ascii( ldev,10,binbuf(5))+5;         <<03007>>24645000
                  move binbuf(len1) := errmess3(4),(10);       <<03007>>24650000
                           << convert 2nd ldev # >>            <<03007>>24655000
                  len2 := ascii( index,10,binbuf(len1+10))     <<03007>>24660000
                                                 + len1 + 10;  <<03007>>24665000
                  move binbuf(len2) := errmess3(13),(21);      <<03007>>24670000
                  print( inbuf, -len2-21, 0);                  <<03007>>24675000
                  errors := true;                              <<03007>>24680000
                  end;                                         <<03007>>24685000
                end;                                                    24690000
              if dvrdrtnum = drtn and                          <<d9021>>24695000
                 not compare'words(dvr'name, dvrname, 4)       <<d9021>>24700000
                 then begin                                    <<d9021>>24705000
                 type2 := ldt'device'type;                     <<d9021>>24710000
                 subtyp2 := lpdt'subtype;                      <<d9068>>24715000
                                                               <<d9021>>24720000
                      << not both cs devices >>                <<d9021>>24725000
                                                               <<d9021>>24730000
                                                               <<d9021>>24735000
                 if  csdev17<= type <= csdev19  and            <<d9068>>24740000
                     csdev17<= type2<= csdev19                 <<d9068>>24745000
                     then validdrivers := true                 <<d9068>>24750000
                                                               <<d9021>>24755000
                                                              <<<d9068>>24760000
                        << not both terminals  on 33 >>        <<d9021>>24765000
                 else if type = termdevtype then              <<<d9068>>24770000
                      begin                                  <<<<d9068>>24775000
                      if type2 = termdevtype  or               <<d9068>>24780000
                         rs232'printer(type2,subtyp2)          <<d9068>>24785000
                                                               <<d9068>>24790000
                         then validdrivers := true;            <<d9068>>24795000
                      end                                      <<d9068>>24800000
                 else if rs232'printer(type,subtyp) then       <<d9068>>24805000
                      begin                                    <<d9068>>24810000
                      if type2 = termdevtype or                <<d9068>>24815000
                         rs232'printer(type2, subtyp2)         <<d9068>>24820000
                         then validdrivers := true;            <<d9068>>24825000
                      end                                      <<d9068>>24830000
                 else begin                                    <<d9068>>24835000
                    <<--------------------------------->>      <<d9021>>24840000
                    << error: more than 1 device with  >>      <<d9021>>24845000
                    << different drivers on same drt#  >>      <<d9021>>24850000
                    <<--------------------------------->>      <<d9021>>24855000
                    message(m127, drtn);                       <<d9021>>24860000
                    errors := true;                            <<d9021>>24865000
                    end;                                       <<d9021>>24870000
                end;                                           <<d9021>>24875000
              end;                                             <<06762>>24880000
            end;                                                        24885000
           end;                                                         24890000
          @dct  := @dct'head + dcth'dct'base;                  <<06762>>24895000
          @dct'b := @dct & lsl(1);                             <<06762>>24900000
          i := 0;                                                       24905000
          while (i:=i+1) <= dcth'num'dct'entries do            <<06762>>24910000
            begin    <<search device class table>>                      24915000
              if dctb'class'name = "DISC    "                  <<06762>>24920000
                then discfound := true;                        <<06762>>24925000
              dct'term'class := 0;                             <<06762>>24930000
              dct'spool'queues := 0;                           <<06762>>24935000
              acctype := dct'class'acc'type;                   <<06762>>24940000
              if dct'class'acc'type = ldt'serial'disc          <<06762>>24945000
                then k := 0                                    <<06762>>24950000
              else k := dct'access'type;                       <<06762>>24955000
              allsame := true;                                          24960000
              get'ldev'entries(dct(dct'first'ldev));           <<06762>>24965000
              dtyp := ldt'device'type;                         <<06762>>24970000
              j := -1;                                         <<06762>>24975000
              if k=ldt'direct'access or                        <<06762>>24980000
                 k=ldt'io'concurrent then                      <<06762>>24985000
                begin                                                   24990000
                  while (j:=j+1) < dct'num'devices do          <<06762>>24995000
                  begin                                        <<06762>>25000000
                  get'ldev'entries(dct(dct'first'ldev+j));     <<06762>>25005000
                  if ldt'access'type <> k then                 <<06762>>25010000
                    begin  <<type ranges different>>           <<06762>>25015000
                    move binbuf := errmess5,(42),2;            <<06762>>25020000
                    move * := dctb'class'name,(8);             <<06762>>25025000
                    print(inbuf,-50,0);                        <<06762>>25030000
                    errors := true;                            <<06762>>25035000
                    goto nextindex;                            <<06762>>25040000
                    end                                        <<06762>>25045000
                  else                                         <<06762>>25050000
                    begin                                      <<06762>>25055000
                    if dtyp <> ldt'device'type                 <<06762>>25060000
                      then allsame:=false;                     <<06762>>25065000
                    if acctype = ldt'serial'disc or            <<06762>>25070000
                       acctype = ldt'foreign'disc then         <<06762>>25075000
                      begin                                    <<06762>>25080000
                        type := ldt'device'type;               <<06762>>25085000
                        subtyp := lpdt'subtype;                <<06762>>25090000
                        if not sdisc'type(type,subtyp) then    <<06762>>25095000
                          goto clcomer;                        <<06762>>25100000
                      end;                                     <<06762>>25105000
                    end;                                       <<06762>>25110000
                  end;                                         <<06762>>25115000
                end                                            <<06762>>25120000
              else                                                      25125000
                while (j:=j+1) < dct'num'devices do            <<06762>>25130000
                  begin                                                 25135000
                  get'ldev'entries(dct(dct'first'ldev+j));     <<06762>>25140000
                  ldevrange:=ldt'access'type;                  <<06762>>25145000
                  if ldevrange=ldt'direct'access then          <<06762>>25150000
   clcomer:         begin   <<type combination error in class>>         25155000
                    move binbuf := errmes11,(35),2;                     25160000
                    move * := dctb'class'name, (8);            <<06762>>25165000
                    print(inbuf,-43,0);                                 25170000
                    errors := true;                                     25175000
                    go nextindex;                                       25180000
                    end;                                                25185000
                  if (k=ldt'serial'in)                         <<06762>>25190000
                     and (ldevrange=ldt'serial'out)            <<06762>>25195000
                     or (k=ldt'serial'out)                     <<06762>>25200000
                     and (ldevrange=ldt'serial'in)             <<06762>>25205000
                     or (k=ldt'io'nonconcur)                   <<06762>>25210000
                     and (ldevrange<>ldt'io'nonconcur)         <<06762>>25215000
                     and (ldevrange<>ldt'io'concurrent)        <<06762>>25220000
                  then go clcomer;                                      25225000
                  if dtyp <> ldt'device'type                   <<06762>>25230000
                  then allsame := false;                       <<06762>>25235000
                  end;                                                  25240000
                if integer(dct'class'acc'type) <> k & lsl(3)   <<06762>>25245000
                   and not allsame                             <<06762>>25250000
                   and acctype <> ldt'serial'disc              <<06762>>25255000
                   and acctype <> ldt'foreign'disc then        <<06762>>25260000
                   goto clcomer;                               <<00072>>25265000
                if dct'class'acc'type = ldt'terminal           <<06762>>25270000
                   and allsame then                            <<06762>>25275000
                  dct'term'class := 1;                         <<06762>>25280000
  nextindex:                                                   <<06762>>25285000
              @dct := @dct + dct'next'entry;                   <<06762>>25290000
              @dct'b := @dct & lsl(1);                         <<06762>>25295000
            end;                                                        25300000
          if toobigdrt or bigusermaxdrt then                   <<03006>>25305000
            begin                                                       25310000
              tos := 0;                                                 25315000
              tos := comm(drtnum);                             <<07039>>25320000
              tos := 10;                                                25325000
              move binbuf := errmess6,(38),2;                  <<03006>>25330000
              len1 := ascii(*,*,*);                                     25335000
              print(inbuf,-38-len1,0);                         <<03006>>25340000
              if toobigdrt                                     <<03006>>25345000
              then errors:= true;  <<comm(drtnum) too small>>  <<07039>>25350000
            end;                                                        25355000
          if cpubigdrt or bigusermaxdrt                        <<03006>>25360000
          then begin                                           <<03006>>25365000
            move binbuf := errmess12,(46),2;                   <<03006>>25370000
            tos := tos +ascii(maxdrt,10,bps0);                 <<03006>>25375000
            len1:= tos-@binbuf;                                <<03006>>25380000
            print(inbuf,-len1,0);                              <<03006>>25385000
            warning:=true;                                     <<03006>>25390000
           end;                                                <<03006>>25395000
                                                               <<03006>>25400000
          if toobigdrt or cpubigdrt                            <<03006>>25405000
          then begin                                           <<03006>>25410000
            if comm(drtnum) <= maxdrt                          <<07039>>25415000
            then drtcutoff := comm(drtnum)                     <<07039>>25420000
            else drtcutoff := maxdrt;                          <<03006>>25425000
                                                               <<03006>>25430000
            move binbuf:=errmess13,(46);                       <<03006>>25435000
            print(inbuf,-46,0);                                <<03006>>25440000
                                                               <<03006>>25445000
            ldev := 0;                                         <<03006>>25450000
            while (ldev:= ldev+1) <= hldev do                  <<03006>>25455000
            begin                                              <<03006>>25460000
              get'ldev'entries(ldev);                          <<06762>>25465000
              drtn := dvrdrtnum;                               <<06762>>25470000
              unitn := dvrunitnum;                             <<06762>>25475000
              if (drtn <> 0 or unitn <> 0) and                 <<06762>>25480000
                 dvrdsbit = 0                                  <<06762>>25485000
              then if drtn > drtcutoff                         <<06762>>25490000
                   then begin                                  <<03006>>25495000
                      move binbuf:="  LDEV ",2;                <<03006>>25500000
                      tos:=tos+ascii(ldev,10,bps0);            <<03006>>25505000
                      move *:="   DRT ",2;                     <<03006>>25510000
                      tos:=tos+ascii(drtn,10,bps0);            <<06762>>25515000
                      len1:=tos-@binbuf;                       <<03006>>25520000
                      print(inbuf,-len1,0);                    <<03006>>25525000
                   end;                                        <<03006>>25530000
            end; <<while ldev < hldev>>                        <<03006>>25535000
         end; <<if toobigdrt or cpubigdrt>>                    <<03006>>25540000
                                                               <<03006>>25545000
          if consoleldev=0 then                                         25550000
            begin                                                       25555000
              message(m109);                                   <<*8393>>25560000
              errors := true;                                           25565000
            end;                                                        25570000
          get'ldev'entries(sysdisc);                           <<06762>>25575000
          if not non'ds'ldev(sysdisc) or                       <<03544>>25580000
            not sysdisc'type(ldt'device'type,lpdt'subtype)     <<06762>>25585000
            then begin    << ldev #1 is not system disc >>     <<06762>>25590000
              message(m105);<<system disc must be ldev 1>>     <<*8393>>25595000
              errors := true;                                           25600000
            end;                                                        25605000
          if dvrunitnum <> 0 then                              <<06762>>25610000
            begin                                                       25615000
              message(m103);  <<system disc must be unit 0>>   <<*8393>>25620000
              errors := true;                                           25625000
            end;                                                        25630000
          if not discfound then                                         25635000
            begin  <<no device in class disc>>                          25640000
              message(m107);                                   <<*8393>>25645000
              errors := true;                                           25650000
            end;                                                        25655000
          if errors  <<user specified too low a maxdrt>>       <<03006>>25660000
          then warning := false   <<must be corrected>>        <<03006>>25665000
          else if warning        <<optional correction>>       <<03006>>25670000
               then if yesanswer(m2008)   <<io config changes?><<*8393>>25675000
                    then io'config'ch  <<chooses to correct>>  <<03006>>25680000
                    else warning:=false;  <<declines offer>>   <<03006>>25685000
                                                               <<03006>>25690000
    end until not warning; <<exit if ok, error, or user>>      <<03006>>25695000
                           <<declines opportunity to>>         <<03006>>25700000
                           <<correct drt problem, ie. is>>     <<03006>>25705000
                           <<configuring for another cpu>>     <<03006>>25710000
          checkdev := not errors;                              <<01073>>25715000
      end <<checkdev>> ;                                                25720000
$control segment=iochange                                      <<01073>>25725000
                                                                        25730000
          <<--------------------------------                            25735000
            get id and component sequences                              25740000
          -------------------------------->>                            25745000
                                                                        25750000
  integer procedure getseq(errlabel,addr);                              25755000
    value errlabel;                                                     25760000
    integer errlabel;                                                   25765000
    byte array addr;                                                    25770000
      comment--                                                <<+0.06>>25775000
      value returned in getseq:                                <<+0.06>>25780000
           (0:8)-zero                                          <<+0.06>>25785000
           (8:2)-input type                                    <<+0.06>>25790000
           (10:6)-length                                       <<+0.06>>25795000
      end of comment;                                          <<+0.06>>25800000
      begin                                                             25805000
        integer type,len,i,j,index;                                     25810000
        logical temp,finished;                                          25815000
        EQUATE QUOT=%42,<<">>                                           25820000
               cr  =%15,<<carriage return>>                             25825000
               maxseqlen=16,<<max length in bytes>>                     25830000
               atyp=0,  <<input type ascii >>                           25835000
               etyp=1,  <<input type ebcdic>>                           25840000
               otyp=2,  <<input type octal >>                           25845000
               htyp=3;  <<input type hex   >>                           25850000
        byte pointer pntr;                                              25855000
          scan bpinbuf while blank,1;                                   25860000
          if carry then return; <<no input>>                            25865000
          if bps0="A" or bps0=quot then type:=atyp                      25870000
          else if bps0="E" then type:=etyp                              25875000
               else if bps0="O" then type:=otyp                         25880000
                    else if bps0="H" then type:=htyp                    25885000
                         else begin                                     25890000
  error:                      message(m2453);                  <<*8393>>25895000
                              returnp := errlabel;                      25900000
                              assemble(exit 3);                         25905000
                              end;                                      25910000
          if type=atyp or type=etyp then                                25915000
            begin  <<string ascii or ebcdic>>                           25920000
            if bps0="A" or bps0="E" then tos:=tos+1;                    25925000
            if bps0<>quot then goto error;                              25930000
            @pntr := tos+1;  <<point to first character>>               25935000
            len := -1;  <<index to adr(also counter>>                   25940000
  getchar:  finished := false;                                          25945000
            while not finished do                                       25950000
              begin <<get a character>>                                 25955000
              if pntr=cr then goto error;                               25960000
              if pntr=quot then finished:=true;                         25965000
              len := len+1;                                             25970000
              addr(len) := pntr;                                        25975000
              @pntr := @pntr+1;                                         25980000
              end;                                                      25985000
            if len>maxseqlen then goto error;                           25990000
            if pntr=quot then                                           25995000
              begin <<double quotes>>                                   26000000
              @pntr := @pntr+1; <<a quot is in sequence>>               26005000
              goto getchar;                                             26010000
              end;                                                      26015000
            scan pntr while blank;                                      26020000
            if nocarry then goto error;                                 26025000
            i := -1;                                                    26030000
            while(i:=i+1)<len do                                        26035000
              if not(%40<=integer(addr(i))<=%176) then                  26040000
                  type := otyp;                                         26045000
            if type=etyp then convert(1,addr,addr,len);        <<+0.06>>26050000
            <<ascii to ebcdic>>                                <<+0.06>>26055000
            end                                                         26060000
          else                                                          26065000
            begin  <<octal or hex>>                                     26070000
            finished := false;                                          26075000
            tos := tos+1;                                               26080000
            if bps0<>"(" then goto error;                               26085000
            tos := tos+1;                                               26090000
            len := 0;                                                   26095000
  nextnum:  scan * while blank,1;<<find first digit>>                   26100000
            if carry then goto error;                                   26105000
            if bps0=special then goto error;                            26110000
            assemble(dup,ddup);                                         26115000
            move *:=* while an,0;                                       26120000
            scan * while blank,1;                                       26125000
            if bps0<>"," then finished:=true;                           26130000
            temp := tos+1;                                              26135000
            assemble(xch,sub);<<compute length>>                        26140000
            if type=otyp and s0>3 or type=htyp and s0>2                 26145000
               then goto error; <<too many digits>>                     26150000
            j := tos;   <<# of digits>>                                 26155000
            @pntr := tos;<<start first digit in this num>>              26160000
            if type=otyp then                                           26165000
              begin <<octal>>                                           26170000
              i := -1;                                                  26175000
              while(i:=i+1)<j do                                        26180000
                if pntr(i)>%67 then goto error;<<not octal>>            26185000
              pntr(-1):="%";                                            26190000
              addr(len) := binary(pntr(-1),j+1);                        26195000
              end                                                       26200000
            else                                                        26205000
              begin <<hex>>                                             26210000
              i := j;                                                   26215000
              while(i:=i-1)>=0 do                                       26220000
                begin                                                   26225000
                x := pntr(i);                                           26230000
                if ("0"<=x<="9") then tos:=x-%60                        26235000
                else if ("A"<=x<="F") then tos:=x-%67                   26240000
                     else goto error;                                   26245000
                end;                                                    26250000
              if j=2 then                                               26255000
                begin <<two digits in this number>>                     26260000
                tos := tos*%20;                                         26265000
                tos := tos+tos; <<add top two words>>                   26270000
                end;                                                    26275000
              addr(len):=tos;                                           26280000
              end;                                                      26285000
            len := len+1;                                               26290000
            if not finished then                                        26295000
              begin                                                     26300000
              tos := temp;                                              26305000
              goto nextnum;                                             26310000
              end;                                                      26315000
            if len>maxseqlen then goto error;                           26320000
            tos := temp-1;                                              26325000
            if bps0<>")" then goto error;                               26330000
            tos := tos+1;                                               26335000
            scan * while blank;                                         26340000
            if nocarry then goto error;                                 26345000
            end;                                                        26350000
        getseq := type&lsl(6)+len;                                      26355000
        end <<getseq>>;                                                 26360000
$control segment=systemch                                      <<01073>>26365000
                                                                        26370000
           <<-------------                                              26375000
             find volume                                                26380000
           ------------->>                                              26385000
  integer procedure findvol(name);                                      26390000
    byte array name;          <<volume name>>                           26395000
    option privileged,uncallable;                                       26400000
      begin                                                             26405000
        integer i:=0;                                          <<01549>>26410000
          while (i:=i+1) <= hvol do                                     26415000
            begin                                                       26420000
              tos := @vtab(i*vtabsize)&lsl(1);   <<ptr to name>>        26425000
              if *=name,(8) then                                        26430000
                begin   <<match>>                                       26435000
                  findvol := x;                                         26440000
                  cc := cce;                                            26445000
                  return;                                               26450000
                end;                                                    26455000
            end;                                                        26460000
          cc := ccg;   <<not found>>                                    26465000
      end <<findvol>>;                                                  26470000
integer procedure getvol(ldev);                                <<01549>>26475000
  value ldev;                                                  <<01549>>26480000
  integer ldev;                                                <<01549>>26485000
  comment: convert ldev to system domain volume number.        <<01549>>26490000
  ;                                                            <<01549>>26495000
  begin                                                        <<01549>>26500000
  integer i := 0;                                              <<01549>>26505000
  cc := cce;                                                   <<01549>>26510000
  if ldev > 0 then                                             <<01549>>26515000
    while (i:=i+1) <= hvol do                                  <<01549>>26520000
      if vtab(i*vtabsize+vtab12).vtabldev=ldev then            <<01549>>26525000
        begin  << found it >>                                  <<01549>>26530000
        getvol := i;                                           <<01549>>26535000
        return;                                                <<01549>>26540000
        end;                                                   <<01549>>26545000
  cc := ccl;                                                   <<01549>>26550000
  end; << getvol >>                                            <<01549>>26555000
integer procedure getldev(volume);                             <<01549>>26560000
  value volume;                                                <<01549>>26565000
  integer volume;                                              <<01549>>26570000
  begin                                                        <<01549>>26575000
  comment: convert volume number to ldev.                      <<01549>>26580000
  ;                                                            <<01549>>26585000
  if volume <= hvol then                                       <<01549>>26590000
    begin                                                      <<01549>>26595000
    getldev := vtab(volume*vtabsize+vtab12).vtabldev;          <<01549>>26600000
    cc := cce;                                                 <<01549>>26605000
    end                                                        <<01549>>26610000
  else                                                         <<01549>>26615000
    cc := ccl;                                                 <<01549>>26620000
  end;  << getldev >>                                          <<01549>>26625000
$control segment=systemch                                      <<01073>>26630000
                                                                        26635000
          <<-------------------                                         26640000
            list volume table                                           26645000
          ------------------->>                                         26650000
  procedure listvol;                                                    26655000
    option privileged,uncallable;                                       26660000
        begin                                                           26665000
          integer i:=0,j;                                               26670000
          move inbuf :=                                                 26675000
            "VOLUME #    NAME    LOG DEV # ";                           26680000
          fwrite(listfnum,inbuf,15,0);                                  26685000
  listerr:if <> then ferror(listfnum,listfile);                         26690000
          while (i:=i+1) <= hvol do                                     26695000
          if vtab(i*vtabsize)<>0 then                                   26700000
            begin   <<live entry>>                                      26705000
              inbuf := "  ";                                            26710000
              move inbuf(1) := inbuf,(12);                              26715000
              ascii(i,10,binbuf(3));                                    26720000
              move inbuf(5) := vtab(i*vtabsize),(4);                    26725000
              j := ascii(vtab(x:=x+12).(0:8),10,binbuf(23));            26730000
              fwrite(listfnum,inbuf,-23-j,0);                           26735000
              if <> then goto listerr;                                  26740000
            end;                                                        26745000
          fwrite(listfnum,inbuf,0,%61);                                 26750000
          if <> then goto listerr;                                      26755000
      end <<listvol>> ;                                                 26760000
procedure listvm;                                              <<01549>>26765000
comment:  print listing of the virtual memory allocation on    <<01549>>26770000
the system volumes.                                            <<01549>>26775000
;                                                              <<01549>>26780000
begin                                                          <<01549>>26785000
double  sectors;         << # sectors allocated >>             <<01549>>26790000
integer ldev,            << ldev # of corresponding volume >>  <<01549>>26795000
        sectors1         = sectors,                            <<01549>>26800000
        sectors2         = sectors+1,                          <<01549>>26805000
        volume := 0,     << volume index >>                    <<01549>>26810000
        j;               << length of ascii number >>          <<01549>>26815000
                                                               <<01549>>26820000
move inbuf := "VOLUME NAME   LDEV #   VM ALLOCATION";          <<01549>>26825000
fwrite(listfnum, inbuf, 18, 0);                                <<01549>>26830000
if <> then ferror(listfnum, listfile);                         <<01549>>26835000
while (volume := volume+1) <= hvol do                          <<01549>>26840000
  if vtab(volume*vtabsize) <> 0 then                           <<01549>>26845000
    begin                                                      <<01549>>26850000
    inbuf := "  ";                                             <<01549>>26855000
      move inbuf(1) := inbuf,(inbuflen-1);  <<clear out buf>>  <<01570>>26860000
    move inbuf(1) := vtab(volume*vtabsize), (4);  << vol name>><<01549>>26865000
    ldev := getldev(volume);                                   <<01549>>26870000
    ascii(ldev, 10, inbuf(7));                                 <<01549>>26875000
    sectors1 := vtab(volume*vtabsize+vtab10);                  <<01549>>26880000
    sectors2 := vtab(x:=x+1);                                  <<01549>>26885000
    j := dascii( (sectors/1024d), 10, inbuf(12) );             <<01549>>26890000
    fwrite(listfnum, inbuf, -(j+24), %40);                     <<01549>>26895000
    if <> then ferror(listfnum, listfile);                     <<01549>>26900000
    end;                                                       <<01549>>26905000
fwrite(listfnum, inbuf, 0, %61);                               <<01549>>26910000
if <> then ferror(listfnum, listfile);                         <<01549>>26915000
end;  << listvm >>                                             <<01549>>26920000
$control segment=systemch                                      <<01073>>26925000
                                                                        26930000
          <<----------------------                                      26935000
            list logging status                                         26940000
          ---------------------->>                                      26945000
  procedure listlog;                                                    26950000
    option privileged,uncallable;                                       26955000
      begin                                                             26960000
        byte array events(*)=pb:=15,"LOGGING ENABLED",14,               26965000
          "JOB INITIATION",15,"JOB TERMINATION",19,"PROCESS ",          26970000
          "TERMINATION",10,"FILE CLOSE",15,"SYSTEM SHUTDOWN",10,        26975000
          "POWER FAIL",8,"SPOOLING",18,"LINE DISCONNECTION",10,         26980000
          "LINE CLOSE",9,"I/O ERROR",                          <<rh.pv>>26985000
          12,"VOLUME MOUNT",                                   <<rh.pv>>26990000
        16,"VOLUME SET MOUNT",11,"TAPE LABELS",7,"CONSOLE",    <<01762>>26995000
        18,"PROGRAM FILE EVENT",19,"CALL PROGRESS SGNLS",      <<04251>>27000000
        17,"DCE PROVIDED INFO";                                <<04251>>27005000
        integer array head(0:15)=pb:="TYPE         EVENT       STATUS ";27010000
        integer i:=1;                                                   27015000
          move inbuf := head,(16);                                      27020000
          fwrite(listfnum,inbuf,-31,0);  <<print heading>>              27025000
          if <> then goto listerr;                                      27030000
          do                                                            27035000
            begin  <<list status of each logging type>>                 27040000
              inbuf := "  ";                                            27045000
              move inbuf(1) := inbuf,(19);                              27050000
              ascii(i,10,binbuf(2));                                    27055000
              tos := @binbuf(6);                                        27060000
              x := -1;                                                  27065000
              tos := 0;                                                 27070000
              tos := @bs0+1;                                            27075000
              tos := @events;                                           27080000
              while (x:=x+1) < i do                                     27085000
                begin  <<find correct message>>                         27090000
                  tos := tos+s2;                                        27095000
                  move * := * pb,(1),1;                                 27100000
                  assemble(decb);  <<point s-1 to s-2;>>                27105000
                end;                                                    27110000
              assemble(delb,xch; mvb pb,3);  <<move message to buffer>> 27115000
              tos := @binbuf(27);                                       27120000
        tos:= ctab0(logbits+i/16);         <<get event word>>  <<01762>>27125000
        x:= 15 - i mod 16;                      <<event bit>>  <<01762>>27130000
              assemble(tbc 0,x);                                        27135000
              del;                                                      27140000
              if = then move * := "OFF" else move * := "ON";            27145000
              fwrite(listfnum,inbuf,-30,0);                             27150000
  listerr:    if <> then ferror(listfnum,listfile);                     27155000
            end                                                         27160000
         until (i:=i+1)>logrmax;                               <<00094>>27165000
<<>>                                                           <<ks.01>>27170000
          fwrite(listfnum,inbuf,0,%61);                                 27175000
          if <> then goto listerr;                                      27180000
      end <<listlog>> ;                                                 27185000
$control segment=systemch                                      <<01073>>27190000
                                                                        27195000
       <<-------------------->>                                <<06814>>27200000
       <<   list rin table   >>                                <<06814>>27205000
       <<-------------------->>                                <<06814>>27210000
                                                               <<06814>>27215000
procedure listrin;                                             <<06814>>27220000
   option privileged,uncallable;                               <<06814>>27225000
begin                                                          <<06814>>27230000
   integer i := 0;                                             <<06814>>27235000
   integer loc;  << holds one location from rin table >>       <<06814>>27240000
   integer glarea;  << disp to global area >>                  <<06814>>27245000
   array useracct(0:7) = q;                                    <<06814>>27250000
   integer array head(0:11)=pb:="RIN #  USERNAME.ACCTNAME";    <<06814>>27255000
                                                               <<06814>>27260000
   mfds( glarea, rindseg, 1, 1);                               <<06814>>27265000
   move inbuf := head,(12);                                    <<06814>>27270000
   fwrite(listfnum,inbuf,12,0);                                <<06814>>27275000
   if <> then ferror(listfnum,listfile);                       <<06814>>27280000
   while (i:=i+1) <= rins do                                   <<06814>>27285000
      begin                                                    <<06814>>27290000
      mfds( loc, rindseg, i*3, 1);                             <<06814>>27295000
      if loc.(0:2) = 2 then                                    <<06814>>27300000
         begin  <<a global rin>>                               <<06814>>27305000
         inbuf := "  ";                                        <<06814>>27310000
         move inbuf(1) := inbuf,(11);                          <<06814>>27315000
         ascii(i,10,binbuf(1)); <<rin #>>                      <<06814>>27320000
         mfds( useracct, rindseg, loc.(2:14)+glarea+4, 8);     <<06814>>27325000
         tos := @binbuf(7);                                    <<06814>>27330000
         tos := @useracct&lsl(1);                              <<06814>>27335000
         move * := *,(8),1;  <<username>>                      <<06814>>27340000
         bps1 := ".";                                          <<06814>>27345000
         assemble(incb);                                       <<06814>>27350000
         move * := *,(8);                                      <<06814>>27355000
         fwrite(listfnum,inbuf,12,0);                          <<06814>>27360000
         if <> then ferror(listfnum,listfile);                 <<06814>>27365000
         end;                                                  <<06814>>27370000
      end;                                                     <<06814>>27375000
   fwrite(listfnum,inbuf,0,%61);                               <<06814>>27380000
   if <> then ferror(listfnum,listfile);                       <<06814>>27385000
end << listrin >> ;                                            <<06814>>27390000
$control segment=systemch                                      <<01073>>27395000
       <<----------------------->>                             <<06814>>27400000
       <<   compact rin table   >>                             <<06814>>27405000
       <<----------------------->>                             <<06814>>27410000
                                                               <<06814>>27415000
procedure compactrin;                                          <<06814>>27420000
   option privileged,uncallable;                               <<06814>>27425000
begin                                                          <<06814>>27430000
   integer array buf(0:11) = q;                                <<06814>>27435000
   integer                                                     <<06814>>27440000
      curfree,                                                 <<06814>>27445000
      current,                                                 <<06814>>27450000
      glarea,   << disp to global area >>                      <<06814>>27455000
      rins',    << local copy of rins >>                       <<07386>>27460000
      grins',   << local copy of grins >>                      <<07386>>27465000
      i,                                                       <<06814>>27470000
      j;                                                       <<06814>>27475000
   integer array                                               <<07386>>27480000
      rin(*)     = db+0,                                       <<07386>>27485000
      glrin(@)   = db+1;                                       <<07386>>27490000
                                                               <<06814>>27495000
   mfds( glarea, rindseg, 1, 1);                               <<06814>>27500000
   if grins = 0 then                                           <<06814>>27505000
      begin  << no global rins >>                              <<06814>>27510000
      mingrin := 0;                                            <<06814>>27515000
      minrin := 5;                                             <<06814>>27520000
      zerobuf( buf, 4);                                        <<06814>>27525000
      mtds( rindseg, glarea, buf, 4);                          <<06814>>27530000
      return;                                                  <<06814>>27535000
      end;                                                     <<06814>>27540000
                                                               <<06814>>27545000
   rins' := rins;                                              <<07386>>27550000
   grins' := grins;                                            <<07386>>27555000
   current := curfree := 4;                                    <<06814>>27560000
   exchangedb( rindseg);                                       <<07386>>27565000
   i := -1;                                                    <<07386>>27570000
   while (i:=i+1) < grins' do                                  <<07386>>27575000
      begin                                                    <<07386>>27580000
      j := 0;                                                  <<07386>>27585000
      while (j:=j+1) <= rins' do                               <<07386>>27590000
         begin                                                 <<07386>>27595000
         if rin(j*3).(0:2) = 2 and rin(x).(2:14) = current then<<07386>>27600000
            begin  << found it >>                              <<07386>>27605000
            rin(x).(2:14) := curfree;                          <<07386>>27610000
            move glrin(curfree) := glrin(current),(12);        <<07386>>27615000
            curfree := curfree+12;                             <<07386>>27620000
            j := rins';  << terminate loop >>                  <<07386>>27625000
            end;                                               <<07386>>27630000
         end;                                                  <<07386>>27635000
      current := current+12;                                   <<07386>>27640000
      end;                                                     <<07386>>27645000
   exchangedb( 0 );                                            <<07386>>27650000
                                                               <<06814>>27655000
   << initialize global area header >>                         <<06814>>27660000
   mingrin := (curfree)/12; << min # of globals >>             <<06814>>27665000
   buf := if mingrin = grins then 0 else curfree;              <<06814>>27670000
   buf(1) := grins;                                            <<06814>>27675000
   buf(2) := grins-mingrin;                                    <<06814>>27680000
   buf(3) := 0;                                                <<06814>>27685000
   mtds( rindseg, glarea, buf, 4);                             <<06814>>27690000
                                                               <<06814>>27695000
   << build global area free list >>                           <<06814>>27700000
   if mingrin < grins then                                     <<07386>>27705000
      begin                                                    <<06814>>27710000
      zerobuf( buf, 12);                                       <<06814>>27715000
      j := curfree;  << first free entry >>                    <<06814>>27720000
      i := mingrin; << start of list >>                        <<07386>>27725000
      while (i:=i+1) < grins do                                <<06814>>27730000
         begin  << link up free list >>                        <<06814>>27735000
         buf := j+12;                                          <<06814>>27740000
         mtds( rindseg, glarea+j, buf, 12);                    <<07386>>27745000
         j := j+12;                                            <<06814>>27750000
         end;                                                  <<06814>>27755000
      buf := 0;                                                <<06814>>27760000
      mtds( rindseg, glarea+j, buf, 12);                       <<07386>>27765000
      end;                                                     <<06814>>27770000
                                                               <<06814>>27775000
   minrin := rins+1;                                           <<06814>>27780000
   while (minrin:=minrin-1) > 5 do                             <<06814>>27785000
      begin                                                    <<06814>>27790000
      mfds( buf, rindseg, minrin*3, 1);                        <<06814>>27795000
      if buf.(0:2) = 2 then goto done;                         <<06814>>27800000
      end;                                                     <<06814>>27805000
done:                                                          <<06814>>27810000
end << compactrin >> ;                                         <<06814>>27815000
$control segment=iochange                                      <<01073>>27820000
          <<------------------------                                    27825000
            move tables in dl area                                      27830000
          ------------------------>>                                    27835000
  procedure movedltables;                                               27840000
    option privileged,uncallable;                                       27845000
    comment                                                             27850000
      expands and contracts tables in the dl area, using following      27855000
    globals:                                                            27860000
        dllen - current dl area size (negative words)                   27865000
        tableptrs - array of pointers to the tables                     27870000
        tableincrs - array containing number of words each table is to  27875000
                     be incremented or decremented;                     27880000
      begin                                                             27885000
        integer array offsets(0:exptables-1)=q;    <<offset for each    27890000
                                                     expandable table>> 27895000
        integer i,j,       <<loop control>>                             27900000
                nwords,    <<number of words for current offset>>       27905000
                lastmoved, <<index of last table moved>>                27910000
                newsize;   <<new size of dl area>>                      27915000
        subroutine expand;                                              27920000
        comment                                                         27925000
          expands a portion of the dl area by nwords words and zeroes   27930000
        the resulting hole. if necessary, calls dlsize to get more      27935000
        space. also updates pointers to those tables moved;             27940000
        begin                                                           27945000
          if nwords=0 then return;                                      27950000
          if (j:=lastmoved+1)=0 and (newsize:=tableptrs-nwords)<dllen   27955000
          then                                                          27960000
            begin <<not enough room in dl area (first time called)>>    27965000
              dllen := dlsize(newsize);                                 27970000
              if <> then                                                27975000
                begin                                                   27980000
                  message(m2466);<<unable to obtain stack space<<*8393>>27985000
                  purgetempsl;                                 <<*7833>>27990000
                end;                                                    27995000
            end;                                                        28000000
          tos := tableptrs(j);                                          28005000
          tos := s0-nwords;   <<destination for move>>                  28010000
          assemble(xch,dup);                                            28015000
          tos := tableptrs(i);                                          28020000
          assemble(sub,neg; move 2); <<move portion of table>>          28025000
          ps0 := 0;                                                     28030000
          assemble(dup,incb);                                           28035000
          tos := nwords-1;                                              28040000
          assemble(move 3);  <<zero expanded area>>                     28045000
        <<update pointers to moved tables>>                             28050000
          do tableptrs(x) := tableptrs(j)-nwords until (j:=j+1)=i;      28055000
        end <<expand>> ;                                                28060000
        subroutine contract;                                            28065000
        comment                                                         28070000
          contracts a portion of the dl area by -nwords words. if this  28075000
        routine is called to move the upper (dl) end of the table and   28080000
        the contraction results in the table being more than 128 words  28085000
        smaller than the current value of dl, dlsize is called to return28090000
        the extra space. also, pointers to any affected tables are      28095000
        updated on each call;                                           28100000
        begin                                                           28105000
          if nwords=0 then return;                                      28110000
          tos := tableptrs(lastmoved)-1;  <<destination ptr>>           28115000
          tos := s0+nwords;  <<source for move>>                        28120000
          tos := -s0+tableptrs(i+1)-1;  <<negative word count>>         28125000
          assemble (move 3);  <<move tables>>                           28130000
          do tableptrs(x) := tableptrs(x)-nwords                        28135000
          until (x:=x+1)=lastmoved;  <<update ptrs to moved tables>>    28140000
          if i<0 and tableptrs>=dllen+128 then                          28145000
            begin <<return some space>>                                 28150000
              dllen := dlsize(tableptrs);                               28155000
              if <> then                                                28160000
                begin                                                   28165000
                  message(m2466);<<unable to obtain stack space<<*8393>>28170000
                  purgetempsl;                                 <<*7833>>28175000
                end;                                                    28180000
            end;                                                        28185000
        end <<contract>> ;                                              28190000
          @blinbuf := wordaddress(blinbuf);<<conv to word ptr>><<03704>>28195000
          offsets := 0;                                                 28200000
          move offsets(1) := offsets,(exptables-1);                     28205000
          i := 0;                                                       28210000
          do if (nwords:=tableincrs(i)) <> 0 then                       28215000
            begin                                                       28220000
              x := 0;                                                   28225000
              do offsets(x) := offsets(x)+nwords until (x:=x+1)>i;      28230000
              tableincrs(i) := 0;                                       28235000
            end                                                         28240000
          until (i:=i+1) = exptables;                                   28245000
          nwords := offsets;                                            28250000
          if < then                                                     28255000
            begin <<contracting table>>                                 28260000
              lastmoved := exptables;                                   28265000
              nwords := offsets(exptables-1);                           28270000
              i := x-1;                                                 28275000
              do if offsets(i) <> nwords then                           28280000
                begin <<next portion of table to be contracted more,    28285000
                        so move everything up to this point which hasn't28290000
                        been moved yet>>                                28295000
                  contract;                                             28300000
                  lastmoved := i+1;                                     28305000
                  nwords := offsets(i);                                 28310000
                end                                                     28315000
              until (i:=i-1)<0;                                         28320000
              contract;   <<finish moving rest of tables>>              28325000
            end                                                         28330000
          else                                                          28335000
            begin  <<expanding table>>                                  28340000
              lastmoved := -1; <<index to last table moved>>            28345000
              i := 1;                                                   28350000
              do if offsets(i) <> nwords then                           28355000
                begin <<next portion to be moved a different amount, so 28360000
                        move everything up to this point which hasn't   28365000
                        been moved yet>>                                28370000
                  expand;                                               28375000
                  lastmoved := i-1;                                     28380000
                  nwords := offsets(i);                                 28385000
                end                                                     28390000
              until (i:=i+1)=exptables;                                 28395000
              expand; <<finish moving rest of tables>>                  28400000
            end;                                                        28405000
          @blinbuf := @blinbuf&lsl(1); <<return to byte ptr>>  <<03704>>28410000
      end <<movedltables>> ;                                            28415000
$page "TAPE DUMP PROCEDURES"                                            28420000
integer procedure flblchecksum( flblbuf);                      <<03604>>28425000
   logical array flblbuf;                                      <<03604>>28430000
begin                                                          <<03604>>28435000
   << compute new checksum >>                                  <<03604>>28440000
   x := 127;                                                   <<03604>>28445000
   tos := -1;                                                  <<03604>>28450000
   do begin                                                    <<03604>>28455000
      if x <> flchecksumx and x <> flmiscx and                 <<03604>>28460000
         x <> flclidx then                                     <<03604>>28465000
         tos := tos xor flblbuf(x);                            <<03604>>28470000
      x := x-1;                                                <<03604>>28475000
      end until <;                                             <<03604>>28480000
   flblchecksum := tos;                                        <<03604>>28485000
end;                                                           <<03604>>28490000
$control segment=dumptape                                      <<01073>>28495000
                                                                        28500000
   procedure massageinin(ldev,eof,diskadr);                             28505000
     value ldev,eof,diskadr;                                            28510000
     integer ldev;                                                      28515000
     double eof,diskadr;                                                28520000
       begin                                                            28525000
       integer diskadr1=diskadr,                                        28530000
                diskadr2=diskadr+1,                                     28535000
                numfull,                                                28540000
                numextra,                                               28545000
                ininsize,                                      <<03604>>28550000
                lstt,                                                   28555000
                istt;                                                   28560000
      equate maxininsize = 4480;  << size of lbuf >>           <<01997>>28565000
      integer array stt(0:383),                                <<01997>>28570000
                    buffer(*) = lbuf; <<buffer for inin file>> <<01997>>28575000
      double array dbufr(*)=lbuf;                              <<01997>>28580000
      integer pointer code,prog,ostt,bufr;                              28585000
      equate obs  = 73,    <<outer block length>>                       28590000
             lent = 70,    <<last entry index for table in ob>>         28595000
             recl = 128;   <<record length>>                            28600000
      integer i,j;                                                      28605000
                                                                        28610000
  comment                                                               28615000
                                                                        28620000
    this procedure reformats the new inin file & write it to tape.      28625000
    reformatting is done by reassigning the stt numbers assigned        28630000
    by the segmenter. the dummy outer block space will be realeased     28635000
    by moving the program code over it.  the outer block is assumed     28640000
    to be the first thing in the file & file assumed to be 1 extent.    28645000
                                                                        28650000
    n.b. inin may have only 1 internal procedure.                       28655000
                                                                        28660000
    there will be an area of garbage between the code and stt           28665000
    as the segment length will be left unchanged. a procedure's         28670000
    address in the segment is to found by subtracting the               28675000
    outer block length from the address found on the pmap.              28680000
                                                                        28685000
    ;                                                                   28690000
                                                                        28695000
      subroutine ioerrcheck(b,a);                                       28700000
        value b,a;                                                      28705000
        integer b,a;                                                    28710000
          begin                                                         28715000
          tos := b.(8:8);                                               28720000
          if s0<> 1 then                                                28725000
            begin                                                       28730000
            tos := -tos;                                                28735000
            ferror(*,fullname);                                         28740000
            end;                                                        28745000
          del;                                                          28750000
      end <<ioerrcheck>>;                                               28755000
                                                                        28760000
          if flnumexts>0 then                                           28765000
            begin <<expect 1 extent>>                                   28770000
            message(m2611);                                    <<*8393>>28775000
            purgetempsl;                                                28780000
            end;                                                        28785000
          @prog := @buffer+flsectoff&lsl(7);                            28790000
          @code := @prog+recl;                                          28795000
          @bufr := @buffer;                                             28800000
          tos := integer(eof)+flsectoff;                                28805000
          ininsize := s0&lsl(7);                               <<03604>>28810000
          if s0&lsl(7) > maxininsize then                      <<01997>>28815000
             begin                                             <<01997>>28820000
             message(m2612); << max inin size exceeded >>      <<*8393>>28825000
             purgetempsl;                                      <<01997>>28830000
             end;                                              <<01997>>28835000
          tos := 8;                                                     28840000
          assemble(div);                                                28845000
          numextra := tos&lsl(7);                                       28850000
          numfull := tos;                                               28855000
          j := -1;                                                      28860000
          while(j:=j+1)<numfull do                                      28865000
            begin                                                       28870000
            tos := attachio(ldev,0,0,@bufr,0,1024,diskadr1,diskadr2,1); 28875000
            ioerrcheck(*,*);                                            28880000
            diskadr := diskadr+8d;                                      28885000
            @bufr := @bufr+1024;                                        28890000
            end;                                                        28895000
          if numextra>0 then                                            28900000
            begin                                                       28905000
            tos := attachio(ldev,0,0,@bufr,0,numextra,diskadr1,         28910000
                                             diskadr2,1);               28915000
            ioerrcheck(*,*);                                            28920000
            end;                                                        28925000
                                                                        28930000
          <<build the stt remapping array>>                             28935000
                                                                        28940000
          stt := 0;                                                     28945000
          move stt(1) := stt,(383);                            <<01997>>28950000
          for i:=0 step 2 until lent do                                 28955000
            stt(code(i+1).(8:8)) := code(i);                            28960000
                                                                        28965000
          <<add entries from external list and fixup list>>             28970000
                                                                        28975000
          i := 37;                                                      28980000
          j := prog(13)*recl;  <<start of external list>>               28985000
          while prog(j)<>0 do                                           28990000
            begin                                                       28995000
            j := j+prog(j).(4:4)&lsr(1)+2; <<step to stt# in entry>>    29000000
            stt(prog(j).(0:8)) := (i:=i+1);  <<set table>>              29005000
            prog(j).(0:8) := i;   <<se new stt>>                        29010000
            j := j+2;  <<step over junk to next entry>>                 29015000
            end;                                                        29020000
          lstt := i;     <<stt length for new inin>>                    29025000
                                                                        29030000
          <<change stt#'s in pcal's and llbl's>>                        29035000
                                                                        29040000
          for i:=obs until prog(%35).(1:15)-1 do                        29045000
            if %33401<=code(i)<=%33777 or %31001<=code(i)<=%31377 then  29050000
              begin                                                     29055000
              tos := stt(code(i).(8:8));                                29060000
              if = then                                                 29065000
                begin                                                   29070000
                del;                                                    29075000
                tos := 37;                                              29080000
                istt := x;                                              29085000
                end;                                                    29090000
              code(i) := code(i).(0:8)&lsl(8)+tos;                      29095000
              end;                                                      29100000
                                                                        29105000
          <<build the new stt in stt array>>                            29110000
                                                                        29115000
          @ostt := @code(i-1);                                          29120000
          for i:=0 step 2 until lent do                                 29125000
            stt(code(i)) := ostt(-code(i+1).(8:8))-obs;                 29130000
          stt(0) := lstt+%40000;                                        29135000
          for i:=38 until lstt do stt(i) := -1;                         29140000
          stt(37) := ostt(-istt)-obs;  <<set internal stt value>>       29145000
                                                                        29150000
          <<move code block and add new stt>>                           29155000
                                                                        29160000
          move code:=code(obs),(prog(%35).(1:15)-obs);                  29165000
          for i:=0 until lstt do                                        29170000
            ostt(-i) := stt(i);                                         29175000
                                                                        29180000
          <<set label and write out to tape>>                           29185000
                                                                        29190000
          move buffer := "ININ    ";                                    29195000
          move buffer(4) := "PUB     ";                                 29200000
          move buffer(8) := "SYS     ";                                 29205000
          move buffer(12) := "MANAGER ";                                29210000
          buffer(21) := %4000;  <<l:any/x:nobody>>                      29215000
          buffer(20) := %20202; <<r,a,w:any>>                           29220000
          buffer(22) := 1;      <<secure>>                              29225000
          buffer(36) := 1;      <<foptions>>                            29230000
          dbufr(21)  := eof;                                            29235000
          buffer(flchecksumx) := flblchecksum( buffer);        <<03604>>29240000
          writetape( buffer, ininsize, 0);                     <<03604>>29245000
      end <<masageinin>>;                                               29250000
procedure readdevfile( tablenr, buf, length);                  <<06763>>29255000
   value tablenr;                                              <<06763>>29260000
   integer tablenr, length;                                    <<06763>>29265000
   integer array buf;                                          <<06763>>29270000
begin                                                          <<06763>>29275000
   integer inx;                                                <<06763>>29280000
                                                               <<06763>>29285000
   inx := devtabenties + tablenr*2;                            <<06763>>29290000
   length := devrec0(inx+1);                                   <<06763>>29295000
   freaddir( devfnum, buf, length, double(devrec0(inx)));      <<06763>>29300000
   if <> then ferror( devfnum, devfile);                       <<06763>>29305000
end;                                                           <<06763>>29310000
integer procedure getdevtabsize( tablenr);                     <<06763>>29315000
   value tablenr;                                              <<06763>>29320000
   integer tablenr;                                            <<06763>>29325000
begin                                                          <<06763>>29330000
   getdevtabsize := devrec0( devtabenties + tablenr*2 +1);     <<06763>>29335000
end;                                                           <<06763>>29340000
$control segment=dumptape                                      <<01073>>29345000
                                                               <<00072>>29350000
procedure nextreel;                                            <<00072>>29355000
begin                                                          <<00072>>29360000
integer array header (*) = pb:="SYSDUMP/INITIAL DISC",30(0);   <<04659>>29365000
integer array buf(0:3);                                        <<00072>>29370000
integer array buff(0:39);                                      <<00072>>29375000
integer length;                                                <<00072>>29380000
byte array bbuf(*)=buf;                                        <<00072>>29385000
equate cr=%15,                                                 <<00072>>29390000
       lf=%12;                                                 <<00072>>29395000
                                                               <<00072>>29400000
move buff:=header,(40);                                        <<00072>>29405000
buff(10):=reelnum;                                             <<00072>>29410000
buff(11):=date;                                                <<00072>>29415000
buff(12):=time1;                                               <<00072>>29420000
buff(13):=time2;                                               <<00072>>29425000
fwrite(tapefnum,buff,40,0);                                    <<00072>>29430000
if > then ferror(tapefnum,tapefile);                           <<00493>>29435000
if < then                                                      <<00493>>29440000
  begin                                                        <<00493>>29445000
  fcheck(tapefnum,errorcode);                                  <<00493>>29450000
  if errorcode<>eotcode then                                   <<00493>>29455000
    ferror(tapefnum,tapefile);                                 <<00493>>29460000
  end;                                                         <<00493>>29465000
fcontrol(tapefnum,6,i);                                        <<00493>>29470000
fcontrol(tapefnum,6,i);                                        <<00493>>29475000
fcontrol(tapefnum,9,i);                                        <<00493>>29480000
message(m2291); <<mount next reel>>                            <<*8393>>29485000
reelnum:=reelnum+1;                                            <<00072>>29490000
buff(10):=reelnum;                                             <<00072>>29495000
length:=ascii(reelnum,10,bbuf);                                <<00072>>29500000
bbuf(length):=cr;                                              <<00072>>29505000
bbuf(length+1):=lf;                                            <<00072>>29510000
print(buf,-length,0);                                          <<00072>>29515000
fwrite(tapefnum,buff,40,0);                                    <<00072>>29520000
if <> then ferror(tapefnum,tapefile);                          <<00072>>29525000
end;                                                           <<00072>>29530000
$control segment=dumptape                                      <<01073>>29535000
                                                               <<00072>>29540000
                                                                        29545000
          <<-------------------                                         29550000
            dump file to tape                                           29555000
          ------------------->>                                         29560000
  procedure fdump(filename);                                            29565000
  byte array filename;                                                  29570000
    option privileged,uncallable;                                       29575000
      begin                                                             29580000
        double discadr,eof,words;                              <<03604>>29585000
        byte volume = discadr;                                 <<03604>>29590000
        integer i,j,ldev,extsize,nx,len,                       <<03604>>29595000
                filenum, k:=0,                                          29600000
                  discadr1=discadr,discadr2=discadr+1;         <<03604>>29605000
        logical sectors;                                       <<03604>>29610000
        logical change := false;                                        29615000
        double pointer dps0=s-0, dps1=s-1;                     <<00928>>29620000
        equate nexec=7;  <<# of executable files>>             <<04659>>29625000
        byte array                                             <<04659>>29630000
           execs  (*) = pb :=     <<executable system files>>  <<04659>>29635000
              "SYSDUMP ", "SEGPROC ", "SEGDVR  ",              <<04659>>29640000
              "LOAD    ", "PVINIT  ", "MAKECAT ", "STORE   ";  <<04659>>29645000
        subroutine ioerrcheck(b,a);                                     29650000
        value b,a;                                                      29655000
        integer b,a;                                                    29660000
         begin                                                          29665000
          tos := b.(8:8);                                               29670000
          if s0 <> 1 then                                               29675000
            begin   <<i/o error>>                                       29680000
              tos := -tos;                                              29685000
              ferror(*,fullname);                                       29690000
            end;                                                        29695000
          del;                                                          29700000
        end <<ioerrcheck>> ;                                            29705000
        subroutine setlab;                                              29710000
        begin                                                           29715000
          move blbuf := filename,(8);                                   29720000
          move lbuf(4) :=  "PUB     ";                                  29725000
          move lbuf(8) :=  "SYS     ";                                  29730000
          move lbuf(12) := "MANAGER ";                                  29735000
          do if filename=execs(k*8),(8) then                            29740000
            begin  <<executable>>                                       29745000
              tos := %4040; <<l,x:any>>                                 29750000
              goto setsec;                                              29755000
            end                                                         29760000
          until (k:=k+1) = nexec;                                       29765000
          tos := %4000; <<l:any/x:nobody>>                              29770000
  setsec: lbuf(21) := tos;  <<security>>                                29775000
          lbuf(20) := %20202;  <<r,a,w:any>>                            29780000
          lbuf(22) := 1;  <<secure>>                                    29785000
          lbuf(36) := 1;   <<foptions>>                                 29790000
          dlbuf(21) := eof;                                             29795000
          lbuf(flchecksumx) := flblchecksum( lbuf);            <<03604>>29800000
        end <<setlab>> ;                                                29805000
          change := search'sysfile( filename);                 <<02516>>29810000
          if fullname="SL.PUB.SYS " or                         <<04252>>29815000
             fullname="TEMPSL.PUB.SYS " then                   <<04252>>29820000
         filenum:=fopen(fullname,%(2)10000000011,%(2)11110000) <<04252>>29825000
          else                                                 <<04252>>29830000
         filenum:=fopen(fullname,%(2)10000000011,%(2)11010000);<<04252>>29835000
          if <> then                                                    29840000
            begin   <<open error>>                                      29845000
              fcheck(filenum,i);                                        29850000
              if not (50<=i<=53) then <<error other than not found>>    29855000
           if fullname <> "MPECHECK.PUB.SYS" then              <<00598>>29860000
  ferr:         ferror(filenum,fullname);                               29865000
              tos := @bpnotdump;  <<files not dumped ptr>>              29870000
              tos := s0+1;                                              29875000
              tos := @fullname;                                         29880000
  nextchar:   move * := * while an,0;                                   29885000
              if bps0 = "." then                                        29890000
                begin   <<part of name>>                                29895000
                  move * := *,(1),1;                                    29900000
                  goto nextchar;                                        29905000
                end;                                                    29910000
              del;                                                      29915000
              if change then                                            29920000
                begin   <<include old name also>>                       29925000
                  move * := " (",2;                                     29930000
                  move * := filename while an,1;  <<old name>>          29935000
                  bps0 := ")";                                          29940000
                  tos := tos+1;                                         29945000
                end;                                                    29950000
              assemble(sub,neg);   <<length of entry>>                  29955000
              bpnotdump := s0;                                          29960000
              @bpnotdump := tos+@bpnotdump;                             29965000
              return;                                                   29970000
            end;                                                        29975000
          if fullname="SL.PUB.SYS " or                         <<04252>>29980000
             fullname="TEMPSL.PUB.SYS " then                   <<04252>>29985000
          begin                                                <<04252>>29990000
            tos := filenum;                                    <<04252>>29995000
            if sirs then tos:=0 else tos := -1;                <<04252>>30000000
            flock(*,*);                                        <<04252>>30005000
            if < then go ferr;                                 <<04252>>30010000
            if > then ferror(1024,fullname);  <<busy>>         <<04252>>30015000
          end;                                                 <<04252>>30020000
          fgetinfo(filenum,,,,,,ldev,,,,eof,,,,,extsize,,,,    <<03604>>30025000
               discadr);                                       <<03604>>30030000
          if <> then goto ferr;                                         30035000
          volume := 0; << zero ldn >>                          <<03604>>30040000
          tos := attachio(ldev,0,0,@flab,0,128,discadr1,       <<03604>>30045000
                   discadr2,1);                                <<03604>>30050000
          ioerrcheck(*,*);                                              30055000
                                                               <<00928>>30060000
          << add file space to total system file space >>      <<00928>>30065000
          tos := @flextmap;                                    <<00928>>30070000
          x := flnumexts;                                      <<00928>>30075000
          tos := 0;                                            <<00928>>30080000
          do begin                                             <<00928>>30085000
             if dps1(x) <> 0d then tos := tos+1;               <<00928>>30090000
             x := x-1;                                         <<00928>>30095000
             end until <;                                      <<00928>>30100000
          nx := tos;                                           <<00928>>30105000
          tos := if dps0(flnumexts) = 0d then                  <<00928>>30110000
             logical(nx) ** logical(extsize)                   <<00928>>30115000
          else                                                 <<00928>>30120000
             << last extent maybe shorter >>                   <<00928>>30125000
             (logical(nx)-1)**logical(extsize)+double(fllastextsize);   30130000
          systemfilespace := systemfilespace+tos;              <<00928>>30135000
                                                               <<00928>>30140000
          if change and filename="ININ    " then                        30145000
            begin                                                       30150000
            massageinin(ldev,eof,discadr);                     <<03604>>30155000
            go exit;                                                    30160000
            end;                                                        30165000
            << convert volume #'s in extent map to ldev #'s >> <<03623>>30170000
          vtabtoldev(flextmap,flextmap,flnumexts+1,flmvtabx);  <<03623>>30175000
                                                               <<03623>>30180000
          i := 0;                                              <<03604>>30185000
          do begin                                             <<03604>>30190000
             sectors := if i = flnumexts then                  <<03604>>30195000
                fllastextsize else extsize;                    <<03604>>30200000
             discadr := flabdbl( flext0+i);                    <<03604>>30205000
             if <> then                                        <<03604>>30210000
                begin                                          <<03604>>30215000
                ldev := volume;                                <<03623>>30220000
                volume := 0;                                   <<03604>>30225000
                words := sectors ** 128;                       <<03604>>30230000
                j := 0;                                        <<03604>>30235000
                while words <> 0d do                           <<03604>>30240000
                   begin                                       <<03604>>30245000
                   len := if words > double(taperecsize)       <<03604>>30250000
                      then taperecsize else logical(words);    <<03604>>30255000
                   tos := attachio( ldev,0,0,@lbuf,0,len,      <<03604>>30260000
                      discadr1,discadr2,1);                    <<03604>>30265000
                   ioerrcheck(*,*);                            <<03604>>30270000
                   if i = 0 and j = 0 then setlab;             <<03604>>30275000
                   fwrite( tapefnum, lbuf, len, 0);            <<03604>>30280000
                   if <> then                                  <<03604>>30285000
                      begin                                    <<03604>>30290000
                      fcheck( tapefnum, errorcode);            <<03604>>30295000
                      if errorcode = eotcode and floppy then   <<03609>>30300000
                         begin                                 <<03604>>30305000
                         nextreel;                             <<03604>>30310000
                         end                                   <<03604>>30315000
                      else                                     <<03604>>30320000
                         ferror( tapefnum, tapefile);          <<03604>>30325000
                      end;                                     <<03604>>30330000
                   j := j+1;                                   <<03604>>30335000
                   discadr := discadr+double(len/128);         <<03604>>30340000
                   words := words-double(len);                 <<03604>>30345000
                   end;                                        <<03604>>30350000
                end;                                           <<03604>>30355000
             end until (i:=i+1) > flnumexts;                   <<03604>>30360000
                                                               <<03604>>30365000
exit:                                                          <<03604>>30370000
   fclose( filenum, 0, 0);                                     <<03604>>30375000
   if <> then ferror( filename, fullname);                     <<03604>>30380000
end; << fdump >>                                               <<03604>>30385000
$control segment=dumptape                                      <<01073>>30390000
                                                               <<00072>>30395000
                                                                        30400000
          <<-----------------------                                     30405000
            write segment to tape                                       30410000
          ----------------------->>                                     30415000
procedure segtotape( recno, words, contig);                    <<03604>>30420000
   value recno, words, contig;                                 <<03604>>30425000
   integer recno, words;                                       <<03604>>30430000
   logical contig;                                             <<03604>>30435000
   option privileged, uncallable;                              <<03604>>30440000
begin                                                          <<03604>>30445000
   integer                                                     <<03604>>30450000
      len,                                                     <<03604>>30455000
      j := 0;                                                  <<03604>>30460000
                                                               <<03604>>30465000
   fpoint( initfnum, double(recno));                           <<03604>>30470000
   if <> then ferror( initfnum, initfile);                     <<03604>>30475000
                                                               <<03604>>30480000
   while words <> 0 do                                         <<03604>>30485000
      begin                                                    <<03604>>30490000
      len := if words > taperecsize then taperecsize           <<03604>>30495000
         else words;                                           <<03604>>30500000
      fread( initfnum, lbuf, len);                             <<03604>>30505000
      if <> then ferror( initfnum, initfile);                  <<03604>>30510000
      fwrite( tapefnum, lbuf, len, if contig and j = 0 then    <<03604>>30515000
         %1001 else 0);                                        <<03604>>30520000
      if <> then ferror( tapefnum, tapefile);                  <<03604>>30525000
      j := j+1;                                                <<03604>>30530000
      words := words-len;                                      <<03604>>30535000
      end;                                                     <<03604>>30540000
                                                               <<03604>>30545000
   if contig and j <> 0 then                                   <<03604>>30550000
      begin << close contiguous block >>                       <<03604>>30555000
      fwrite( tapefnum, lbuf, 0, %2001);                       <<03604>>30560000
      if <> then ferror( tapefnum, tapefile);                  <<03604>>30565000
      end;                                                     <<03604>>30570000
end; << segtotape >>                                           <<03604>>30575000
$control segment=dumptape                                      <<01073>>30580000
integer procedure checksum(target,targetlen,oldchecksum);      <<00150>>30585000
value targetlen,oldchecksum;                                   <<00150>>30590000
array target;                                                  <<00150>>30595000
integer targetlen;                                             <<00150>>30600000
logical oldchecksum;                                           <<00150>>30605000
comment:                                                       <<00150>>30610000
   using the value of oldchecksum as a base, the checksum      <<00150>>30615000
   of the target array is calculated and returned as the       <<00150>>30620000
   value of the procedure.                                     <<00150>>30625000
end of comment;                                                <<00150>>30630000
                                                               <<00150>>30635000
begin                                                          <<00150>>30640000
integer i;                                                     <<00150>>30645000
i:=0;                                                          <<00150>>30650000
do                                                             <<00150>>30655000
   oldchecksum:=oldchecksum+target(i)                          <<00150>>30660000
until (i:=i+1)=targetlen;                                      <<00150>>30665000
checksum:=oldchecksum;                                         <<00150>>30670000
end;  <<checksum>>                                             <<00150>>30675000
$control segment=dumptape                                      <<01073>>30680000
procedure build'sio( tape'fmt'tab, cmd'tab);                   <<02509>>30685000
   integer array tape'fmt'tab, cmd'tab;                        <<02509>>30690000
begin                                                          <<02509>>30695000
   entry                                                       <<02509>>30700000
      build'sio'skip;                                          <<02509>>30705000
   equate                                                      <<02509>>30710000
      base1 = %1400,                                           <<02509>>30715000
      base2 = %2000;                                           <<02509>>30720000
   define                                                      <<02509>>30725000
      entry'size = tape'fmt'tab.(0:8)#,                        <<02509>>30730000
      entries = tape'fmt'tab.(8:8)#,                           <<02509>>30735000
      length = pntr#,                                          <<02509>>30740000
      coreadr1 = pntr(1)#,                                     <<02509>>30745000
      coreadr2 = pntr(2)#;                                     <<02509>>30750000
   define                                                      <<02509>>30755000
      fnum                = cmd'tab#,                          <<02509>>30760000
      next'rec            = cmd'tab(1)#,                       <<02509>>30765000
      rec'before'initial  = cmd'tab(2)#,                       <<02509>>30770000
      nrent'after'wcs     = cmd'tab(3)#,                       <<02509>>30775000
      nrent'before'wcs    = cmd'tab(4)#,                       <<02509>>30780000
      amigo'rec'1         = cmd'tab(5)#,                       <<02509>>30785000
      amigo'rec'2         = cmd'tab(6)#,                       <<02509>>30790000
      wcs'rec'before'init = cmd'tab(7)#,                       <<02509>>30795000
      sio'rec'before'init = cmd'tab(8)#,                       <<02509>>30800000
      amigo'rec'before'init = cmd'tab(9)#,                     <<02509>>30805000
      beg'of'stack        = 40#,                               <<02509>>30810000
      rec                 = ctpntr#,                           <<02509>>30815000
      len                 = ctpntr(1)#;                        <<02509>>30820000
   integer                                                     <<02509>>30825000
      i := 0,                                                  <<02509>>30830000
      oldbank := 0,                                            <<02509>>30835000
      nr'recs := 0,                                            <<02509>>30840000
      j,                                                       <<02509>>30845000
      size;                                                    <<02509>>30850000
   integer pointer                                             <<02509>>30855000
      pntr,                                                    <<02509>>30860000
      ctpntr;                                                  <<02509>>30865000
   subroutine save'it(b'wcs,len');                             <<02509>>30870000
      value b'wcs,len';                                        <<02509>>30875000
      logical b'wcs;                                           <<02509>>30880000
      integer len';                                            <<02509>>30885000
   begin                                                       <<02509>>30890000
      fwritedir( fnum,lbuf,len',double(next'rec));             <<02509>>30895000
      if <> then quit(3);                                      <<02509>>30900000
      rec := next'rec;                                         <<02509>>30905000
      len := len';                                             <<02509>>30910000
      if b'wcs then                                            <<02509>>30915000
         nrent'before'wcs := nrent'before'wcs+1                <<02509>>30920000
      else                                                     <<02509>>30925000
         nrent'after'wcs := nrent'after'wcs+1;                 <<02509>>30930000
      @ctpntr := @ctpntr(2);                                   <<02509>>30935000
      next'rec := next'rec+(len'+127)/128;                     <<02509>>30940000
   end;                                                        <<02509>>30945000
   subroutine skip;                                            <<02509>>30950000
   begin                                                       <<02509>>30955000
      lbuf(i) := %40000;                                       <<02509>>30960000
      lbuf(i:=i+1) := 7;                                       <<02509>>30965000
      i := i+1;                                                <<02509>>30970000
   end;                                                        <<02509>>30975000
                                                               <<02509>>30980000
   subroutine read(bank,address,length,jmp'target);            <<02509>>30985000
      value bank,address,length,jmp'target;                    <<02509>>30990000
      integer bank,address,length,jmp'target;                  <<02509>>30995000
   begin                                                       <<02509>>31000000
      if bank <> oldbank then                                  <<02509>>31005000
         begin                                                 <<02509>>31010000
         lbuf(i) := %14000;   << sio set bank >>               <<02509>>31015000
         lbuf(i:=i+1) := oldbank := bank; << new bank >>       <<02509>>31020000
         i:=i+1;                                               <<02509>>31025000
         end;                                                  <<02509>>31030000
      while length > 0 do                                      <<02509>>31035000
         begin                                                 <<02509>>31040000
         lbuf(i) := %40000;    << sio control >>               <<02509>>31045000
         lbuf(x:=x+1) := 6;    << read        >>               <<02509>>31050000
         size := if length > taperecsize then taperecsize      <<03604>>31055000
            else length;                                       <<03604>>31060000
         tos := -size;                                         <<02509>>31065000
         assemble( trbc 0 ); << convert to sio read instruction<<02509>>31070000
         lbuf(x:=x+1) := tos;                                  <<02509>>31075000
         lbuf(x:=x+1) := address;                              <<02509>>31080000
         i := x+1;                                             <<02509>>31085000
         length := length-size;                                <<02509>>31090000
         address := address+size;                              <<02509>>31095000
         nr'recs := nr'recs+1;                                 <<02509>>31100000
         end;                                                  <<02509>>31105000
      if jmp'target <> 0 then                                  <<02509>>31110000
         begin                                                 <<02509>>31115000
         lbuf(i) := 0;                << sio jump >>           <<02509>>31120000
         lbuf(i:=i+1) := jmp'target;  << jump target >>        <<02509>>31125000
         i:=i+1;                                               <<02509>>31130000
         end;                                                  <<02509>>31135000
   end;                                                        <<02509>>31140000
   @ctpntr := @cmd'tab(beg'of'stack+nrent'after'wcs*2);        <<02509>>31145000
   tos := rec'before'initial;                                  <<02509>>31150000
   while <> do                                                 <<02509>>31155000
      begin                                                    <<02509>>31160000
      skip;                                                    <<02509>>31165000
      tos:=tos-1;         << skip counter >>                   <<02509>>31170000
      end;                                                     <<02509>>31175000
   @pntr := @tape'fmt'tab(entry'size);                         <<02509>>31180000
   while @pntr <= @tape'fmt'tab(entries*entry'size) do         <<02509>>31185000
      begin                                                    <<02509>>31190000
      read(coreadr1,coreadr2,length,0);                        <<02509>>31195000
      @pntr := @pntr(entry'size);                              <<02509>>31200000
      end;                                                     <<02509>>31205000
   lbuf(i) := %34000;     << sio end,i >>                      <<02509>>31210000
   lbuf(i:=i+1) := 0;                                          <<02509>>31215000
   j := i+1;                                                   <<02509>>31220000
   save'it(false,j);                                           <<02509>>31225000
   zerobuf(lbuf,32);     << zero lbuf >>                       <<02509>>31230000
   nr'recs := 1;                                               <<02509>>31235000
   i := 0;                                                     <<02509>>31240000
   read(0,base2,j,base2);                                      <<02509>>31245000
   save'it(false,32);                                          <<02509>>31250000
   rec'before'initial := sio'rec'before'initial :=             <<02509>>31255000
      rec'before'initial+nr'recs;                              <<02509>>31260000
   return;                                                     <<02509>>31265000
                                                               <<02509>>31270000
build'sio'skip:                                                <<02509>>31275000
   @ctpntr := @cmd'tab(beg'of'stack                            <<02509>>31280000
      +(nrent'before'wcs+nrent'after'wcs)*2);                  <<02509>>31285000
   tos := rec'before'initial-sio'rec'before'initial;           <<02509>>31290000
   while <> do                                                 <<02509>>31295000
      begin                                                    <<02509>>31300000
      skip;                                                    <<02509>>31305000
      tos := tos-1;                                            <<02509>>31310000
      end;                                                     <<02509>>31315000
   read(0,base1,32,base1);                                     <<02509>>31320000
   save'it(true,i);                                            <<02509>>31325000
   j := i;                                                     <<02509>>31330000
   i := 0;                                                     <<02509>>31335000
   zerobuf(lbuf,32);     << zero lbuf >>                       <<02509>>31340000
   read(0,base2,j,base2);                                      <<02509>>31345000
   save'it(true,32);                                           <<02509>>31350000
   rec'before'initial := rec'before'initial+nr'recs;           <<02509>>31355000
end;                                                           <<02509>>31360000
procedure build'amigo( tape'fmt'tab, cmd'tab);                 <<02509>>31365000
   integer array tape'fmt'tab, cmd'tab;                        <<02509>>31370000
begin                                                          <<02509>>31375000
   entry                                                       <<02509>>31380000
      build'amigo'skip;                                        <<02509>>31385000
   define                                                      <<02509>>31390000
      entry'size = tape'fmt'tab.(0:8)#,                        <<02509>>31395000
      entries    = tape'fmt'tab.(8:8)#,                        <<02509>>31400000
      length     = pntr#,                                      <<02509>>31405000
      coreadr1   = pntr(1)#,                                   <<02509>>31410000
      coreadr2   = pntr(2)#;                                   <<02509>>31415000
   define                                                      <<02509>>31420000
      fnum                = cmd'tab#,                          <<02509>>31425000
      next'rec            = cmd'tab(1)#,                       <<02509>>31430000
      rec'before'initial  = cmd'tab(2)#,                       <<02509>>31435000
      nrent'after'wcs     = cmd'tab(3)#,                       <<02509>>31440000
      nrent'before'wcs    = cmd'tab(4)#,                       <<02509>>31445000
      amigo'rec'1         = cmd'tab(5)#,                       <<02509>>31450000
      amigo'rec'2         = cmd'tab(6)#,                       <<02509>>31455000
      wcs'rec'before'init = cmd'tab(7)#,                       <<02509>>31460000
      sio'rec'before'init = cmd'tab(8)#,                       <<02509>>31465000
      amigo'rec'before'init = cmd'tab(9)#,                     <<02509>>31470000
      beg'of'stack        = 40#,                               <<02509>>31475000
      rec                 = ctpntr#,                           <<02509>>31480000
      len                 = ctpntr(1)#;                        <<02509>>31485000
   define                                                      <<02509>>31490000
      nr'skips'to'wcs     = lbuf(95)#,                         <<02509>>31495000
      nr'skips'to'cs80    = lbuf(96)#;                         <<02509>>31500000
   integer                                                     <<02509>>31505000
      nr'recs := 0,                                            <<02509>>31510000
      cpsize,                                                  <<02509>>31515000
      base,                                                    <<02509>>31520000
      size;                                                    <<02509>>31525000
   integer pointer                                             <<02509>>31530000
      pntr,                                                    <<02509>>31535000
      ctpntr,                                                  <<02509>>31540000
      cppntr;                                                  <<02509>>31545000
   equate                                                      <<02509>>31550000
      base1         = %7100, << microcode starting address >>  <<02509>>31555000
      base2         = %1000,                                   <<02509>>31560000
      base3         = %2000;                                   <<02509>>31565000
   equate                                                      <<02509>>31570000
      cprd'len          = %44,                                 <<02509>>31575000
      cprd'cmd'x        =   4,                                 <<02509>>31580000
      cprd'dsj'err1'x   = %12,                                 <<02509>>31585000
      cprd'cnt'x        = %14,                                 <<02509>>31590000
      cprd'bank'x       = %16,                                 <<02509>>31595000
      cprd'adr'x        = %17,                                 <<02509>>31600000
      cprd'end'x        = %30,                                 <<02509>>31605000
      cprd'xfer'x       = %35,                                 <<02509>>31610000
      cprd'dsj'target'x =  -2,                                 <<02509>>31615000
      cprd'dsj'err2'x   = %43,                                 <<02509>>31620000
      cpsk'len          = %17,                                 <<02509>>31625000
      cpsk'cnt'x        =   1,                                 <<02509>>31630000
      cpsk'cmd'x        =  %4,                                 <<02509>>31635000
      cpsk'dsj'err'x    = %14,                                 <<02509>>31640000
      cpend'len         =   3,                                 <<02509>>31645000
      cpbase'stat'x     = %11,                                 <<02509>>31650000
      cpbase'std'len    = %14,                                 <<02509>>31655000
      cpbase'fst'len    = %20,                                 <<02509>>31660000
      cpbase'entry      =   1,                                 <<02509>>31665000
      cpbase'xfer'buf   =   0,                                 <<02509>>31670000
      cpbase'stat'buf   =   1,                                 <<02509>>31675000
      cpbase'skipcmd'x  =   4,                                 <<02509>>31680000
      cpbase'readcmd'x  =   3,                                 <<02509>>31685000
      cpbase'endcmd'x   =   3,                                 <<02509>>31690000
      cpstat'entry      =   5;                                 <<02509>>31695000
   <<     note:   a "*" besides a number indicates     >>      <<02509>>31700000
   <<     a location within the channel program        >>      <<02509>>31705000
   <<     that needs to be updated.                    >>      <<02509>>31710000
   array chan'pgm'base(*) = pb :=                              <<02509>>31715000
     <<  0 >>         0, << checksum / transfer buffer >>      <<02509>>31720000
                                                               <<02509>>31725000
     <<  1 >>         0, << jmp cmd  / status buffer   >>      <<02509>>31730000
     <<  2 >>         9, << target   / status buffer   >>      <<02509>>31735000
                                                               <<02509>>31740000
     <<  3 >>[8/8,8/19], << read cmd / end cmd         >>      <<02509>>31745000
     <<  4 >> [8/9,8/9], << skip cmd / skip cmd        >>      <<02509>>31750000
                                                               <<02509>>31755000
     <<  5 >>     %1401, << read status                >>      <<02509>>31760000
     <<  6 >>         3, << three bytes of status      >>      <<02509>>31765000
     <<  7 >>         0, << the status buffer above    >>      <<02509>>31770000
     << 10 >>     %2000, << will contain the error     >>      <<02509>>31775000
     << 11*>>         0, << status returned by the mt  >>      <<02509>>31780000
                                                               <<02509>>31785000
     << 12 >>      %600, << int/halt - bad news halt   >>      <<02509>>31790000
     << 13 >>         2, << error - cause system halt! >>      <<02509>>31795000
                                                               <<02509>>31800000
     << 14 >>     %2401, << dsj                        >>      <<02509>>31805000
     << 15 >>         0, << finish up microcode cl.    >>      <<02509>>31810000
     << 16 >>         0, << a-ok jump                  >>      <<02509>>31815000
     << 17 >>       -11; << error jump                 >>      <<02509>>31820000
   array chan'pgm'read(*) = pb :=                              <<02509>>31825000
     <<  0 >>     %2001, << send read command          >>      <<02509>>31830000
     <<  1 >>         1, << one byte                   >>      <<02509>>31835000
     <<  2 >>         0,                                       <<02509>>31840000
     <<  2 >>     %2000, << start left byte            >>      <<02509>>31845000
     <<  4*>>         0, << read  command address      >>      <<02509>>31850000
                                                               <<02509>>31855000
     <<  5 >>     %1000, << wait                       >>      <<02509>>31860000
     <<  6 >>         0,                                       <<02509>>31865000
                                                               <<02509>>31870000
     <<  7 >>     %2401, << dsj                        >>      <<02509>>31875000
     << 10 >>         0,                                       <<02509>>31880000
     << 11 >>         0, << a-ok jump                  >>      <<02509>>31885000
     << 12*>>         0, << error jump                 >>      <<02509>>31890000
                                                               <<02509>>31895000
     << 13 >>     %1400, << read a record              >>      <<02509>>31900000
     << 14*>>         0, << byte count                 >>      <<02509>>31905000
     << 15 >>     %2100,                                       <<02509>>31910000
     << 16*>>   %100000, << bank                       >>      <<02509>>31915000
     << 17*>>         0, << addresss                   >>      <<02509>>31920000
                                                               <<02509>>31925000
     << 20 >>         0, << jump                       >>      <<02509>>31930000
     << 21 >>         2, << complete target            >>      <<02509>>31935000
                                                               <<02509>>31940000
     << 22 >>         0, << jump                       >>      <<02509>>31945000
     << 23 >>       -15, << next burst                 >>      <<02509>>31950000
                                                               <<02509>>31955000
     << 24 >>     %2007, << send end command           >>      <<02509>>31960000
     << 25 >>         1, << one byte                   >>      <<02509>>31965000
     << 26 >>         0,                                       <<02509>>31970000
     << 27 >>    %42000, << start right byte           >>      <<02509>>31975000
     << 30*>>         0, << end command address        >>      <<02509>>31980000
                                                               <<02509>>31985000
     << 31 >>     %1402, << read transfer count        >>      <<02509>>31990000
     << 32 >>         2, << two bytes                  >>      <<02509>>31995000
     << 33 >>         0,                                       <<02509>>32000000
     << 34 >>     %2000,                                       <<02509>>32005000
     << 35*>>         0, << address of xfer buffer     >>      <<02509>>32010000
                                                               <<02509>>32015000
     << 36 >>     %1000, << wait                       >>      <<02509>>32020000
     << 37 >>         0,                                       <<02509>>32025000
                                                               <<02509>>32030000
     << 40 >>     %2401, << dsj                        >>      <<02509>>32035000
     << 41 >>         0,                                       <<02509>>32040000
     << 42*>>         0, << a-ok jump                  >>      <<02509>>32045000
     << 43*>>         0; << error jump                 >>      <<02509>>32050000
   array chan'pgm'skip(*) = pb :=                              <<02509>>32055000
     <<  0 >>     %2001, << forward space record cmd   >>      <<02509>>32060000
     <<  1*>>         0, << nr. skips to be performed  >>      <<02509>>32065000
     <<  2 >>         1, << one byte burst             >>      <<02509>>32070000
     <<  3 >>   %104000, << single address option      >>      <<02509>>32075000
     <<  4*>>         0, << address of skip command    >>      <<02509>>32080000
                                                               <<02509>>32085000
     <<  5 >>     %7407, << write relative memory      >>      <<02509>>32090000
     <<  6 >>         0, << zero jump next burst       >>      <<02509>>32095000
                                                               <<02509>>32100000
     <<  7 >>     %1000, << wait                       >>      <<02509>>32105000
     << 10 >>         0,                                       <<02509>>32110000
                                                               <<02509>>32115000
     << 11 >>     %2401, << dsj                        >>      <<02509>>32120000
     << 12 >>         0,                                       <<02509>>32125000
     << 13 >>         0, << a-ok jump                  >>      <<02509>>32130000
     << 14*>>         0, << error jump                 >>      <<02509>>32135000
                                                               <<02509>>32140000
     << 15 >>         0, << jump                       >>      <<02509>>32145000
     << 16 >>       -15; << to write next burst        >>      <<02509>>32150000
   array chan'pgm'end(*) = pb :=                               <<02509>>32155000
     <<  0 >>      %600, << int/halt                   >>      <<02509>>32160000
     <<  1 >>         0, << good code                  >>      <<02509>>32165000
                                                               <<02509>>32170000
     <<  2 >>        -1; << terminator                 >>      <<02509>>32175000
   subroutine save'it(b'wcs,len');                             <<02509>>32180000
      value b'wcs,len';                                        <<02509>>32185000
      logical b'wcs;                                           <<02509>>32190000
      integer len';                                            <<02509>>32195000
   begin                                                       <<02509>>32200000
      fwritedir( fnum,lbuf,len',double(next'rec));             <<02509>>32205000
      if <> then quit(3);                                      <<02509>>32210000
      rec := next'rec;                                         <<02509>>32215000
      len := len';                                             <<02509>>32220000
      if b'wcs then                                            <<02509>>32225000
         nrent'before'wcs := nrent'before'wcs+1                <<02509>>32230000
      else                                                     <<02509>>32235000
         nrent'after'wcs := nrent'after'wcs+1;                 <<02509>>32240000
      @ctpntr := @ctpntr(2);                                   <<02509>>32245000
      next'rec := next'rec+(len'+127)/128;                     <<02509>>32250000
   end;                                                        <<02509>>32255000
   subroutine skip( cnt);                                      <<02509>>32260000
      value cnt;                                               <<02509>>32265000
      integer cnt;                                             <<02509>>32270000
   begin                                                       <<02509>>32275000
      move cppntr := chan'pgm'skip,(cpsk'len);                 <<02509>>32280000
      cppntr(cpsk'cnt'x) := cnt;                               <<02509>>32285000
      cppntr(cpsk'cmd'x) := base+cpbase'skipcmd'x;             <<02509>>32290000
      cppntr(cpsk'dsj'err'x) := @lbuf(cpstat'entry)            <<02509>>32295000
         -@cppntr(cpsk'dsj'err'x+1);                           <<02509>>32300000
      @cppntr := @cppntr+cpsk'len;                             <<02509>>32305000
   end;                                                        <<02509>>32310000
                                                               <<02509>>32315000
   subroutine read( bank, address, length, jmp'target);        <<02509>>32320000
      value bank, address, length, jmp'target;                 <<02509>>32325000
      integer bank, address, length, jmp'target;               <<02509>>32330000
   begin                                                       <<02509>>32335000
      while length > 0 do                                      <<02509>>32340000
         begin                                                 <<02509>>32345000
         move cppntr := chan'pgm'read,(cprd'len);              <<02509>>32350000
         size := if length > taperecsize then taperecsize      <<03604>>32355000
            else length;                                       <<03604>>32360000
         cppntr(cprd'cmd'x) := base+cpbase'readcmd'x;          <<02509>>32365000
         cppntr(cprd'dsj'err1'x) := @lbuf(cpstat'entry)        <<02509>>32370000
            -@cppntr(cprd'dsj'err1'x+1);                       <<02509>>32375000
         cppntr(cprd'cnt'x) := size&lsl(1);                    <<02509>>32380000
         cppntr(cprd'bank'x).(8:8) := bank;                    <<02509>>32385000
         cppntr(cprd'adr'x) := address;                        <<02509>>32390000
         cppntr(cprd'end'x) := base+cpbase'endcmd'x;           <<02509>>32395000
         cppntr(cprd'xfer'x) := base+cpbase'xfer'buf;          <<02509>>32400000
         cppntr(cprd'dsj'err2'x) := @lbuf(cpstat'entry)        <<02509>>32405000
            -@cppntr(cprd'dsj'err2'x+1);                       <<02509>>32410000
         @cppntr := @cppntr+cprd'len;                          <<02509>>32415000
         length := length-size;                                <<02509>>32420000
         address := address+size;                              <<02509>>32425000
         nr'recs := nr'recs+1;                                 <<02509>>32430000
         end;                                                  <<02509>>32435000
      if jmp'target <> 0 then                                  <<02509>>32440000
         cppntr(cprd'dsj'target'x) := jmp'target               <<02509>>32445000
         -(@cppntr(cprd'dsj'target'x+2)-@lbuf+base);           <<02509>>32450000
   end;                                                        <<02509>>32455000
   @ctpntr := @cmd'tab(beg'of'stack+nrent'after'wcs*2);        <<02509>>32460000
   base := base3;                                              <<02509>>32465000
   move lbuf := chan'pgm'base,(cpbase'std'len),2;              <<02509>>32470000
   @cppntr := tos;                                             <<02509>>32475000
   lbuf(cpbase'stat'x) := base+cpbase'stat'buf;                <<02509>>32480000
                                                               <<02509>>32485000
   tos := rec'before'initial;                                  <<02509>>32490000
   if <> then skip(*);                                         <<02509>>32495000
   @pntr := @tape'fmt'tab(entry'size);                         <<02509>>32500000
   while @pntr <= @tape'fmt'tab(entries*entry'size) do         <<02509>>32505000
      begin                                                    <<02509>>32510000
      read( coreadr1,coreadr2,length,0);                       <<02509>>32515000
      @pntr := @pntr(entry'size);                              <<02509>>32520000
      end;                                                     <<02509>>32525000
   move cppntr := chan'pgm'end,(cpend'len),2;                  <<02509>>32530000
   @cppntr := tos;                                             <<02509>>32535000
   cpsize := @cppntr-@lbuf;                                    <<02509>>32540000
   save'it(false,cpsize);                                      <<02509>>32545000
                                                               <<02509>>32550000
                                                               <<02509>>32555000
   nr'recs := 1;                                               <<02509>>32560000
   base := base2;                                              <<02509>>32565000
   move lbuf := chan'pgm'base,(cpbase'std'len),2;              <<02509>>32570000
   @cppntr := tos;                                             <<02509>>32575000
   lbuf(cpbase'stat'x) := base+cpbase'stat'buf;                <<02509>>32580000
   read(0,base3,cpsize,base3+cpbase'entry);                    <<02509>>32585000
   cpsize := @cppntr-@lbuf;                                    <<02509>>32590000
   save'it(false,cpsize);                                      <<02509>>32595000
                                                               <<02509>>32600000
                                                               <<02509>>32605000
   base := base1;                                              <<02509>>32610000
   zerobuf(lbuf,128);      << zero lbuf >>                     <<02509>>32615000
   move lbuf := chan'pgm'base,(cpbase'fst'len),2;              <<02509>>32620000
   @cppntr := tos;                                             <<02509>>32625000
   lbuf(cpbase'stat'x) := base+cpbase'stat'buf;                <<02509>>32630000
   read(0,base2,cpsize,base2+cpbase'entry);                    <<02509>>32635000
   lbuf := checksum(lbuf,128,seed);                            <<02509>>32640000
   amigo'rec'2 := next'rec;                                    <<02509>>32645000
   save'it(false,128);                                         <<02509>>32650000
   rec'before'initial := amigo'rec'before'initial :=           <<02509>>32655000
      rec'before'initial+nr'recs;                              <<02509>>32660000
   return;                                                     <<02509>>32665000
                                                               <<02509>>32670000
                                                               <<02509>>32675000
build'amigo'skip:                                              <<02509>>32680000
   @ctpntr := @cmd'tab(beg'of'stack                            <<02509>>32685000
      +(nrent'before'wcs+nrent'after'wcs)*2);                  <<02509>>32690000
   base := base2;                                              <<02509>>32695000
   move lbuf := chan'pgm'base,(cpbase'std'len),2;              <<02509>>32700000
   @cppntr := tos;                                             <<02509>>32705000
   lbuf(cpbase'stat'x) := base+cpbase'stat'buf;                <<02509>>32710000
                                                               <<02509>>32715000
   tos := rec'before'initial-amigo'rec'before'initial;         <<02509>>32720000
   if <> then skip(*);                                         <<02509>>32725000
   read(0,base1,128,base1+cpbase'entry);                       <<02509>>32730000
   cpsize := @cppntr-@lbuf;                                    <<02509>>32735000
   save'it(true,cpsize);                                       <<02509>>32740000
                                                               <<02509>>32745000
                                                               <<02509>>32750000
   base := base1;                                              <<02509>>32755000
   zerobuf(lbuf,128);      << zero lbuf >>                     <<02509>>32760000
   move lbuf := chan'pgm'base,(cpbase'fst'len),2;              <<02509>>32765000
   @cppntr := tos;                                             <<02509>>32770000
   lbuf(cpbase'stat'x) := base+cpbase'stat'buf;                <<02509>>32775000
   read(0,base2,cpsize,base2+cpbase'entry);                    <<02509>>32780000
   amigo'rec'1 := next'rec;                                    <<02509>>32785000
   rec'before'initial := rec'before'initial+nr'recs;           <<02509>>32790000
   nr'skips'to'wcs := rec'before'initial-wcs'rec'before'init-1;<<02509>>32795000
   lbuf := checksum(lbuf,128,seed);                            <<02509>>32800000
   save'it(true,128);                                          <<02509>>32805000
                                                               <<02509>>32810000
end;                                                           <<02509>>32815000
procedure build'amigo'sdisc( tape'fmt'tab);                    <<02509>>32820000
   integer array tape'fmt'tab;                                 <<02509>>32825000
begin                                                          <<02509>>32830000
   equate                                                      <<02509>>32835000
      base1         =  %7100,                                  <<02509>>32840000
      base2         =  %2000;                                  <<02509>>32845000
   define                                                      <<02509>>32850000
      entry'size    =  tape'fmt'tab.(0:8)#,                    <<02509>>32855000
      entries       =  tape'fmt'tab.(8:8)#,                    <<02509>>32860000
      length        =  pntr#,                                  <<02509>>32865000
      coreadr1      =  pntr(1)#,                               <<02509>>32870000
      coreadr2      =  pntr(2)#,                               <<02509>>32875000
      discadr1      =  pntr(3)#,                               <<02509>>32880000
      discadr2      =  pntr(4)#;                               <<02509>>32885000
   integer                                                     <<02509>>32890000
      cpsize,                                                  <<02509>>32895000
      base,                                                    <<02509>>32900000
      size,                                                    <<02509>>32905000
      sect'cyl,                                                <<03604>>32910000
      nrsects,                                                 <<02509>>32915000
      maxread,                                                 <<02509>>32920000
      rem;                                                     <<02509>>32925000
   double array discaddress(0:0)=q;                            <<02509>>32930000
   integer pointer                                             <<02509>>32935000
      pntr,                                                    <<02509>>32940000
      cppntr,                                                  <<02509>>32945000
      adrpntr;                                                 <<02509>>32950000
   equate                                                      <<02509>>32955000
      cpbase'len             = %22,                            <<02509>>32960000
      cpbase'statbuf         =   1,                            <<02509>>32965000
      cpbase'jmp'x           =   2,                            <<02509>>32970000
      cpbase'filemask'x      =   3,                            <<02509>>32975000
      cpbase'readcmd'x       =   4,                            <<02509>>32980000
      cpbase'statcmd'x       =   5,                            <<02509>>32985000
      cpstat'entry           =   6,                            <<02509>>32990000
      cpstat'cmd'x           = %12,                            <<02509>>32995000
      cpstat'adr'x           = %17,                            <<02509>>33000000
      cprd'len               = %40,                            <<03604>>33005000
      cprd'skcmd'x           =   4,                            <<03604>>33010000
      cprd'jmp'flop          = %10,                            <<03604>>33015000
      cprd'filemask'x        = %15,                            <<03604>>33020000
      cprd'cmd'x             = %24,                            <<03604>>33025000
      cprd'cnt'x             = %26,                            <<03604>>33030000
      cprd'bank'x            = %30,                            <<03604>>33035000
      cprd'adr'x             = %31,                            <<03604>>33040000
      cprd'dsj'err'x         = %37,                            <<03604>>33045000
      cpend'len              =   3;                            <<02509>>33050000
   <<     note:   a "*" besides a number indicates     >>      <<02509>>33055000
   <<     a location within the channel program        >>      <<02509>>33060000
   <<     that needs to be updated.                    >>      <<02509>>33065000
   array chan'pgm'base(*) = pb :=                              <<02509>>33070000
     <<  0 >>         0, << checksum                         >><<02509>>33075000
                                                               <<02509>>33080000
     <<  1 >>         0, << jump cmd  / status buffer        >><<02509>>33085000
     <<  2*>>        15, << target    / status buffer        >><<02509>>33090000
                                                               <<02509>>33095000
     <<  3*>>         0, << filemask                         >><<02509>>33100000
     <<  4 >>     %2400, << read data command                >><<02509>>33105000
     <<  5 >>     %1400, << request status command           >><<02509>>33110000
                                                               <<02509>>33115000
     <<  6 >>     %2010, << send read status cmd             >><<02509>>33120000
     <<  7 >>         2, << two bytes                        >><<02509>>33125000
     << 10 >>         0,                                       <<02509>>33130000
     << 11 >>     %2000, << start left byte                  >><<02509>>33135000
     << 12*>>         0, << status command address           >><<02509>>33140000
                                                               <<02509>>33145000
     << 13 >>     %1410, << read status                      >><<02509>>33150000
     << 14 >>         4, << four bytes of status             >><<02509>>33155000
     << 15 >>         0,                                       <<02509>>33160000
     << 16 >>     %2000, << will contain the error           >><<02509>>33165000
     << 17*>>         0, << status returned by the disc      >><<02509>>33170000
                                                               <<02509>>33175000
     << 20 >>      %600, << int/halt - bad news halt         >><<02509>>33180000
     << 21 >>         2; << error - cause system halt!       >><<02509>>33185000
   array chan'pgm'read(*) = pb :=                              <<02509>>33190000
     <<  0 >>     %2010, << seek command                     >><<02509>>33195000
     <<  1 >>         6, << six bytes                        >><<02509>>33200000
     <<  2 >>         0,                                       <<02509>>33205000
     <<  3 >>     %2000, << start left byte                  >><<02509>>33210000
     <<  4*>>         0, << address of seek command          >><<02509>>33215000
                                                               <<02509>>33220000
     <<  5 >>     %1000, << wait                             >><<02509>>33225000
     <<  6 >>         0,                                       <<02509>>33230000
                                                               <<03604>>33235000
     <<  7 >>         0, << jump over set filemask if floppy >><<03604>>33240000
     << 10*>>         0, << 0 - 7905/06/20/25, 7 - floppy    >><<03604>>33245000
                                                               <<03604>>33250000
     << 11 >>     %2010, << write file mask                  >><<03604>>33255000
     << 12 >>         2, << two bytes                        >><<03604>>33260000
     << 13 >>         0,                                       <<03604>>33265000
     << 14 >>     %2000, << start left byte                  >><<03604>>33270000
     << 15*>>         0, << address of filemask              >><<03604>>33275000
                                                               <<03604>>33280000
     << 16 >>     %1000, << wait                             >><<03604>>33285000
     << 17 >>         0,                                       <<03604>>33290000
                                                               <<03604>>33295000
     << 20 >>     %2010, << send read command                >><<03604>>33300000
     << 21 >>         2, << two bytes                        >><<03604>>33305000
     << 22 >>         0,                                       <<03604>>33310000
     << 23 >>     %2000, << start left byte                  >><<03604>>33315000
     << 24*>>         0, << address of read command          >><<03604>>33320000
                                                               <<03604>>33325000
     << 25 >>     %1400, << read data                        >><<03604>>33330000
     << 26*>>         0, << byte count                       >><<03604>>33335000
     << 27 >>         0,                                       <<03604>>33340000
     << 30*>>         0, << bank                             >><<03604>>33345000
     << 31*>>         0, << address                          >><<03604>>33350000
                                                               <<03604>>33355000
     << 32 >>     %1000, << wait                             >><<03604>>33360000
     << 33 >>         0,                                       <<03604>>33365000
                                                               <<03604>>33370000
     << 34 >>     %2401, << dsj                              >><<03604>>33375000
     << 35 >>         0,                                       <<03604>>33380000
     << 36 >>         0, << a-ok jump                        >><<03604>>33385000
     << 37*>>         0; << error jump                       >><<03604>>33390000
   array chan'pgm'end(*) = pb :=                               <<02509>>33395000
     <<  0 >>      %600, << int/halt                         >><<02509>>33400000
     <<  1 >>         0, << good code                        >><<02509>>33405000
                                                               <<02509>>33410000
     <<  2 >>        -1; << terminator                       >><<02509>>33415000
   subroutine read(bank,address,discadr,size);                 <<02509>>33420000
      value bank,address,discadr,size;                         <<02509>>33425000
      integer bank,address,size;                               <<02509>>33430000
      double discadr;                                          <<02509>>33435000
   begin                                                       <<02509>>33440000
      while size > 0 do                                        <<02509>>33445000
         begin                                                 <<02509>>33450000
         nrsects := (size+127)/128;                            <<02509>>33455000
         tos := discadr;                                       <<02509>>33460000
         tos := sect'cyl;                                      <<03604>>33465000
         assemble( ldiv, delb );                               <<02509>>33470000
         rem := tos;                                           <<02509>>33475000
         maxread := if nrsects > sect'cyl-rem then             <<03604>>33480000
            (sect'cyl-rem)*128 else size;                      <<03604>>33485000
         move cppntr := chan'pgm'read,(cprd'len);              <<02509>>33490000
         cppntr(cprd'skcmd'x) := base+@adrpntr-@lbuf;          <<02509>>33495000
         if floppy then                                        <<03604>>33500000
            cppntr(cprd'jmp'flop) := 7                         <<03604>>33505000
         else                                                  <<03604>>33510000
            cppntr(cprd'filemask'x) := base+cpbase'filemask'x; <<03604>>33515000
         cppntr(cprd'cmd'x) := base+cpbase'readcmd'x;          <<02509>>33520000
         cppntr(cprd'cnt'x) := maxread&lsl(1);                 <<02509>>33525000
         cppntr(cprd'bank'x).(8:8) := bank;                    <<02509>>33530000
         cppntr(cprd'adr'x) := address;                        <<02509>>33535000
         cppntr(cprd'dsj'err'x) := @lbuf(cpstat'entry)-        <<02509>>33540000
            @cppntr(cprd'dsj'err'x+1);                         <<02509>>33545000
         @cppntr := @cppntr+cprd'len;                          <<02509>>33550000
         adrpntr := %1000;                                     <<02509>>33555000
         tos := l'padr(discadr);                               <<02509>>33560000
         adrpntr(2) := tos;                                    <<02509>>33565000
         adrpntr(1) := tos;                                    <<02509>>33570000
         @adrpntr := @adrpntr+3;                               <<02509>>33575000
         discadr := discadr+d'l((maxread+127)/128));           <<02509>>33580000
         address := address+maxread;                           <<02509>>33585000
         size := size-maxread;                                 <<02509>>33590000
         end;                                                  <<02509>>33595000
   end;                                                        <<02509>>33600000
   base := base2;                                              <<02509>>33605000
   move lbuf := chan'pgm'base,(cpbase'len),2;                  <<02509>>33610000
   @adrpntr := tos;                                            <<02509>>33615000
   @cppntr := @lbuf(512);                                      <<02509>>33620000
   sect'cyl := if floppy then flop'sec'cyl                     <<03604>>33625000
      else sec'cyl(stype);                                     <<03604>>33630000
   if not floppy then                                          <<03604>>33635000
      lbuf(cpbase'filemask'x) := filemask(stype);              <<03604>>33640000
   lbuf(cpstat'cmd'x) := base+cpbase'statcmd'x;                <<02509>>33645000
   lbuf(cpstat'adr'x) := base+cpbase'statbuf;                  <<02509>>33650000
                                                               <<02509>>33655000
   @pntr := @tape'fmt'tab(entry'size);                         <<02509>>33660000
   while @pntr <= @tape'fmt'tab(entries*entry'size) do         <<02509>>33665000
      begin                                                    <<02509>>33670000
      move discaddress := discadr1,(2);                        <<02509>>33675000
      read(coreadr1,coreadr2,discaddress,length);              <<02509>>33680000
      @pntr := @pntr(entry'size);                              <<02509>>33685000
      end;                                                     <<02509>>33690000
   move cppntr := chan'pgm'end,(cpend'len),2;                  <<02509>>33695000
   @cppntr := tos;                                             <<02509>>33700000
   move adrpntr := lbuf(512),(@cppntr-@lbuf(512)),2;           <<02509>>33705000
   @cppntr := tos;                                             <<02509>>33710000
   cpsize := @cppntr-@lbuf;                                    <<02509>>33715000
   << compute jump target >>                                   <<02509>>33720000
   lbuf(cpbase'jmp'x) := @adrpntr-@lbuf(cpbase'jmp'x+1);       <<02509>>33725000
   writetape(lbuf,cpsize,1);                                   <<02509>>33730000
   blockn := blockn+1;                                         <<02509>>33735000
   temp := findsdiscgap(sdiscldev,blockn,discaddress);         <<02509>>33740000
   if temp <> 0 then ferror(tapefnum,tapefile);                <<02509>>33745000
                                                               <<02509>>33750000
   base := base1;                                              <<02509>>33755000
   zerobuf(lbuf,128);                                          <<02509>>33760000
   move lbuf := chan'pgm'base,(cpbase'len),2;                  <<02509>>33765000
   @adrpntr := tos;                                            <<02509>>33770000
   @cppntr := @adrpntr+9;                                      <<02509>>33775000
   lbuf(cpbase'jmp'x) := @cppntr-@lbuf(cpbase'jmp'x+1);        <<02509>>33780000
   if not floppy then                                          <<03604>>33785000
      lbuf(cpbase'filemask'x) := filemask(stype);              <<03604>>33790000
   lbuf(cpstat'cmd'x) := base+cpbase'statcmd'x;                <<02509>>33795000
   lbuf(cpstat'adr'x) := base+cpbase'statbuf;                  <<02509>>33800000
   read(0,base2,discaddress,cpsize);                           <<02509>>33805000
   << compute absolute jump target >>                          <<02509>>33810000
   cppntr := 0;  << jump >>                                    <<02509>>33815000
   cppntr(1) := base2+1-(@cppntr(2)-@lbuf+base);               <<02509>>33820000
   lbuf := checksum(lbuf,128,seed);                            <<02509>>33825000
   tos := p'attachio(sdiscldev,0,0,@lbuf,11,128,0,2,1);        <<07443>>33830000
   ioerrcheck(*,*);                                            <<02509>>33835000
end;                                                           <<02509>>33840000
procedure build'sio'sdisc( tape'fmt'tab);                      <<02509>>33845000
   integer array tape'fmt'tab;                                 <<02509>>33850000
begin                                                          <<02509>>33855000
   equate                                                      <<02509>>33860000
      base1         =  %1400,                                  <<02509>>33865000
      base2         =  %1000,                                  <<02509>>33870000
      base3         =  %2000;                                  <<02509>>33875000
   define                                                      <<02509>>33880000
      entry'size    =  tape'fmt'tab.(0:8)#,                    <<02509>>33885000
      entries       =  tape'fmt'tab.(8:8)#,                    <<02509>>33890000
      length        =  pntr#,                                  <<02509>>33895000
      coreadr1      =  pntr(1)#,                               <<02509>>33900000
      coreadr2      =  pntr(2)#,                               <<02509>>33905000
      discadr1      =  pntr(3)#,                               <<02509>>33910000
      discadr2      =  pntr(4)#;                               <<02509>>33915000
   integer                                                     <<02509>>33920000
      siosize,                                                 <<02509>>33925000
      sioentry,                                                <<02509>>33930000
      base,                                                    <<02509>>33935000
      size,                                                    <<02509>>33940000
      nrsects,                                                 <<02509>>33945000
      maxread,                                                 <<02509>>33950000
      rem,                                                     <<02509>>33955000
      len;                                                     <<02509>>33960000
   double array discaddress(0:0)=q;                            <<02509>>33965000
   integer pointer                                             <<02509>>33970000
      pntr,                                                    <<02509>>33975000
      siopntr,                                                 <<02509>>33980000
      adrpntr;                                                 <<02509>>33985000
   equate                                                      <<02509>>33990000
      sprd'len      =  %20,                                    <<02509>>33995000
      spend'len     =    2;                                    <<02509>>34000000
   array sio'pgm'read(*) = pb :=                               <<02509>>34005000
     <<  0 >>  %14000,      << set bank to 0               >>  <<02509>>34010000
     <<  1 >>       0,                                         <<02509>>34015000
                                                               <<02509>>34020000
     <<  2 >>  %40000,      << send seek command           >>  <<02509>>34025000
     <<  3 >>   %1200,                                         <<02509>>34030000
                                                               <<02509>>34035000
     <<  4 >>  %67776,      << send seek address           >>  <<02509>>34040000
     <<  5*>>       0,                                         <<02509>>34045000
                                                               <<02509>>34050000
     <<  6 >>  %40000,      << set filemask                >>  <<02509>>34055000
     <<  7*>>       0,                                         <<02509>>34060000
                                                               <<02509>>34065000
     << 10 >>  %40000,      << send address record command >>  <<02509>>34070000
     << 11 >>   %6000,                                         <<02509>>34075000
                                                               <<02509>>34080000
     << 12 >>  %67776,      << send address                >>  <<02509>>34085000
     << 13*>>       0,                                         <<02509>>34090000
                                                               <<02509>>34095000
     << 14 >>  %40000,      << send read command           >>  <<02509>>34100000
     << 15 >>   %2400,                                         <<02509>>34105000
                                                               <<02509>>34110000
     << 16 >>  %14000,      << set bank, of data           >>  <<02509>>34115000
     << 17*>>       0;                                         <<02509>>34120000
   array sio'pgm'end(*) = pb :=                                <<02509>>34125000
     <<  0 >>  %34000,      << end with interrupt          >>  <<02509>>34130000
     <<  1 >>       0;                                         <<02509>>34135000
   subroutine sioread( address, words);                        <<02509>>34140000
      value words;                                             <<02509>>34145000
      integer address, words;                                  <<02509>>34150000
   begin                                                       <<02509>>34155000
      while words > 0 do                                       <<02509>>34160000
         begin                                                 <<02509>>34165000
         len := if words > 4096 then 4096 else words;          <<02509>>34170000
         siopntr := -len;                                      <<02509>>34175000
         siopntr(1) := address;                                <<02509>>34180000
         @siopntr := @siopntr+2;                               <<02509>>34185000
         address := address+len;                               <<02509>>34190000
         words := words-len;                                   <<02509>>34195000
         end;                                                  <<02509>>34200000
      siopntr(-2).(0:1) := 0; << stop chain >>                 <<02509>>34205000
   end;                                                        <<02509>>34210000
   subroutine read(bank,address,discadr,size);                 <<02509>>34215000
      value bank,address,discadr,size;                         <<02509>>34220000
      integer bank,address,size;                               <<02509>>34225000
      double discadr;                                          <<02509>>34230000
   begin                                                       <<02509>>34235000
      while size > 0 do                                        <<02509>>34240000
         begin                                                 <<02509>>34245000
         nrsects := (size+127)/128;                            <<02509>>34250000
         tos := discadr;                                       <<02509>>34255000
         tos := sec'cyl( stype);                               <<02509>>34260000
         assemble( ldiv, delb );                               <<02509>>34265000
         rem := tos;                                           <<02509>>34270000
         maxread := if nrsects > sec'cyl(stype)-rem then       <<02509>>34275000
            (sec'cyl(stype)-rem)*128 else size;                <<02509>>34280000
         move siopntr := sio'pgm'read,(sprd'len);              <<02509>>34285000
         siopntr(5) := siopntr(11) := @adrpntr-@lbuf+base;     <<02509>>34290000
         siopntr(7) := filemask( stype);                       <<02509>>34295000
         siopntr(15) := bank;                                  <<02509>>34300000
         @siopntr := @siopntr+sprd'len;                        <<02509>>34305000
         sioread( address, maxread);                           <<02509>>34310000
         tos := l'padr( discadr);                              <<02509>>34315000
         adrpntr(1) := tos;                                    <<02509>>34320000
         adrpntr := tos;                                       <<02509>>34325000
         @adrpntr := @adrpntr+2;                               <<02509>>34330000
         discadr := discadr+double((maxread+127)/128);         <<02509>>34335000
         size := size-maxread;                                 <<02509>>34340000
         end;                                                  <<02509>>34345000
   end;                                                        <<02509>>34350000
   base := base3;                                              <<02509>>34355000
   @adrpntr := @lbuf;                                          <<02509>>34360000
   @siopntr := @lbuf(512);                                     <<02509>>34365000
   @pntr := @tape'fmt'tab(entry'size);                         <<02509>>34370000
   while @pntr <= @tape'fmt'tab(entries*entry'size) do         <<02509>>34375000
      begin                                                    <<02509>>34380000
      move discaddress := discadr1,(2);                        <<02509>>34385000
      read(coreadr1,coreadr2,discaddress,length);              <<02509>>34390000
      @pntr := @pntr(entry'size);                              <<02509>>34395000
      end;                                                     <<02509>>34400000
   move siopntr := sio'pgm'end,(spend'len),2;                  <<02509>>34405000
   @siopntr := tos;                                            <<02509>>34410000
   move adrpntr := lbuf(512),(@siopntr-@lbuf(512)),2;          <<02509>>34415000
   @siopntr := tos;                                            <<02509>>34420000
   siosize := @siopntr-@lbuf;                                  <<02509>>34425000
   sioentry := @adrpntr-@lbuf+base;                            <<02509>>34430000
   writetape(lbuf,siosize,1);                                  <<02509>>34435000
   blockn := blockn+1;                                         <<02509>>34440000
   temp := findsdiscgap(sdiscldev,blockn,discaddress);         <<02509>>34445000
   if temp <> 0 then ferror(tapefnum,tapefile);                <<02509>>34450000
                                                               <<02509>>34455000
   base := base2;                                              <<02509>>34460000
   @adrpntr := @lbuf;                                          <<02509>>34465000
   @siopntr := @lbuf(512);                                     <<02509>>34470000
   read(0,base3,discaddress,siosize);                          <<02509>>34475000
   siopntr := 0;  << sio jump >>                               <<02509>>34480000
   siopntr(1) := sioentry; << jump target >>                   <<02509>>34485000
   @siopntr := @siopntr+2;                                     <<02509>>34490000
   move adrpntr := lbuf(512),(@siopntr-@lbuf(512)),2;          <<02509>>34495000
   @siopntr := tos;                                            <<02509>>34500000
   siosize := @siopntr-@lbuf;                                  <<02509>>34505000
   sioentry := @adrpntr-@lbuf+base;                            <<02509>>34510000
   tos := p'attachio(sdiscldev,0,0,@lbuf,11,siosize,0,3,1);    <<07443>>34515000
   ioerrcheck(*,*);                                            <<02509>>34520000
                                                               <<02509>>34525000
   base := base1;                                              <<02509>>34530000
   tos := p'attachio(sdiscldev,0,0,@lbuf,0,128,0,0,1);         <<07443>>34535000
   ioerrcheck(*,*);                                            <<02509>>34540000
   << create cold load read program >>                         <<02509>>34545000
   lbuf := %40000;     << read from sector 3 >>                <<02509>>34550000
   lbuf(1) := 3;                                               <<02509>>34555000
   lbuf(2) := logical(-siosize) land %77777;                   <<02509>>34560000
   lbuf(3) := base2;                                           <<02509>>34565000
   lbuf(4) := 0;          << sio jump >>                       <<02509>>34570000
   lbuf(5) := sioentry;   << jump target >>                    <<02509>>34575000
   tos := p'attachio(sdiscldev,0,0,@lbuf,11,128,0,0,1);        <<07443>>34580000
   ioerrcheck(*,*);                                            <<02509>>34585000
end;                                                           <<02509>>34590000
$control segment=dumptape                                      <<03544>>34595000
        <<---------------------------------->>                 <<03544>>34600000
        << build cs'80 boot channel program >>                 <<03544>>34605000
        <<---------------------------------->>                 <<03544>>34610000
procedure build'cs80'sdisc( tape'fmt'tab);                     <<03544>>34615000
integer array tape'fmt'tab;                                    <<03544>>34620000
begin                                                          <<03544>>34625000
equate                                                         <<03544>>34630000
   base1         =  %7100,                                     <<03544>>34635000
   base2         =  %2000;                                     <<03544>>34640000
define                                                         <<03544>>34645000
   entry'size    =  tape'fmt'tab.(0:8)#,                       <<03544>>34650000
   entries       =  tape'fmt'tab.(8:8)#,                       <<03544>>34655000
   length        =  pntr#,     << tape'fmt'tab definition: >>  <<03544>>34660000
   coreadr1      =  pntr(1)#,  << 5-word entries contain   >>  <<03544>>34665000
   coreadr2      =  pntr(2)#,  << length of table (words), >>  <<03544>>34670000
   discadr1      =  pntr(3)#,  << double-word core address, >> <<03544>>34675000
   discadr2      =  pntr(4)#;  << and double-word disc addr >> <<03544>>34680000
integer                                                        <<03544>>34685000
   cpsize,                                                     <<03544>>34690000
   base,                                                       <<03544>>34695000
   size,                                                       <<03544>>34700000
   msglen;                                                     <<03544>>34705000
double array discaddress(0:0)=q;                               <<03544>>34710000
integer pointer                                                <<03544>>34715000
   pntr,                                                       <<03544>>34720000
   cppntr;                                                     <<03544>>34725000
byte pointer                                                   <<03544>>34730000
   adrpntr,                                                    <<03544>>34735000
   apntr;                                                      <<03544>>34740000
define                                                         <<03544>>34745000
   memx                   = (8:8)#;                            <<03544>>34750000
equate                                                         <<03544>>34755000
   cdb'read               =   0,                               <<03544>>34760000
   cdb'req'status         = %15,                               <<03544>>34765000
   cdb'set'sngl'vec       = %20,                               <<03544>>34770000
   cdb'set'length         = %30,                               <<03544>>34775000
   cdb'set'unit           = %40,                               <<03544>>34780000
   cdb'no'op              = %64,                               <<03544>>34785000
   cdb'set'vol            =%100,                               <<03544>>34790000
   maxmsg                 = 768;                               <<03544>>34795000
equate                                                         <<03544>>34800000
   cpbase'len             = %41,                               <<03544>>34805000
   cpbase'jmp'x           =   2,                               <<03544>>34810000
   cpbase'statcmd'x       =   3,                               <<03544>>34815000
   cpbase'statbuf         =   4,                               <<03544>>34820000
   cpstat'entry           = %16,                               <<03544>>34825000
   cpstat'cmd'x           = %22,                               <<03544>>34830000
   cpstat'adr'x           = %31,                               <<03544>>34835000
   cprd'len               = %23,                               <<03544>>34840000
   cprd'msglen'x          =   1,                               <<03544>>34845000
   cprd'msgadr'x          =   4,                               <<03544>>34850000
   cprd'cnt'x             = %10,                               <<03544>>34855000
   cprd'bank'x            = %12,                               <<03544>>34860000
   cprd'adr'x             = %13,                               <<03544>>34865000
   cprd'dsj'err1'x        = %21,                               <<03544>>34870000
   cprd'dsj'err2'x        = %22,                               <<03544>>34875000
   cprd'dsj'next          = %23,                               <<03544>>34880000
   cpend'len              =   3;                               <<03544>>34885000
<<     note:   a "*" besides a number indicates     >>         <<03544>>34890000
<<     a location within the channel program        >>         <<03544>>34895000
<<     that needs to be updated.                    >>         <<03544>>34900000
array chan'pgm'base(*) = pb :=                                 <<03544>>34905000
  <<  0*>>         0, << checksum                         >>   <<03544>>34910000
                                                               <<03544>>34915000
  <<  1 >>         0, << jump command                     >>   <<03544>>34920000
  <<  2*>>       %36, << jump target                      >>   <<03544>>34925000
                                                               <<03544>>34930000
  <<  3 >>       %15, << status request command           >>   <<03544>>34935000
                                                               <<03544>>34940000
  <<  4 >> 0,0,0,0,0, << status buffer - error status     >>   <<03544>>34945000
  << 11 >> 0,0,0,0,0, << will be returned here!           >>   <<03544>>34950000
                                                               <<03544>>34955000
  << 16 >>     %2005, << send read status command         >>   <<03544>>34960000
  << 17 >>         1,                                          <<03544>>34965000
  << 20 >>         0,                                          <<03544>>34970000
  << 21 >>    %42000,                                          <<03544>>34975000
  << 22*>>         0,                                          <<03544>>34980000
                                                               <<03544>>34985000
  << 23 >>     %1000, << wait                             >>   <<03544>>34990000
  << 24 >>         0,                                          <<03544>>34995000
                                                               <<03544>>35000000
  << 25 >>     %1416, << execution msg secondary          >>   <<03544>>35005000
  << 26 >>        20, << #status bytes to read            >>   <<03544>>35010000
  << 27 >>         0, << burst                            >>   <<03544>>35015000
  << 30 >>     %2000, << data bank                        >>   <<03544>>35020000
  << 31*>>         0, << data buffer absolute address     >>   <<03544>>35025000
                                                               <<03544>>35030000
  << 32 >>     %1000, << wait                             >>   <<03544>>35035000
  << 33 >>         0,                                          <<03544>>35040000
                                                               <<03544>>35045000
  << 34 >>     %2400, << reporting msg secondary          >>   <<03544>>35050000
  << 35 >>         0,                                          <<03544>>35055000
  << 36 >>         0,                                          <<03544>>35060000
                                                               <<03544>>35065000
  << 37 >>      %600, << int/halt - bad news halt         >>   <<03544>>35070000
  << 40 >>         1; << error - cause system halt!       >>   <<03544>>35075000
array chan'pgm'read(*) = pb :=                                 <<03544>>35080000
  <<  0 >>     %2005, << command msg secondary            >>   <<03544>>35085000
  <<  1*>>         0, << command msg buffer length        >>   <<03544>>35090000
  <<  2 >>         0, << burst                            >>   <<03544>>35095000
  <<  3 >>     %2000, << command buffer bank              >>   <<03544>>35100000
  <<  4*>>         0, << command buffer absolute address  >>   <<03544>>35105000
                                                               <<03544>>35110000
  <<  5 >>     %1000, << wait                             >>   <<03544>>35115000
  <<  6 >>         0,                                          <<03544>>35120000
                                                               <<03544>>35125000
  <<  7 >>     %1416, << execution msg secondary          >>   <<03544>>35130000
  << 10*>>         0, << number of data bytes to read     >>   <<03544>>35135000
  << 11 >>         0, << burst                            >>   <<03544>>35140000
  << 12*>>         0, << data bank                        >>   <<03544>>35145000
  << 13*>>         0, << data buffer absolute address     >>   <<03544>>35150000
                                                               <<03544>>35155000
  << 14 >>     %1000, << wait                             >>   <<03544>>35160000
  << 15 >>         0,                                          <<03544>>35165000
                                                               <<03544>>35170000
  << 16 >>     %2402, << dsj - reporting phase            >>   <<03544>>35175000
  << 17 >>         0,                                          <<03544>>35180000
  << 20 >>         0, << a-ok jump                        >>   <<03544>>35185000
  << 21*>>         0, << hard error jump                  >>   <<03544>>35190000
  << 22*>>         0; << power on jump                    >>   <<03544>>35195000
array chan'pgm'end(*) = pb :=                                  <<03544>>35200000
  <<  0 >>      %600, << int/halt                         >>   <<03544>>35205000
  <<  1 >>         0, << good news halt!                  >>   <<03544>>35210000
                                                               <<03544>>35215000
  <<  2 >>        -1; << terminator                       >>   <<03544>>35220000
                                                               <<03544>>35225000
subroutine read( bank, address, discadr, size);                <<03544>>35230000
value bank, address, discadr, size;                            <<03544>>35235000
integer bank, address, size;                                   <<03544>>35240000
double discadr;                                                <<03544>>35245000
                                                               <<03544>>35250000
comment                                                        <<03544>>35255000
builds a channel program to do one read                        <<03544>>35260000
;                                                              <<03544>>35265000
                                                               <<03544>>35270000
begin                                                          <<03544>>35275000
size := size&lsl(1);                                           <<03544>>35280000
@apntr := @adrpntr; << save start of cmd buffer >>             <<03544>>35285000
                                                               <<03544>>35290000
<< build cmd buffer >>                                         <<03544>>35295000
                                                               <<03544>>35300000
adrpntr := cdb'set'sngl'vec;                                   <<03544>>35305000
adrpntr(1) := 0;                                               <<03544>>35310000
adrpntr(2) := 0;                                               <<03544>>35315000
tos := @discadr&lsl(1);                                        <<03544>>35320000
move adrpntr(3) := *,(4);                                      <<03544>>35325000
adrpntr(7) := cdb'set'length;                                  <<03544>>35330000
adrpntr(8) := 0;                                               <<03544>>35335000
adrpntr(9) := 0;                                               <<03544>>35340000
tos := @size&lsl(1);                                           <<03544>>35345000
move adrpntr(10) := *,(2);                                     <<03544>>35350000
adrpntr(12) := cdb'read;                                       <<03544>>35355000
msglen := 13;                                                  <<03544>>35360000
@adrpntr := @adrpntr(14);                                      <<03544>>35365000
                                                               <<03544>>35370000
<< build channel program >>                                    <<03544>>35375000
                                                               <<03544>>35380000
move cppntr := chan'pgm'read,(cprd'len);                       <<03544>>35385000
cppntr(cprd'msglen'x) := msglen;                               <<03544>>35390000
cppntr(cprd'msgadr'x) := base+wordaddress(apntr)-@lbuf;        <<03704>>35395000
cppntr(cprd'cnt'x) := size;                                    <<03544>>35400000
cppntr(cprd'bank'x).memx := bank;                              <<03544>>35405000
cppntr(cprd'adr'x) := address;                                 <<03544>>35410000
cppntr(cprd'dsj'err1'x) := cppntr(cprd'dsj'err2'x) :=          <<03544>>35415000
   @lbuf(cpstat'entry) - @cppntr(cprd'dsj'next);               <<03544>>35420000
@cppntr := @cppntr+cprd'len;                                   <<03544>>35425000
end;   << read >>                                              <<03544>>35430000
                                                               <<03544>>35435000
<< build large channel program with many reads to go >>        <<03544>>35440000
<< at address %2000.                                 >>        <<03544>>35445000
                                                               <<03544>>35450000
base := base2;                                                 <<03544>>35455000
move lbuf := chan'pgm'base,(cpbase'len),2;                     <<03544>>35460000
@adrpntr := tos&lsl(1); << make byte address >>                <<03544>>35465000
@cppntr := @lbuf(maxmsg);                                      <<03544>>35470000
lbuf(cpstat'cmd'x) := base+cpbase'statcmd'x;                   <<03544>>35475000
lbuf(cpstat'adr'x) := base+cpbase'statbuf;                     <<03544>>35480000
                                                               <<03544>>35485000
<< build one read channel program for every entry in >>        <<03544>>35490000
<< tape'fmt'table                                    >>        <<03544>>35495000
                                                               <<03544>>35500000
@pntr := @tape'fmt'tab(entry'size);                            <<03544>>35505000
while @pntr <= @tape'fmt'tab(entries*entry'size) do            <<03544>>35510000
   begin                                                       <<03544>>35515000
   move discaddress := discadr1,(2);                           <<03544>>35520000
   read(coreadr1,coreadr2,discaddress,length);                 <<03544>>35525000
   @pntr := @pntr(entry'size);                                 <<03544>>35530000
   end;                                                        <<03544>>35535000
move cppntr := chan'pgm'end,(cpend'len),2;                     <<03544>>35540000
@cppntr := tos;                                                <<03544>>35545000
@pntr := wordaddress(adrpntr);  << change to word pntr >>      <<03704>>35550000
cpsize := @cppntr-@lbuf;                                       <<03544>>35555000
<< compute jump target >>                                      <<03544>>35560000
lbuf(cpbase'jmp'x) := @lbuf(maxmsg)-@lbuf(cpbase'jmp'x+1);     <<03544>>35565000
writetape(lbuf,cpsize,1);     << write out channel program >>  <<03544>>35570000
blockn := blockn+1;                                            <<03544>>35575000
                                                               <<03544>>35580000
<< find out where on the serial disc the large channel >>      <<03544>>35585000
<< program was put                                     >>      <<03544>>35590000
                                                               <<03544>>35595000
temp := findsdiscgap(sdiscldev,blockn,discaddress);            <<03544>>35600000
if temp <> 0 then ferror(tapefnum,tapefile);                   <<03544>>35605000
                                                               <<03544>>35610000
<< now build the small channel program, which reads in  >>     <<03544>>35615000
<< the larger one, to run at %7100                      >>     <<03544>>35620000
                                                               <<03544>>35625000
base := base1;                                                 <<03544>>35630000
zerobuf(lbuf,128);                                             <<03544>>35635000
move lbuf := chan'pgm'base,(cpbase'len),2;                     <<03544>>35640000
@adrpntr := s0&lsl(1); << make byte address >>                 <<03544>>35645000
@cppntr := tos+27; << room for three msg reads >>              <<03544>>35650000
lbuf(cpbase'jmp'x) := @cppntr-@lbuf(cpbase'jmp'x+1);           <<03544>>35655000
lbuf(cpstat'cmd'x) := base+cpbase'statcmd'x;                   <<03544>>35660000
lbuf(cpstat'adr'x) := base+cpbase'statbuf;                     <<03544>>35665000
read(0,base2,discaddress,cpsize);                              <<03544>>35670000
<< compute absolute jump target >>                             <<03544>>35675000
cppntr := 0;  << jump >>                                       <<03544>>35680000
cppntr(1) := base2+1-(@cppntr(2)-@lbuf+base);                  <<03544>>35685000
lbuf := checksum(lbuf,128,seed);                               <<03544>>35690000
                                                               <<03544>>35695000
<< write this channel program out to sector 2 >>               <<03544>>35700000
                                                               <<03544>>35705000
tos := p'attachio(sdiscldev,0,0,@lbuf,11,128,0,2,1);           <<07443>>35710000
ioerrcheck(*,*);                                               <<03544>>35715000
end;   << build'cs80'sdisc >>                                  <<03544>>35720000
                                                               <<03544>>35725000
integer procedure compute'wcs'size;                            <<03005>>35730000
begin                                                          <<03005>>35735000
   equate                                                      <<03005>>35740000
         << tape wcs table format >>                           <<03005>>35745000
      nr'entries        = 32,                                  <<03005>>35750000
      entry'size        = 4,                                   <<03005>>35755000
      wcstab'size       = nr'entries*entry'size,               <<03005>>35760000
         << tape wcs table entry format >>                     <<03005>>35765000
      recs'to'wcs       = 0,                                   <<03005>>35770000
      recs'of'wcs       = 1,                                   <<03005>>35775000
      recs'after'wcs    = 2,                                   <<03005>>35780000
      wcsrecsize        = 3,                                   <<03604>>35785000
         << allocation of entries in wcs table >>              <<03005>>35790000
      icf55'tab'x       = 4,                                   <<08393>>35795000
      icf37'tab'x       = 5;                                   <<08393>>35800000
   equate                                                      <<03005>>35805000
         << allocation of disc wcs pointer entries >>          <<03005>>35810000
      icf55'wcs'disc'x  = 0,                                   <<08393>>35815000
      icf37'wcs'disc'x  = 1;                                   <<08393>>35820000
   double array                                                <<03005>>35825000
      discwcstab(*)     = lbuf(%25);                           <<03005>>35830000
   integer                                                     <<03005>>35835000
      fnum,                                                    <<03005>>35840000
      errnr,                                                   <<03005>>35845000
      len,                                                     <<03005>>35850000
      rec,                                                     <<03005>>35855000
      total'wcs'recs = compute'wcs'size,                       <<03604>>35860000
      wcstaperecsize, << iml microcode can only handle       >><<04130>>35865000
                      << record sizes of 1024,2048,3072,4096 >><<04130>>35870000
      temp,                                                    <<03005>>35875000
      s0 = s-0,                                                <<03005>>35880000
      x = x;                                                   <<03005>>35885000
   double                                                      <<03005>>35890000
      discaddress;                                             <<03005>>35895000
   entry                                                       <<03005>>35900000
      dump'wcs;                                                <<03005>>35905000
   integer pointer                                             <<03005>>35910000
      wcstabpntr;                                              <<03005>>35915000
   byte array                                                  <<03005>>35920000
      filename(0:8);                                           <<03005>>35925000
   integer array rec0(*) = lbuf(4096);                         <<03604>>35930000
   integer array wcstab(*) = stt;                              <<03005>>35935000
   integer array wcsfnum(*) = stt(wcstab'size);                <<03005>>35940000
                                                               <<03005>>35945000
   <<    icf/55 wcs constants    >>                            <<03005>>35950000
                                                               <<03005>>35955000
   double array drec0(*) = rec0;                               <<03005>>35960000
   define                                                      <<03005>>35965000
      nr'wcs'locs       = drec0(2)#,                           <<03005>>35970000
      nr'lut'locs       = drec0(3)#;                           <<03005>>35975000
   byte array icf55wcsname(*)=pb := "SYSWCS64 ";               <<03061>>35980000
                                                               <<03005>>35985000
   <<    icf/37 wcs constants   >>                             <<08393>>35990000
                                                               <<08393>>35995000
   define                                                      <<08393>>36000000
      nr'slow'wcs       = drec0(2)#,                           <<08393>>36005000
      nr'fast'wcs       = drec0(3)#;                           <<08393>>36010000
   byte array icf37wcsname(*)= pb := "SYSWCS37 ";              <<08393>>36015000
                                                               <<08393>>36020000
   subroutine dump'it( words);                                 <<03005>>36025000
      value words;                                             <<03005>>36030000
      double words;                                            <<03005>>36035000
   begin                                                       <<03005>>36040000
   while words > 0d do                                         <<03005>>36045000
      begin                                                    <<03005>>36050000
      len := if words > double(wcstaperecsize) then            <<04130>>36055000
             wcstaperecsize else logical(words);               <<04130>>36060000
      freaddir( fnum,lbuf,len,double(rec));                    <<03005>>36065000
      if <> then ferror( fnum,fullname);                       <<03005>>36070000
      writetape( lbuf,len,0);                                  <<03005>>36075000
      words := words-double(len);                              <<03005>>36080000
      rec := rec+(len+127)/128;                                <<03005>>36085000
      end;                                                     <<03005>>36090000
   end;                                                        <<03005>>36095000
   subroutine update'sect0( wcs'disc'x);                       <<03005>>36100000
      value wcs'disc'x;                                        <<03005>>36105000
      integer wcs'disc'x;                                      <<03005>>36110000
   begin                                                       <<03005>>36115000
   if not magtape then                                         <<03005>>36120000
      begin                                                    <<03005>>36125000
      blockn := blockn+1;                                      <<03005>>36130000
      temp := findsdiscgap(sdiscldev,blockn,discaddress);      <<03005>>36135000
      if temp <> 0 then ferror(tapefnum,tapefile);             <<03005>>36140000
      tos := p'attachio(sdiscldev,0,0,@lbuf,0,128,0,0,1);      <<07443>>36145000
      ioerrcheck(*,*);                                         <<03005>>36150000
      discwcstab(wcs'disc'x) := l'padr(discaddress);           <<03005>>36155000
      tos := p'attachio(sdiscldev,0,0,@lbuf,11,128,0,0,1);     <<07443>>36160000
      ioerrcheck(*,*);                                         <<03005>>36165000
      end;                                                     <<03005>>36170000
   end;                                                        <<03005>>36175000
                                                               <<03005>>36180000
      << round taperecsize to 1024,2048,3072,4096 >>           <<04130>>36185000
   wcstaperecsize := logical(taperecsize) land %16000;         <<04130>>36190000
   zerobuf(wcsfnum,nr'entries);                                <<03005>>36195000
   zerobuf(wcstab,wcstab'size);                                <<03005>>36200000
                                                               <<03005>>36205000
   <<***************************************************>>     <<03005>>36210000
   <<    icf/55 wcs size                                >>     <<03005>>36215000
   <<***************************************************>>     <<03005>>36220000
                                                               <<03005>>36225000
   @wcstabpntr := @wcstab(icf55'tab'x*entry'size);             <<03005>>36230000
   move filename := icf55wcsname,(9);                          <<03005>>36235000
   search'sysfile( filename);                                  <<03005>>36240000
   fnum := fopen( fullname,3,%420);                            <<03005>>36245000
   if <> then                                                  <<03005>>36250000
      begin                                                    <<03005>>36255000
      fcheck( fnum, errnr);                                    <<03005>>36260000
      if errnr <> 52 then ferror( fnum,fullname);              <<03005>>36265000
      end                                                      <<03005>>36270000
   else                                                        <<03005>>36275000
      begin                                                    <<03005>>36280000
      fread( fnum,rec0,128);                                   <<03005>>36285000
      if < then ferror( wcsfnum, fullname);                    <<03005>>36290000
      if > then fclose( fnum, 0, 0)                            <<03005>>36295000
      else                                                     <<03005>>36300000
         begin                                                 <<03005>>36305000
         wcstabpntr(recs'to'wcs) := total'wcs'recs;            <<03005>>36310000
         tos := (nr'wcs'locs*4d+double(wcstaperecsize)-1d)/    <<04130>>36315000
            double(wcstaperecsize) + (nr'lut'locs*2d+          <<04130>>36320000
            double(wcstaperecsize)-1d)/double(wcstaperecsize); <<04130>>36325000
         if <> then tos := tos+1; << record 0 >>               <<03604>>36330000
         wcstabpntr(recs'of'wcs) := s0;                        <<03005>>36335000
         wcstabpntr(wcsrecsize) := -wcstaperecsize;            <<04130>>36340000
         total'wcs'recs := total'wcs'recs+tos;                 <<03005>>36345000
         del;                                                  <<03005>>36350000
         wcsfnum(icf55'tab'x) := fnum;                         <<03005>>36355000
         end;                                                  <<03005>>36360000
      end;                                                     <<03005>>36365000
                                                               <<03005>>36370000
   <<***************************************************>>     <<08393>>36375000
   <<    icf/37 wcs size                                >>     <<08393>>36380000
   <<***************************************************>>     <<08393>>36385000
                                                               <<08393>>36390000
   @wcstabpntr := @wcstab(icf37'tab'x*entry'size);             <<08393>>36395000
   move filename := icf37wcsname,(9);                          <<08393>>36400000
   search'sysfile( filename);                                  <<08393>>36405000
   fnum := fopen( fullname,3,%420);                            <<08393>>36410000
   if <> then                                                  <<08393>>36415000
      begin                                                    <<08393>>36420000
      fcheck( fnum, errnr);                                    <<08393>>36425000
      if errnr <> 52 then ferror( fnum,fullname);              <<08393>>36430000
      end                                                      <<08393>>36435000
   else                                                        <<08393>>36440000
      begin                                                    <<08393>>36445000
      fread( fnum,rec0,128);                                   <<08393>>36450000
      if < then ferror( wcsfnum, fullname);                    <<08393>>36455000
      if > then fclose( fnum, 0, 0)                            <<08393>>36460000
      else                                                     <<08393>>36465000
         begin                                                 <<08393>>36470000
         wcstabpntr(recs'to'wcs) := total'wcs'recs;            <<08393>>36475000
         tos := (nr'slow'wcs*4d+double(wcstaperecsize)-1d)/    <<08393>>36480000
            double(wcstaperecsize) + (nr'fast'wcs*4d+          <<08393>>36485000
            double(wcstaperecsize)-1d)/double(wcstaperecsize); <<08393>>36490000
         if <> then tos := tos+1; << record 0 >>               <<08393>>36495000
         wcstabpntr(recs'of'wcs) := s0;                        <<08393>>36500000
         wcstabpntr(wcsrecsize) := -wcstaperecsize;            <<08393>>36505000
         total'wcs'recs := total'wcs'recs+tos;                 <<08393>>36510000
         del;                                                  <<08393>>36515000
         wcsfnum(icf37'tab'x) := fnum;                         <<08393>>36520000
         end;                                                  <<08393>>36525000
      end;                                                     <<08393>>36530000
                                                               <<08393>>36535000
   <<**************************************************>>      <<03005>>36540000
   <<    fill in records after wcs in wcs table        >>      <<03005>>36545000
   <<**************************************************>>      <<03005>>36550000
                                                               <<03005>>36555000
   @wcstabpntr := @wcstab;                                     <<03005>>36560000
   while @wcstabpntr <> @wcstab(wcstab'size) do                <<03005>>36565000
      begin                                                    <<03005>>36570000
      wcstabpntr(recs'after'wcs) := total'wcs'recs             <<03005>>36575000
         -wcstabpntr(recs'to'wcs)-wcstabpntr(recs'of'wcs);     <<03005>>36580000
      @wcstabpntr := @wcstabpntr(entry'size);                  <<03005>>36585000
      end;                                                     <<03005>>36590000
                                                               <<03005>>36595000
   << add in length of wcs table >>                            <<03005>>36600000
                                                               <<03005>>36605000
   total'wcs'recs := total'wcs'recs+1;                         <<03005>>36610000
                                                               <<03005>>36615000
   return;                                                     <<03005>>36620000
                                                               <<03005>>36625000
dump'wcs:   << wcs dump entry point >>                         <<03005>>36630000
                                                               <<03005>>36635000
      << round taperecsize to 1024,2048,3072,4096 >>           <<04130>>36640000
   wcstaperecsize := logical(taperecsize) land %16000;         <<04130>>36645000
   <<***************************************************>>     <<03005>>36650000
   <<   write wcs files to tape/serial disc             >>     <<03005>>36655000
   <<***************************************************>>     <<03005>>36660000
                                                               <<03005>>36665000
   if magtape then                                             <<03005>>36670000
      begin                                                    <<03005>>36675000
      fwrite(tapefnum,wcstab,wcstab'size,0); << wcs table >>   <<03005>>36680000
      if <> then ferror(tapefnum,tapefile);                    <<03005>>36685000
      end;                                                     <<03005>>36690000
                                                               <<03005>>36695000
   <<***************************************************>>     <<03005>>36700000
   <<   dump icf/55 wcs to tape/serial disc             >>     <<03005>>36705000
   <<***************************************************>>     <<03005>>36710000
                                                               <<03005>>36715000
   move filename := icf55wcsname,(9);                          <<03005>>36720000
   search'sysfile( filename);                                  <<03005>>36725000
   fnum := wcsfnum(icf55'tab'x);                               <<03005>>36730000
   if fnum <> 0 then                                           <<03005>>36735000
      begin                                                    <<03005>>36740000
      freaddir(fnum,rec0,128,0d);                              <<03005>>36745000
      if <> then ferror( fnum, fullname);                      <<03005>>36750000
      fwrite(tapefnum,rec0,128,%1001);  << record 0 >>         <<03005>>36755000
      if <> then ferror(tapefnum,tapefile);                    <<03005>>36760000
      rec := 1;                                                <<03005>>36765000
      dump'it( nr'wcs'locs&dlsl(2));    << wcs >>              <<03005>>36770000
      dump'it( nr'lut'locs&dlsl(1));    << lut >>              <<03005>>36775000
      fwrite(tapefnum,rec0,0,%2001);    << end contig blk >>   <<03005>>36780000
      if <> then ferror(tapefnum,tapefile);                    <<03005>>36785000
      fclose(fnum,0,0);                                        <<03005>>36790000
      update'sect0( icf55'wcs'disc'x);                         <<03005>>36795000
      end;                                                     <<03005>>36800000
                                                               <<08393>>36805000
   <<***************************************************>>     <<08393>>36810000
   <<   dump icf/37 wcs to tape/serial disc             >>     <<08393>>36815000
   <<***************************************************>>     <<08393>>36820000
                                                               <<08393>>36825000
   move filename := icf37wcsname,(9);                          <<08393>>36830000
   search'sysfile( filename);                                  <<08393>>36835000
   fnum := wcsfnum(icf37'tab'x);                               <<08393>>36840000
   if fnum <> 0 then                                           <<08393>>36845000
      begin                                                    <<08393>>36850000
      freaddir(fnum,rec0,128,0d);                              <<08393>>36855000
      if <> then ferror( fnum, fullname);                      <<08393>>36860000
      fwrite(tapefnum,rec0,128,%1001);  << record 0 >>         <<08393>>36865000
      if <> then ferror(tapefnum,tapefile);                    <<08393>>36870000
      rec := 1;                                                <<08393>>36875000
      dump'it( nr'slow'wcs&dlsl(2));    << slow wcs >>         <<08393>>36880000
      dump'it( nr'fast'wcs&dlsl(2));    << fast wcs >>         <<08393>>36885000
      fwrite(tapefnum,rec0,0,%2001);    << end contig blk >>   <<08393>>36890000
      if <> then ferror(tapefnum,tapefile);                    <<08393>>36895000
      fclose(fnum,0,0);                                        <<08393>>36900000
      update'sect0( icf37'wcs'disc'x);                         <<08393>>36905000
      end;                                                     <<08393>>36910000
end;                                                           <<03005>>36915000
$control segment=dumptape                                      <<01073>>36920000
double procedure l'padr(discaddress);                          <<00.sd>>36925000
value discaddress;                                             <<00.sd>>36930000
double discaddress;                                            <<00.sd>>36935000
begin                                                          <<03544>>36940000
equate disc2'sectors'track = 30;                               <<03544>>36945000
                                                               <<03544>>36950000
if outdevtype = disc0 or outdevtype = disc2 then               <<03544>>36955000
  begin                                                        <<03544>>36960000
                                                               <<03544>>36965000
  tos:=discaddress;                                            <<00.sd>>36970000
  tos:=if floppy then flop'sec'cyl else                        <<00072>>36975000
  sec'cyl(stype);                                              <<00072>>36980000
  assemble(ldiv);                                              <<00.sd>>36985000
  if overflow then                                             <<00.sd>>36990000
    begin                                                      <<00.sd>>36995000
    message(m27); <<bad disc address>>                         <<*8393>>37000000
    purgetempsl;                                               <<00.sd>>37005000
    end;                                                       <<00.sd>>37010000
  tos:=if floppy then disc2'sectors'track else                 <<00072>>37015000
  secthd(stype);                                               <<00488>>37020000
  assemble(div,xch);                                           <<00.sd>>37025000
  tos:=tos&lsl(8)+tos;<<doesn't support 7905/6(f)>>            <<00072>>37030000
  l'padr:=tos;                                                 <<00.sd>>37035000
  end                                                          <<03544>>37040000
                                                               <<03544>>37045000
else         << cs'80 and any other types >>                   <<03544>>37050000
  l'padr := discaddress;   << pass back the logical address >> <<03544>>37055000
end;   << l'padr >>                                            <<03544>>37060000
$control segment=dumptape                                      <<01073>>37065000
                                                                        37070000
          <<---------------------------                                 37075000
            write core buffer to tape                                   37080000
          --------------------------->>                                 37085000
procedure writetape( buf, words, contig);                      <<03604>>37090000
   value words, contig;                                        <<03604>>37095000
   integer array buf;                                          <<03604>>37100000
   integer words;                                              <<03604>>37105000
   logical contig;                                             <<03604>>37110000
begin comment                                                  <<03604>>37115000
     writes the array "BUF" to tape blocked                    <<03604>>37120000
     according to "TAPERECSIZE";                               <<03604>>37125000
                                                               <<03604>>37130000
   integer                                                     <<03604>>37135000
      j := 0,                                                  <<03604>>37140000
      len;                                                     <<03604>>37145000
                                                               <<03604>>37150000
   while words <> 0 do                                         <<03604>>37155000
      begin                                                    <<03604>>37160000
      len := if words > taperecsize then taperecsize           <<03604>>37165000
         else words;                                           <<03604>>37170000
      fwrite( tapefnum,buf,len,if j=0 and contig then          <<03604>>37175000
              %1001 else 0);                                   <<03604>>37180000
     if <> then                                                <<07156>>37185000
         begin                                                 <<07156>>37190000
         fcheck( tapefnum, errorcode);                         <<07156>>37195000
         if errorcode = eotcode and floppy then                <<07156>>37200000
            begin                                              <<07156>>37205000
            nextreel;                                          <<07156>>37210000
            end                                                <<07156>>37215000
         else                                                  <<07156>>37220000
            ferror( tapefnum, tapefile);                       <<07156>>37225000
         end;                                                  <<07156>>37230000
      j:=j+1;                                                  <<03604>>37235000
      @buf := @buf(len);                                       <<03604>>37240000
      words := words-len;                                      <<03604>>37245000
      end;                                                     <<03604>>37250000
                                                               <<03604>>37255000
   if contig and j<>0 then                                     <<03604>>37260000
      begin                                                    <<03604>>37265000
      fwrite( tapefnum,buf,0,%2001);                           <<03604>>37270000
      if <> then ferror( tapefnum, tapefile);                  <<03604>>37275000
      end;                                                     <<03604>>37280000
end; << writetape >>                                           <<03604>>37285000
$control segment=dumptape                                      <<06814>>37290000
                                                               <<06814>>37295000
          <<-------------------------------->>                 <<06814>>37300000
          <<   write data segment to tape   >>                 <<06814>>37305000
          <<-------------------------------->>                 <<06814>>37310000
procedure writedsegtotape( dstn, words, contig);               <<06814>>37315000
   value dstn, words, contig;                                  <<06814>>37320000
   integer dstn, words;                                        <<06814>>37325000
   logical contig;                                             <<06814>>37330000
begin comment                                                  <<06814>>37335000
     writes the data segment "DSTN" to tape blocked            <<06814>>37340000
     according to "TAPERECSIZE";                               <<06814>>37345000
                                                               <<06814>>37350000
   integer                                                     <<06814>>37355000
      disp := 0,                                               <<06814>>37360000
      len;                                                     <<06814>>37365000
                                                               <<06814>>37370000
   while words <> 0 do                                         <<06814>>37375000
      begin                                                    <<06814>>37380000
      len := if words > taperecsize then taperecsize           <<06814>>37385000
         else words;                                           <<06814>>37390000
      mfds( lbuf, dstn, disp, len);                            <<06814>>37395000
      fwrite( tapefnum,lbuf,len,if disp=0 and contig then      <<06814>>37400000
              %1001 else 0);                                   <<06814>>37405000
      if <> then ferror( tapefnum, tapefile);                  <<06814>>37410000
      disp := disp+len;                                        <<06814>>37415000
      words := words-len;                                      <<06814>>37420000
      end;                                                     <<06814>>37425000
                                                               <<06814>>37430000
   if contig and disp<>0 then                                  <<06814>>37435000
      begin                                                    <<06814>>37440000
      fwrite( tapefnum,lbuf,0,%2001);                          <<06814>>37445000
      if <> then ferror( tapefnum, tapefile);                  <<06814>>37450000
      end;                                                     <<06814>>37455000
end; << writedsegtotape >>                                     <<06814>>37460000
<<***********************************************************>><<07089>>37465000
<<           dump  system  directory  to  tape               >><<07089>>37470000
<<***********************************************************>><<07089>>37475000
                                                               <<07089>>37480000
procedure dumpdirc (sectors, address, what);                   <<07089>>37485000
   value   sectors, address;                                   <<07089>>37490000
   logical sectors;               << directory size          >><<07089>>37495000
   double  address;               << directory address       >><<07089>>37500000
   byte array what;               << text                    >><<07089>>37505000
                                                               <<07089>>37510000
<<----------------------------------------------------------->><<07089>>37515000
<< this procedure dumps the entire directory to tape.        >><<07089>>37520000
<< it expands or crunch directory if neccessary. the arg.    >><<07089>>37525000
<< sectors represents new directry size. if old directory    >><<07089>>37530000
<< size (old'dir'size) <> sectors then directory expansion   >><<07089>>37535000
<< or crunch take place. if the directory size is <= 6112    >><<07089>>37540000
<< sectors then the dir. bit map will occupy 3 sectors       >><<07089>>37545000
<< otherwise 32 sectors. the directory address (address)     >><<07089>>37550000
<< pointed to last 3 sectors of the directory bit map i.e.   >><<07089>>37555000
<< if dir. size is <= 6112 then it points to the beginnig of >><<07089>>37560000
<< the dir. disc space (system account index always is value >><<07089>>37565000
<< of 3). however if dir. size is > 6112 then the dir. bit   >><<07089>>37570000
<< map occupies 32 sectors and the dir. bit map disc addr. is>><<07089>>37575000
<< equal dir. disc addr. - 29. also only 3 sectors of the    >><<07089>>37580000
<< bit map are represented in the bit map. therefore the dir.>><<07089>>37585000
<< size stored in the dir. space data segment represents only>><<07089>>37590000
<< directory data and 3 sectors of the bit map i.e. in case  >><<07089>>37595000
<< of the dir size > 6112 the ds'dir'size = dir. size - 29.  >><<07089>>37600000
<< if the directory is dumped all remainnig not allocated    >><<07089>>37605000
<< sectors are zeroed.                                       >><<07089>>37610000
<<----------------------------------------------------------->><<07089>>37615000
                                                               <<07089>>37620000
begin                                                          <<07089>>37625000
logical addr1 = address;                                       <<07089>>37630000
logical addr2 = address + 1;                                   <<07089>>37635000
integer start'addr;              << reset from addr.         >><<07089>>37640000
integer start'addr'w;            << reset from addr. in words>><<07089>>37645000
integer end'addr;                << reset to addr.           >><<07089>>37650000
integer end'addr'w;              << reset to addr. in words  >><<07089>>37655000
integer size;                    << dir. size - new          >><<07089>>37660000
integer size1;                   << dir. size - old          >><<07089>>37665000
logical rsize;                                                 <<s7529>>37670000
integer bmsize;                                                <<s7529>>37675000
integer len;                     << length of data - io      >><<07089>>37680000
logical maxsize;                 << max. size of dir bm (bit)>><<07089>>37685000
logical min;                                                   <<07089>>37690000
logical free;                    << true means - free space  >><<07089>>37695000
equate  alloc = 0;               << set bit to "0"           >><<07089>>37700000
equate  dealloc = %177777;       << set bit to "1"           >><<07089>>37705000
                                                               <<07089>>37710000
subroutine ioerrcheck (p1, p2);                                <<07089>>37715000
   value   p1, p2;                                             <<07089>>37720000
   logical p1, p2;                                             <<07089>>37725000
begin                                                          <<07089>>37730000
p1 := p1.(8:8);                  << extract status           >><<07089>>37735000
if p1 <> 1 then                                                <<07089>>37740000
   begin                                                       <<07089>>37745000
   p1 := -p1;                                                  <<07089>>37750000
   ferror (p1, what);                                          <<07089>>37755000
   end;                                                        <<07089>>37760000
end;                                                           <<07089>>37765000
                                                               <<07089>>37770000
subroutine tape'error;                                         <<07089>>37775000
begin                                                          <<07089>>37780000
fcheck (tapefnum, errorcode);                                  <<07089>>37785000
if errorcode = eotcode and floppy then                         <<07089>>37790000
   nextreel                                                    <<07089>>37795000
else                                                           <<07089>>37800000
   ferror (tapefnum, tapefile);                                <<07089>>37805000
end;                                                           <<07089>>37810000
                                                               <<07089>>37815000
subroutine dsm'setreset (saddr, eaddr, flag);                  <<07089>>37820000
   value   saddr, eaddr, flag;                                 <<07089>>37825000
   logical saddr, eaddr, flag;                                 <<07089>>37830000
                                                               <<07089>>37835000
<<----------------------------------------------------------->><<07089>>37840000
<< this subroutine set or reset bits in lbuf array starting  >><<07089>>37845000
<< form saddr (bit address). the flag = true   -   set to "1">><<07089>>37850000
<< (make space free).                                        >><<07089>>37855000
<<----------------------------------------------------------->><<07089>>37860000
                                                               <<07089>>37865000
begin                                                          <<07089>>37870000
start'addr := saddr - 1;                                       <<07089>>37875000
end'addr := eaddr - 1;                                         <<07089>>37880000
free := flag;                                                  <<07089>>37885000
start'addr'w := start'addr &lsr(4) + ds'dir'header;            <<07089>>37890000
end'addr'w := end'addr &lsr(4) + ds'dir'header;                <<07089>>37895000
                                                               <<07089>>37900000
tos := lbuf (start'addr'w);      << extract first word       >><<07089>>37905000
<<----------------------------------------------------------->><<07089>>37910000
<< reset bits in first word                                  >><<07089>>37915000
<<----------------------------------------------------------->><<07089>>37920000
x := start'addr &lsl(12) &lsr(12);                             <<07089>>37925000
while ( x := x + 1 ) < 16 do                                   <<07089>>37930000
   if free then                                                <<07089>>37935000
      assemble (tsbc 0, x)                                     <<07089>>37940000
   else                                                        <<07089>>37945000
      assemble (trbc 0, x);                                    <<07089>>37950000
lbuf (start'addr'w) := s0;     << post back                  >><<07089>>37955000
                                                               <<07089>>37960000
<<----------------------------------------------------------->><<07089>>37965000
<< reset by words if possible                                >><<07089>>37970000
<<----------------------------------------------------------->><<07089>>37975000
while (start'addr'w := start'addr'w + 1) < end'addr'w do       <<07089>>37980000
   lbuf (start'addr'w) := free;                                <<07089>>37985000
                                                               <<07089>>37990000
s0 := lbuf (end'addr'w);      << extract word                >><<07089>>37995000
<<----------------------------------------------------------->><<07089>>38000000
<< reset bits in last word                                   >><<07089>>38005000
<<----------------------------------------------------------->><<07089>>38010000
x := end'addr &lsl(12) &lsr(12);                               <<07089>>38015000
while ( x := x - 1 ) >= 0 do                                   <<07089>>38020000
   if free then                                                <<07089>>38025000
      assemble (tsbc 0, x)                                     <<07089>>38030000
   else                                                        <<07089>>38035000
      assemble (trbc 0, x);                                    <<07089>>38040000
lbuf (end'addr'w) := tos;     << post back                   >><<07089>>38045000
                                                               <<07089>>38050000
end;  << dsm'setreset >>                                       <<07089>>38055000
                                                               <<07089>>38060000
                                                               <<07089>>38065000
<<----------------------------------------------------------->><<07089>>38070000
<< write short record to tape with directory size            >><<07089>>38075000
<<----------------------------------------------------------->><<07089>>38080000
lbuf := 0;                                                     <<07089>>38085000
move lbuf (1) := lbuf, (19);                                   <<07089>>38090000
lbuf (2) := sectors;                                           <<07089>>38095000
fwrite (tapefnum, lbuf, 20, 0);                                <<07089>>38100000
if <> then                                                     <<07089>>38105000
   tape'error;                                                 <<07089>>38110000
                                                               <<07089>>38115000
<<----------------------------------------------------------->><<07089>>38120000
<< set dir. bit map disc addr. and max size of bit map in wd.>><<07089>>38125000
<<----------------------------------------------------------->><<07089>>38130000
if direc'size > 6112 then                                      <<07089>>38135000
   address := address - 29d;                                   <<07089>>38140000
if sectors > 6112 then                                         <<07089>>38145000
   maxsize := 65504             << (32*128-2)*16             >><<07089>>38150000
else                                                           <<07089>>38155000
   maxsize := 6112;             << (3*128-2)*16              >><<07089>>38160000
                                                               <<07089>>38165000
<<----------------------------------------------------------->><<07089>>38170000
<< read bit map form disc and allocate bits                  >><<07089>>38175000
<<----------------------------------------------------------->><<07089>>38180000
len := 4096;                    << up to 32 sectors          >><<07089>>38185000
tos := attachio (sysdisc, 0, 0, @lbuf, 0, len, addr1, addr2,1);<<07089>>38190000
ioerrcheck (*, *);                                             <<07089>>38195000
                                                               <<07089>>38200000
<<----------------------------------------------------------->><<07089>>38205000
<< adjust address accordingly to size of directory           >><<07089>>38210000
<<----------------------------------------------------------->><<07089>>38215000
start'addr := direc'size;       << old directory             >><<07089>>38220000
if start'addr > 6112 then                                      <<07089>>38225000
   start'addr := start'addr - 29;                              <<07089>>38230000
end'addr := sectors;            << new directory             >><<07089>>38235000
if end'addr > 6112 then                                        <<07089>>38240000
   end'addr := end'addr - 29;                                  <<07089>>38245000
min := end'addr;                                               <<07089>>38250000
                                                               <<07089>>38255000
if sectors > direc'size then                                   <<07089>>38260000
   << expand directory                                       >><<07089>>38265000
   dsm'setreset (start'addr, end'addr, dealloc);               <<07089>>38270000
dsm'setreset (min, maxsize, alloc);                            <<07089>>38275000
                                                               <<07089>>38280000
<<----------------------------------------------------------->><<07089>>38285000
<< write dir. bit map and if dir. bit map < 32 sectors write >><<07089>>38290000
<< up to 29 sectors of the directory data.                   >><<07089>>38295000
<<----------------------------------------------------------->><<07089>>38300000
address := address + 32d;       << advance dir. address      >><<07089>>38305000
size1 := direc'size;                                           <<07089>>38310000
if direc'size > 6112 then                                      <<07089>>38315000
   <<-------------------------------------------------------->><<07089>>38320000
   << old dir. bit map is 32 sectors long                    >><<07089>>38325000
   <<-------------------------------------------------------->><<07089>>38330000
   if sectors > 6112 then                                      <<07089>>38335000
      <<----------------------------------------------------->><<07089>>38340000
      << new dir. bit map is 32 sectors long  (same size)    >><<07089>>38345000
      <<----------------------------------------------------->><<07089>>38350000
      size1 := size1 - 32       << copy entire bit map       >><<07089>>38355000
   else                                                        <<07089>>38360000
      begin                                                    <<07089>>38365000
      <<----------------------------------------------------->><<07089>>38370000
      << new dir. bit map is 3 sectors long   (squeezed)     >><<07089>>38375000
      <<----------------------------------------------------->><<07089>>38380000
      tos := attachio (sysdisc, 0, 0, @lbuf (384), 0, len-384, <<07089>>38385000
         addr1, addr2, 1);                                     <<07089>>38390000
      ioerrcheck (*, *);                                       <<07089>>38395000
      address := address + 29d; << copy also up to 29 dir.dat>><<07089>>38400000
      size := size - 32 - 29;                                  <<07089>>38405000
      end                                                      <<07089>>38410000
else                                                           <<07089>>38415000
   <<-------------------------------------------------------->><<07089>>38420000
   << old dir. bit map is 3 sectors long                     >><<07089>>38425000
   <<-------------------------------------------------------->><<07089>>38430000
   if sectors > 6112 then                                      <<07089>>38435000
      begin                                                    <<07089>>38440000
      <<----------------------------------------------------->><<07089>>38445000
      << new dir. bit map is 32 sectors long  (expanded)     >><<07089>>38450000
      <<----------------------------------------------------->><<07089>>38455000
      size1 := size1 - 3;                                      <<07089>>38460000
      address := address - 29d;                                <<07089>>38465000
      end                                                      <<07089>>38470000
   else                                                        <<07089>>38475000
      <<----------------------------------------------------->><<07089>>38480000
      << new dir. bit map is 3 sectors long   (same size)    >><<07089>>38485000
      <<----------------------------------------------------->><<07089>>38490000
      size1 := size1 - 32;                                     <<07089>>38495000
                                                               <<07089>>38500000
if logical (size1) > 65000 then                                <<07089>>38505000
   size1 := 0;                    << very small directory    >><<07089>>38510000
                                                               <<07089>>38515000
if sectors > 32 then                                           <<07089>>38520000
   size := sectors - 32                                        <<07089>>38525000
else                                                           <<07089>>38530000
   begin                                                       <<07089>>38535000
   size := 0;                                                  <<07089>>38540000
   len := sectors * 128;                                       <<07089>>38545000
   end;                                                        <<07089>>38550000
                                                               <<07089>>38555000
lbuf := ((sectors + 15) / 16) + 1;                             <<07444>>38560000
if sectors > 6112 then                                         <<07089>>38565000
   lbuf := ((sectors - 29 + 15) / 16) + 1;                     <<07444>>38570000
lbuf (1) := ds'dir'header;                                     <<07089>>38575000
                                                               <<07089>>38580000
<<----------------------------------------------------------->><<07089>>38585000
<< write bit map to tape                                     >><<07089>>38590000
<<----------------------------------------------------------->><<07089>>38595000
bmsize := len;                                                 <<s7529>>38600000
while len >= taperecsize do                                    <<s7529>>38605000
   begin                                                       <<s7529>>38610000
   <<-------------------------------------------------------->><<s7529>>38615000
   << write full block to tape                               >><<s7529>>38620000
   <<-------------------------------------------------------->><<s7529>>38625000
   fwrite (tapefnum, lbuf (bmsize - len), taperecsize, 0);     <<s7529>>38630000
   if <> then                                                  <<s7529>>38635000
      tape'error;                                              <<s7529>>38640000
   len := len - taperecsize;                                   <<s7529>>38645000
   end;                                                        <<s7529>>38650000
                                                               <<s7529>>38655000
if len > 0 then                                                <<s7529>>38660000
   begin                                                       <<s7529>>38665000
   <<-------------------------------------------------------->><<s7529>>38670000
   << write the rest of the buffer as full block             >><<s7529>>38675000
   <<-------------------------------------------------------->><<s7529>>38680000
   move lbuf := lbuf (bmsize - len), (len);                    <<s7529>>38685000
   rsize := taperecsize - len;              << reminder      >><<s7529>>38690000
   <<-------------------------------------------------------->><<s7529>>38695000
   << fill block with data from disc                         >><<s7529>>38700000
   <<-------------------------------------------------------->><<s7529>>38705000
   tos := attachio (sysdisc, 0, 0, @lbuf + len, 0, rsize,      <<s7529>>38710000
      addr1, addr2, 1);                                        <<s7529>>38715000
   ioerrcheck (*, *);                                          <<s7529>>38720000
   address := address + double (rsize &lsr(7));                <<s7529>>38725000
   if size <> 0 then                                           <<s7529>>38730000
      size := size - integer (rsize &lsr(7));                  <<s7529>>38735000
   if size1 <> 0 then                                          <<s7529>>38740000
      size1 := size1 - integer (rsize &lsr(7));                <<s7529>>38745000
   fwrite (tapefnum, lbuf, taperecsize, 0);                    <<s7529>>38750000
   if <> then                                                  <<s7529>>38755000
      tape'error;                                              <<s7529>>38760000
   end;                                                        <<s7529>>38765000
                                                               <<07089>>38770000
<<----------------------------------------------------------->><<07089>>38775000
<< copy rest of the directory                                >><<07089>>38780000
<<----------------------------------------------------------->><<07089>>38785000
                                                               <<07089>>38790000
while size <> 0 do                                             <<07089>>38795000
   begin                                                       <<07089>>38800000
   if size1 <> -1 then                                         <<07089>>38805000
      begin                                                    <<07089>>38810000
      <<----------------------------------------------------->><<07089>>38815000
      << read dir data from disc                             >><<07089>>38820000
      <<----------------------------------------------------->><<07089>>38825000
      len := taperecsize;          << read full block        >><<s7529>>38830000
      if logical (size1) < logical (len &lsr(7)) then          <<s7529>>38835000
         len := size1 * 128;                                   <<07089>>38840000
      tos := attachio (sysdisc, 0, 0, @lbuf, 0, len, addr1,    <<07089>>38845000
         addr2, 1);                                            <<07089>>38850000
      ioerrcheck (*, *);                                       <<07089>>38855000
      if len < taperecsize then                                <<s7529>>38860000
         begin                                                 <<07089>>38865000
         <<-------------------------------------------------->><<07089>>38870000
         << zero the rest of the buffer                      >><<07089>>38875000
         <<-------------------------------------------------->><<07089>>38880000
         lbuf (len) := 0;                                      <<07089>>38885000
         move lbuf (len + 1) := lbuf (len),(taperecsize - len);<<s7529>>38890000
         end;                                                  <<07089>>38895000
                                                               <<07089>>38900000
      if size1 = 0 then                                        <<07089>>38905000
         size1 := -1;              << no more                >><<07089>>38910000
                                                               <<07089>>38915000
      size1 := size1 - len / 128;                              <<07089>>38920000
      end;                                                     <<07089>>38925000
                                                               <<07089>>38930000
   <<-------------------------------------------------------->><<07089>>38935000
   << write data to tape                                     >><<07089>>38940000
   <<-------------------------------------------------------->><<07089>>38945000
   len := taperecsize;                                         <<s7529>>38950000
   if logical (size) < logical (len &lsr(7)) then              <<s7529>>38955000
      len := size * 128;                                       <<07089>>38960000
   fwrite (tapefnum, lbuf, len, 0);                            <<s7529>>38965000
   if <> then                                                  <<s7529>>38970000
      tape'error;                                              <<s7529>>38975000
   address := address + double (taperecsize &lsr(7));          <<s7529>>38980000
   size := size - len / 128;                                   <<07089>>38985000
   end;                                                        <<07089>>38990000
                                                               <<07089>>38995000
end;   << dumpdirc >>                                          <<07089>>39000000
$control segment=dumptape                                      <<07089>>39005000
<<***********************************************************>><<07089>>39010000
<<              calculate directory size                     >><<07089>>39015000
<<***********************************************************>><<07089>>39020000
                                                               <<07089>>39025000
double procedure dirsize (maxsize);                            <<07089>>39030000
   value   maxsize;                                            <<07089>>39035000
   integer maxsize;                                            <<07089>>39040000
   option  privileged, uncallable;                             <<07089>>39045000
                                                               <<07089>>39050000
<<----------------------------------------------------------->><<07089>>39055000
<< this procedure calculates number of used sectors. it      >><<07089>>39060000
<< also determinates the highest address of used sector i.e. >><<07089>>39065000
<< minimum size of the directory occupied by the directory.  >><<07089>>39070000
<< values returned:                                          >><<07089>>39075000
<< dirsize        - number of used sectors,                  >><<07089>>39080000
<< dirsize + 1    - minimum size of directory or max used    >><<07089>>39085000
<<                  sector address - 1.                      >><<07089>>39090000
<<----------------------------------------------------------->><<07089>>39095000
                                                               <<07089>>39100000
begin                                                          <<07089>>39105000
logical used = dirsize;                                        <<07089>>39110000
logical min  = dirsize + 1;                                    <<07089>>39115000
logical tested'word = s - 0;   << work area used for testing >><<07089>>39120000
define  full'used'word = -1#;  << all 16 bits are used       >><<07089>>39125000
                                                               <<07089>>39130000
tos := 0;                << reserved word on stack for test  >><<07089>>39135000
used := min := 0;        << initialize output parameters     >><<07089>>39140000
                                                               <<07089>>39145000
<<----------------------------------------------------------->><<07089>>39150000
<< set system directory address in directory space data seg. >><<07089>>39155000
<<----------------------------------------------------------->><<07089>>39160000
exchangedb (0);                                                <<07089>>39165000
tos := dirdiscadr;                                             <<07089>>39170000
s1.(0:8) := sysdisc;           << set ldev                   >><<07089>>39175000
exchangedb (sys'dds);          << switch to dir. data seg.   >><<07089>>39180000
dirbase := tos;                                                <<07089>>39185000
                                                               <<07089>>39190000
<<----------------------------------------------------------->><<07089>>39195000
<< insure that it is system directory                        >><<07089>>39200000
<<----------------------------------------------------------->><<07089>>39205000
tos := dirallocate (1);  << make sure that it is system dir. >><<07089>>39210000
if = then                      << space allocated - return   >><<07089>>39215000
   dirdeallocate (*, 1)                                        <<07089>>39220000
else                                                           <<07089>>39225000
   del;                                                        <<07089>>39230000
                                                               <<07089>>39235000
<<----------------------------------------------------------->><<07089>>39240000
<< switch to dir. space data seg. and read first sectors     >><<07089>>39245000
<<----------------------------------------------------------->><<07089>>39250000
exchangedb (ds'dst);                                           <<07089>>39255000
ds'req'sector := 1;      << start from the beginnig of bm    >><<07089>>39260000
dirxxxbitmap (0);        << read first sector of the bit map >><<07089>>39265000
                                                               <<07089>>39270000
do                                                             <<07089>>39275000
   <<-------------------------------------------------------->><<07089>>39280000
   << scan the entire directory bit map                      >><<07089>>39285000
   <<-------------------------------------------------------->><<07089>>39290000
   begin                                                       <<07089>>39295000
   while logical (@ds'first'word) <= ds'last'word do           <<07089>>39300000
      <<----------------------------------------------------->><<07089>>39305000
      << scan bit map pages in the buffer                    >><<07089>>39310000
      <<----------------------------------------------------->><<07089>>39315000
      begin                                                    <<07089>>39320000
      if (tested'word := not ds'first'word) <> 0 then          <<07089>>39325000
         <<-------------------------------------------------->><<07089>>39330000
         << extract word and invert bits ( "1" - means used )>><<07089>>39335000
         <<-------------------------------------------------->><<07089>>39340000
         if tested'word = full'used'word and                   <<07089>>39345000
            logical (@ds'first'word) < ds'last'word then       <<07089>>39350000
            begin                                              <<07089>>39355000
            <<----------------------------------------------->><<07089>>39360000
            << full word allocated - 16 sectors              >><<07089>>39365000
            <<----------------------------------------------->><<07089>>39370000
            used := used + 16;                                 <<07089>>39375000
            min := (logical (@ds'first'word) - ds'header -     <<07089>>39380000
               ds'dir'header) &lsl (4) + (ds'cur'sector - 1)   <<07089>>39385000
               &lsl (11) + 16;                                 <<07089>>39390000
            end                                                <<07089>>39395000
         else                                                  <<07089>>39400000
            begin                                              <<07089>>39405000
            <<----------------------------------------------->><<07089>>39410000
            << check which bits are set in the word          >><<07089>>39415000
            <<----------------------------------------------->><<07089>>39420000
            xr := 0;                                           <<07089>>39425000
            while tested'word <> 0 do                          <<07089>>39430000
               begin                                           <<07089>>39435000
               assemble (scan 0, x);  << set bit offset in x >><<07089>>39440000
               if logical (@ds'first'word) = ds'last'word and  <<07089>>39445000
                  ds'last'sector < ds'cur'sector +             <<07089>>39450000
                  ds'buf'size's then                           <<07089>>39455000
                  <<----------------------------------------->><<07089>>39460000
                  << check if it is last word of the bit map >><<07089>>39465000
                  <<----------------------------------------->><<07089>>39470000
                  if (logical (@ds'first'word) - ds'header -   <<07089>>39475000
                     ds'dir'header) &lsl(4) + (ds'cur'sector - <<07089>>39480000
                     1) &lsl (11) + xr <= ds'dir'size then     <<07089>>39485000
                     begin                                     <<07089>>39490000
                     <<-------------------------------------->><<07089>>39495000
                     << valid bit in last word of the bit map>><<07089>>39500000
                     <<-------------------------------------->><<07089>>39505000
                     used := used + 1;                         <<07089>>39510000
                     min := (logical (@ds'first'word) -        <<07089>>39515000
                        ds'header - ds'dir'header) &lsl(4) +   <<07089>>39520000
                        (ds'cur'sector - 1) &lsl(11) + xr;     <<07089>>39525000
                     end                                       <<07089>>39530000
                  else                                         <<07089>>39535000
                     tested'word := 0   << bits beyond bm    >><<07089>>39540000
               else                                            <<07089>>39545000
                  begin                                        <<07089>>39550000
                  <<----------------------------------------->><<07089>>39555000
                  << calculate used space                    >><<07089>>39560000
                  <<----------------------------------------->><<07089>>39565000
                  used := used + 1;                            <<07089>>39570000
                  min := (logical (@ds'first'word) -           <<07089>>39575000
                     ds'header - ds'dir'header) &lsl(4) +      <<07089>>39580000
                     (ds'cur'sector - 1) &lsl(11) + xr;        <<07089>>39585000
                  end;                                         <<07089>>39590000
               end;                                            <<07089>>39595000
            end;                                               <<07089>>39600000
      @ds'first'word := @ds'first'word + 1;    << next word  >><<07089>>39605000
      end;                                                     <<07089>>39610000
   ds'req'sector := ds'req'sector + ds'buf'size's;<< next sec>><<07089>>39615000
   dirxxxbitmap (0);       << read next bit map pages        >><<07089>>39620000
   end                                                         <<07089>>39625000
until <> ;  << finish when end of bit map or io error        >><<07089>>39630000
                                                               <<07089>>39635000
<<----------------------------------------------------------->><<07089>>39640000
<< if dir. bit map = 32 sectors then add 29 sectors          >><<07089>>39645000
<<----------------------------------------------------------->><<07089>>39650000
if ds'dir'size > 6112 then                                     <<07089>>39655000
   begin                                                       <<07089>>39660000
   min := min + 29;                                            <<07089>>39665000
   used := used + 29;                                          <<07089>>39670000
   end;                                                        <<07089>>39675000
                                                               <<07089>>39680000
tos := ds'dir'size;                                            <<07089>>39685000
exchangedb (0);                                                <<07089>>39690000
direc'size := tos;              << directory size            >><<07089>>39695000
if direc'size > 6112 then                                      <<07089>>39700000
   direc'size := direc'size + 29;                              <<07089>>39705000
                                                               <<07089>>39710000
end;  << dirsize >>                                            <<07089>>39715000
$control segment=dumptape                                      <<s7849>>39720000
logical procedure get'tape'info(filenum,max'block,density);    <<s7849>>39725000
   value filenum;                                              <<s7849>>39730000
   integer filenum,max'block,density;                          <<s7849>>39735000
   option privileged,uncallable;                               <<s7849>>39740000
                                                               <<s7849>>39745000
comment                                                        <<s7849>>39750000
                                                               <<s7849>>39755000
   this procedure returns information about tape files which is<<s7849>>39760000
relevant only to those programs/procedures which interface the <<s7849>>39765000
user to the store/restore procedures istore, fstore, irestore, <<s7849>>39770000
& frestore.  the typical caller has opened the store/restore   <<s7849>>39775000
output tape (serial disc) file and is in the process of verify-<<s7849>>39780000
ing the file characteristics specified by the user.  the caller<<s7849>>39785000
must ensure that filenum resides on a magtape drive.  db must  <<s7849>>39790000
be at stack.                                                   <<s7849>>39795000
                                                               <<s7849>>39800000
inputs:                                                        <<s7849>>39805000
   filenum -- the tape file in question.                       <<s7849>>39810000
                                                               <<s7849>>39815000
outputs:                                                       <<s7849>>39820000
   max'block -- the maximum block size the user can legally    <<s7849>>39825000
                specify for this file (function of density).   <<s7849>>39830000
   density   -- the density of the tape file in bpi.           <<s7849>>39835000
   procedure -- true, when no errors.                          <<s7849>>39840000
   return       false, when a file system error occured.       <<s7849>>39845000
                                                               <<s7849>>39850000
called by:  dumptape                                           <<s7849>>39855000
                                                               <<s7849>>39860000
                                                               <<s7849>>39865000
;     << end of comment >>                                     <<s7849>>39870000
                                                               <<s7849>>39875000
begin                                                          <<s7849>>39880000
equate den'option = %56;                                       <<s7849>>39885000
                                                               <<s7849>>39890000
logical                                                        <<s7849>>39895000
   result = get'tape'info;   << procedure return >>            <<s7849>>39900000
                                                               <<s7849>>39905000
                                                               <<s7849>>39910000
   result := false;   << set up return to signal error >>      <<s7849>>39915000
                                                               <<s7849>>39920000
   << determine density of tape >>                             <<s7849>>39925000
   ffileinfo(filenum,den'option,density);                      <<s7849>>39930000
   if <> then return;    << file system error.  return. >>     <<s7849>>39935000
                                                               <<s7849>>39940000
   if density = 0 then                                         <<s7849>>39945000
      density := 1600;   << not a variable density drive. >>   <<s7849>>39950000
                                                               <<s7849>>39955000
   result := true;   << everything ok. >>                      <<s7849>>39960000
                                                               <<s7849>>39965000
   << maximum block size is a function of density. >>          <<s7849>>39970000
   max'block := if density = 1600 then 4096                    <<s7849>>39975000
                                  else 8192;                   <<s7849>>39980000
                                                               <<s7849>>39985000
end;   << of get'tape'info >>                                  <<s7849>>39990000
                                                               <<s7849>>39995000
$control segment=dumptape                                      <<s7849>>40000000
procedure setup'flags(filenum,density,desig,flags,errnum);     <<s7849>>40005000
   value filenum,density;                                      <<s7849>>40010000
   integer filenum,density,errnum;                             <<s7849>>40015000
   byte array desig;                                           <<s7849>>40020000
   logical flags;                                              <<s7849>>40025000
   option privileged,uncallable;                               <<s7849>>40030000
                                                               <<s7849>>40035000
comment                                                        <<s7849>>40040000
                                                               <<s7849>>40045000
   this procedure handles a kludge which is relevant only to   <<s7849>>40050000
those programs/procedures which interface the user to the      <<s7849>>40055000
store/restore procedures fstore & irestore.  (it should be     <<s7849>>40060000
easy to extend this procedure to do any extra work which is    <<s7849>>40065000
common to all these programs/procedures.)                      <<s7849>>40070000
   the calling procedure opens the store/restore tape (serial  <<s7849>>40075000
disc) file with a block size of 4096 words.  however, for 6250 <<s7849>>40080000
bpi tapes which use the attachio algorithm, the default block  <<s7849>>40085000
size is defined to be 8192 words.  (default here means that the<<s7849>>40090000
user has not used a file equation to specify the file's block  <<s7849>>40095000
size.)  in this case, the caller must signal fstore/irestore   <<s7849>>40100000
that the block size returned by fgetinfo (4096 words) should be<<s7849>>40105000
ignored and that the actual block size should be 8192 words.   <<s7849>>40110000
this procedure sets a flag when it detects this situation.     <<s7849>>40115000
                                                               <<s7849>>40120000
inputs:                                                        <<s7849>>40125000
   filenum -- the file in quetion.                             <<s7849>>40130000
   density -- the density of the file in bpi, relevant for     <<s7849>>40135000
              tape files only.                                 <<s7849>>40140000
   desig   -- the formal designator used to open the file.     <<s7849>>40145000
                                                               <<s7849>>40150000
outputs:                                                       <<s7849>>40155000
   flags   -- true when the user has taken the default block   <<s7849>>40160000
              size and attachio will be used with the tape     <<s7849>>40165000
              file.  (if this procedure is ever expanded, each <<s7849>>40170000
              bit in the flags word could have a different     <<s7849>>40175000
              meaning.)                                        <<s7849>>40180000
   errnum  --   0:  no errors occured.                         <<s7849>>40185000
               -1:  a file system error occured.               <<s7849>>40190000
              1,2:  error in xretpmask:  1 = feq entry cannot  <<s7849>>40195000
                    be found, 2 = feq pointer entry points to  <<s7849>>40200000
                    non-existent entry.                        <<s7849>>40205000
                                                               <<s7849>>40210000
called by:  dumptape                                           <<s7849>>40215000
                                                               <<s7849>>40220000
                                                               <<s7849>>40225000
db must be at stack !!                                         <<s7849>>40230000
                                                               <<s7849>>40235000
;    << end of comment >>                                      <<s7849>>40240000
                                                               <<s7849>>40245000
begin                                                          <<s7849>>40250000
define                                                         <<s7849>>40255000
   recsize'flag = ( 1: 1)#,                                    <<s7849>>40260000
   tape'type    = ( 5:11)#,                                    <<s7849>>40265000
   using'attio  = (devtype.tape'type = type7974 or            <<<s7849>>40270000
                    devtype.tape'type = type7976 or            <<s7849>>40275000
                    devtype.tape'type = type7978) and          <<s7849>>40280000
                   vdev = 0 #;  << not a virtual device >>    <<<s7849>>40285000
equate                                                         <<s7849>>40290000
   type7970 = %30,                                             <<s7849>>40295000
   type7974 = %1430,                                           <<s7849>>40300000
   type7976 = %430,                                            <<s7849>>40305000
   type7978 = %1030;                                           <<s7849>>40310000
                                                               <<s7849>>40315000
integer                                                        <<s7849>>40320000
   desig'pos := 0, << start of designator minus leading "*" >> <<s7849>>40325000
   recsize;        << returns from fgetinfo >>                 <<s7849>>40330000
logical                                                        <<s7849>>40335000
   devtype,                                                    <<s7849>>40340000
   vdev,                                                       <<s7849>>40345000
   foptions,                                                   <<s7849>>40350000
   spec'entry := false,                                        <<s7849>>40355000
   masklow,                                                    <<s7849>>40360000
   maskhi;         << 1st and 2nd words of feq option bits >>  <<s7849>>40365000
byte                                                           <<s7849>>40370000
   dummy := " ";   << dummy for xretpmask >>                   <<s7849>>40375000
                                                               <<s7849>>40380000
                                                               <<s7849>>40385000
   << initialization -- no errors/no special case >>           <<s7849>>40390000
   errnum := 0;                                                <<s7849>>40395000
   flags := false;                                             <<s7849>>40400000
                                                               <<s7849>>40405000
   ffileinfo(filenum,2,foptions,                               <<s7849>>40410000
                     4,recsize,                                <<s7849>>40415000
                     5,devtype,                                <<s7849>>40420000
                    51,vdev);                                  <<s7849>>40425000
   if <> then                                                  <<s7849>>40430000
      begin    << file system error >>                         <<s7849>>40435000
      errnum := -1;                                            <<s7849>>40440000
      return;                                                  <<s7849>>40445000
      end;                                                     <<s7849>>40450000
                                                               <<s7849>>40455000
   if using'attio and (density = 6250) and                     <<s7849>>40460000
     (recsize = 4096)  then                                    <<s7849>>40465000
      begin                                                    <<s7849>>40470000
      << possible special case.  check file equation. >>       <<s7849>>40475000
                                                               <<s7849>>40480000
      if desig = "*" then desig'pos := 1;                      <<s7849>>40485000
      errnum := xretpmask(desig(desig'pos),dummy,dummy,        <<s7849>>40490000
                          maskhi,masklow);                     <<s7849>>40495000
                                                               <<s7849>>40500000
      << if no file equation, then either special case or >>   <<s7849>>40505000
      << error.  let caller decide. >>                         <<s7849>>40510000
                                                               <<s7849>>40515000
      if errnum <> 0 then                                      <<s7849>>40520000
         flags := true                                         <<s7849>>40525000
      else                                                     <<s7849>>40530000
         flags := not maskhi.recsize'flag;                     <<s7849>>40535000
      end;                                                     <<s7849>>40540000
                                                               <<s7849>>40545000
end;   << of setup'flags >>                                    <<s7849>>40550000
$control segment=dumptape                                      <<01073>>40555000
                                                                        40560000
          <<--------------------------                                  40565000
            evaluate return from store                                  40570000
          ---------------------------->>                                40575000
  procedure evalreturn(b,a);                                            40580000
    value b,a;                                                          40585000
    integer b,a;                                                        40590000
    option privileged,uncallable;                                       40595000
      begin                                                             40600000
        integer array errnum(3:5)=pb:=m35,m278,m2466;          <<*8393>>40605000
          if a=0 then return;   <<everything ok>>                       40610000
          if a=1 then                                                   40615000
            begin  <<file error>>                                       40620000
              tos := b;                                                 40625000
              if s0=tapefnum then tos:=@tapefile                        40630000
              else if s0=listfnum then tos := @listfile                 40635000
              else if s0=goodfnum then tos := @goodfile                 40640000
              else tos := @errorfile;                                   40645000
              ferror(*,*);                                              40650000
            end;                                                        40655000
          if sirs then                                                  40660000
            begin  <<release sirs>>                                     40665000
              relsir(dirsir,dsir);                                      40670000
              relsir(flabsir,fsir);                                     40675000
              relsir(fmavtsir,fmsir);                          <<00197>>40680000
            end;                                                        40685000
          resetcritical(0);  <<in case in critical mode>>               40690000
          if 3<=a<=5 then                                      <<00134>>40695000
             message(errnum(a))                                <<00134>>40700000
          else                                                 <<00134>>40705000
             genmsg(cimsgset,a);                               <<00134>>40710000
          quit(0);                                                      40715000
      end <<evalreturn>> ;                                              40720000
$control segment=dumptape                                      <<01073>>40725000
procedure ioerrcheck(b,a);                                     <<00.sd>>40730000
value b,a;                                                     <<00.sd>>40735000
integer b,a;                                                   <<00.sd>>40740000
  begin                                                        <<00.sd>>40745000
  tos:=b.(8:8);                                                <<00.sd>>40750000
  if s0<>noerr then                                            <<00.sd>>40755000
    begin                                                      <<00.sd>>40760000
    move fullname:="SERIAL DISC";                              <<00.sd>>40765000
    tos:=-tos;                                                 <<00.sd>>40770000
    ferror(*,fullname);                                        <<00.sd>>40775000
    end;                                                       <<00.sd>>40780000
  del;                                                         <<00.sd>>40785000
  end;                                                         <<00.sd>>40790000
                                                               <<00.sd>>40795000
$page "MAINSEG1 --  INITIALIZATION"                                     40800000
$control segment=inialize                                      <<01073>>40805000
                                                               <<12.km>>40810000
logical procedure changeversion(input,versid);                 <<12.km>>40815000
  value input,versid;                                          <<12.km>>40820000
  byte pointer input,                                          <<12.km>>40825000
               versid;                                         <<12.km>>40830000
begin                                                          <<12.km>>40835000
  comment:                                                     <<12.km>>40840000
    "VERSID" points to the   l a s t   position in the         <<12.km>>40845000
    system version id.                                         <<12.km>>40850000
                                                               <<12.km>>40855000
    we pack successive fields into "VERSID", driven by         <<12.km>>40860000
    "FIELDSIZE".  the complete field must be specified.        <<12.km>>40865000
    fields must be alphanumeric.  any additional input         <<12.km>>40870000
    is flagged as an error.  (we deblank input on left         <<12.km>>40875000
    and right.);                                               <<12.km>>40880000
                                                               <<12.km>>40885000
  label exitinstr;                                             <<12.km>>40890000
  define exitproc= assemble(br *+1,i; con exitinstr) #;        <<12.km>>40895000
                                                               <<12.km>>40900000
  equate dot= ".";                     <<zero in left byte>>   <<12.km>>40905000
  integer array fieldsize(*)=pb:= 2, 2, 1, 32767;              <<12.km>>40910000
  integer array fieldend(*)=pb:= dot, dot, 0, 0;               <<12.km>>40915000
                                                               <<12.km>>40920000
  equate cr= %15;                                              <<12.km>>40925000
  byte pointer string;                                         <<12.km>>40930000
  integer fieldinx:=0,                                         <<12.km>>40935000
          fsize,                                               <<12.km>>40940000
          length;                                              <<12.km>>40945000
                                                               <<12.km>>40950000
  equate badchar=   0,                                         <<12.km>>40955000
         baddelim=  1,                                         <<12.km>>40960000
         extrachar= 2;                                         <<12.km>>40965000
                                                               <<12.km>>40970000
  subroutine verror(errnum); value errnum; integer errnum;     <<12.km>>40975000
  begin                                                        <<12.km>>40980000
    message(m2453);                                            <<*8393>>40985000
    changeversion:=false;                                      <<12.km>>40990000
    exitproc;                                                  <<12.km>>40995000
  end <<subroutine verror>>;                                   <<12.km>>41000000
                                                               <<12.km>>41005000
                                                               <<12.km>>41010000
  scan input while blank,1;            <<deblank input>>       <<12.km>>41015000
  @string:=tos;                                                <<12.km>>41020000
  scan string until cr,1;                                      <<12.km>>41025000
  length:=tos-logical(@string);                                <<12.km>>41030000
  while length>0 and string(length-1)=" " do length:=length-1; <<12.km>>41035000
                                                               <<12.km>>41040000
  while length>=(fsize:=fieldsize(fieldinx)) do                <<12.km>>41045000
    begin                                                      <<12.km>>41050000
    do                                 <<pack field>>          <<12.km>>41055000
      begin                                                    <<12.km>>41060000
      length:=length-1;                                        <<12.km>>41065000
      if (versid:=string(length))=special then verror(badchar);<<12.km>>41070000
      @versid:=@versid(-1);                                    <<12.km>>41075000
      end                                                      <<12.km>>41080000
    until (fsize:=fsize-1)<=0;                                 <<12.km>>41085000
    if fieldsize(fieldinx).(15:1)=1 then                       <<12.km>>41090000
      begin                            <<consume even bytes>>  <<12.km>>41095000
      versid:=" ";                                             <<12.km>>41100000
      @versid:=@versid(-1);                                    <<12.km>>41105000
      end;                                                     <<12.km>>41110000
    if length<>0 and fieldend(fieldinx)<>0 then                <<12.km>>41115000
      begin                            <<skip delimiter>>      <<12.km>>41120000
      length:=length-1;                                        <<12.km>>41125000
      if integer(string(length))<>fieldend(fieldinx)           <<12.km>>41130000
         then verror(baddelim);                                <<12.km>>41135000
      end;                                                     <<12.km>>41140000
    fieldinx:=fieldinx+1;                                      <<12.km>>41145000
    end;                                                       <<12.km>>41150000
  if length<>0 then verror(extrachar);                         <<12.km>>41155000
  changeversion:=true;                                         <<12.km>>41160000
                                                               <<12.km>>41165000
exitinstr:                                                     <<12.km>>41170000
end <<procedure changeversion>>;                               <<12.km>>41175000
                                                               <<12.km>>41180000
                                                               <<12.km>>41185000
$control segment=inialize                                      <<01073>>41190000
        procedure setversion;                                  <<01073>>41195000
        option privileged,uncallable;                          <<01073>>41200000
        begin                                                  <<14.km>>41205000
          version:=comm(version');                             <<07039>>41210000
          updatel:=comm(updatel');                             <<07039>>41215000
          fixlevel:=comm(fixlevel');                           <<07039>>41220000
        end;  << setversion >>                                 <<01073>>41225000
  procedure initialization;                                    <<01073>>41230000
    option privileged,uncallable;                              <<01073>>41235000
      begin                                                    <<01073>>41240000
                                                               <<04327>>41245000
        equate       <<disc cold load info tab offsets>>       <<04327>>41250000
          tabptr = 0,     <<pntr to table info>>               <<04327>>41255000
          ldtxaddr1 = 42, <<offset into tab info to the>>      <<04327>>41260000
          ldtxaddr2 = 43; <<  disc addr of the ldtx    >>      <<04327>>41265000
                                                               <<04327>>41270000
        integer cnt,      <<transfer count used by attachio>>  <<04327>>41275000
                length,                                        <<06763>>41280000
                maxlength,                                     <<06814>>41285000
                addr1,                                         <<04327>>41290000
                addr2;                                         <<04327>>41295000
        integer glarea;  << disp to global rin area >>         <<06814>>41300000
         pointer tempbuf;    << used for moving tables    >>   <<06762>>41305000
                             << from devdata to dsegs     >>   <<06762>>41310000
                                                               <<06762>>41315000
         integer dlsizeneeded;  << actual dl required for >>   <<06762>>41320000
                                << sysdump                >>   <<06762>>41325000
                                                               <<06762>>41330000
                                                               <<04327>>41335000
          push(dl);                                                     41340000
          x := tos-ps0(-1).(4:12);                                      41345000
          db2(x).(0:1) := 1;<<set system manager attribute>>   <<+0.06>>41350000
          <<bit in pcbx>>                                      <<+0.06>>41355000
          who(mode,capability);                                         41360000
          if attrib.(5:1)=0 then                                        41365000
            begin                                                       41370000
            message(m2803);<<user without requied cap. >>      <<*8393>>41375000
comment:                                                       <<+0.06>>41380000
        system manager is required.                            <<+0.06>>41385000
        end of comment;                                        <<+0.06>>41390000
            quit(0);                                                    41395000
            end;                                                        41400000
                                                                        41405000
          <<--------------                                              41410000
            set up files                                                41415000
          -------------->>                                              41420000
comment:                                                       <<+0.06>>41425000
        the command interpreter issues the file equation       <<+0.06>>41430000
        (:file) for the dumptape and the listfile.  this       <<+0.06>>41435000
        section uses the command intrinsic to issue the        <<+0.06>>41440000
        file equation for seglist, the output list file        <<+0.06>>41445000
        for segmenter messages generated during system         <<+0.06>>41450000
        sl changes or lists.                                   <<+0.06>>41455000
        end of comment;                                        <<+0.06>>41460000
                                                               <<04659>>41465000
          fill' (store'files', store'files'len, cr);           <<04659>>41470000
          fill' (dump'date', dump'date'len, " ");              <<04659>>41475000
          x:= 0;                                               <<06763>>41480000
          while x < sysprog'chg'table'limit do                 <<06763>>41485000
             begin                                             <<06763>>41490000
             bspc(x):= 0;                                      <<06763>>41495000
             x:= x+34;                                         <<06763>>41500000
             end;                                              <<06763>>41505000
          listfnum:=                                           <<04107>>41510000
             fopen(listfile,%(2)110001100,%(2)01011000001,-81);<<04107>>41515000
  listerr:if<> then ferror(listfnum,listfile);                          41520000
          fgetinfo(listfnum,filename,foptions,aoptions,recsize,devtype, 41525000
            ldev,,,,,,,,blksize);                                       41530000
          if <> then goto listerr;                                      41535000
          move b := "FILE SEGLIST=",2;                                  41540000
          i := foptions.(10:3);  <<default designator>>                 41545000
          case *i of begin                                              41550000
            begin  <<0: actual designator>>                             41555000
              tos := @filename;                                         41560000
              assemble(dup,dup);                                        41565000
              scan * until %6440,1;  <<get length of file name>>        41570000
              assemble(sub,neg; mvb 2);                                 41575000
              if foptions.(14:2)=1 then move * := ",OLD",2;             41580000
              if foptions.(14:2)=2 then move *:=",OLDTEMP",2;           41585000
              if logical(foptions.(7:1)) then move * := ";CCTL",2       41590000
              else move * := ";NOCCTL",2;                               41595000
              if devtype.rbite > 7 then                                 41600000
                begin  <<not a disc file>>                              41605000
                  move * := ";DEV=",2;                                  41610000
                  tos := 0;                                             41615000
                  tos := ldev;                                          41620000
                  tos := 10;                                            41625000
                  tos := s3;                                            41630000
                  tos := ascii(*,*,*);                                  41635000
                  assemble(add);  <<new buffer ptr>>                    41640000
                end;                                                    41645000
              move * := ";ACC=APPEND;REC=",2;                           41650000
              if blksize<0 then blksize := (-blksize+1)/2;              41655000
              if recsize<0 then l := blksize*(-2)/recsize               41660000
              else l := blksize/recsize;                                41665000
              tos := 0;                                                 41670000
              tos := recsize;                                           41675000
              tos := 10;                                                41680000
              tos := s3;                                                41685000
              tos := ascii(*,*,*);                                      41690000
              assemble(add);                                            41695000
              bps0 := ",";                                              41700000
              tos := tos+1;                                             41705000
              tos := 0;                                                 41710000
              tos := l;                                                 41715000
              tos := 10;                                                41720000
              tos := s3;                                                41725000
              tos := ascii(*,*,*);                                      41730000
assemble(add);                                                 <<02810>>41735000
              bps0 := ",";                                              41740000
              tos := tos+1;                                             41745000
              case * foptions.(8:2) of                                  41750000
                begin  <<record type>>                                  41755000
                  bps0 := "F";                                          41760000
                  bps0 := "V";                                          41765000
                  bps0 := "U";                                          41770000
                end;                                                    41775000
              tos := tos+1;                                             41780000
              if logical(foptions.(13:1)) then move * := ",ASCII",2     41785000
              else move * := ",BINARY",2;                               41790000
            end;                                                        41795000
              move * := "$STDLIST",2;                                   41800000
              move * := "$NEWPASS",2;                                   41805000
              move * := "$OLDPASS",2;                                   41810000
              move * := "$STDIN",2;                                     41815000
              move * := "$STDINX",2;                                    41820000
              move * := "$NULL",2;                                      41825000
            end;                                                        41830000
          bps0 := %15;                                                  41835000
          del;                                                          41840000
          command(b,i,j);                                               41845000
                                                                        41850000
          <<----------------                                            41855000
            set up dl area                                              41860000
          ---------------->>                                            41865000
                                                                        41870000
comment     the dl area is built with the tables which are expected to  41875000
          expand the most closest to dl. 5 tables may expand during the 41880000
          configuration dialogue. their pointers most reside in order   41885000
          in the direct array tableptrs and the increments (or          41890000
          decrements) when moving them are placed in the direct array   41895000
          tableincrs, once again in the order the tables appear in      41900000
          memory. the dl area looks like this:                          41905000
                                                                        41910000
                  dl => --------------------                            41915000
                        -  expansion area  -                            41920000
             blinbuf => --------------------                   <<00778>>41925000
                        -     filename     -                   <<00778>>41930000
                        -      buffer      -                   <<00778>>41935000
               cstab => --------------------                            41940000
                        -        cs        -                            41945000
                        -      table       -                            41950000
              tclass => --------------------                   <<j8606>>41955000
                        -  temp dev class  -                   <<j8606>>41960000
                        -      table       -                   <<t8606>>41965000
            dct'head => --------------------                   <<j8606>>41970000
                        -    header for    -                   <<j8606>>41975000
                        - dev class table  -                   <<j8606>>41980000
               dctab => --------------------                   <<j8606>>41985000
                        -  device class    -                   <<j8606>>41990000
                        -      table       -                            41995000
              tl'buf => --------------------                   <<j8606>>42000000
                        -      table       -                   <<j8606>>42005000
                        -      lookup      -                   <<j8606>>42010000
                vtab => --------------------                            42015000
                        -    volume        -                            42020000
                        -     table        -                            42025000
             oldvtab => --------------------                            42030000
                        -    unchanged     -                            42035000
                        -   volume table   -                            42040000
              lidtab => --------------------                   <<j8606>>42045000
                        -    logging to    -                   <<j8606>>42050000
                        -    table         -                   <<t8393>>42055000
                ctab => --------------------                            42060000
                        - current coresize -                            42065000
                        -  configuration   -                            42070000
                        -    information   -                            42075000
               ctab0 => --------------------                            42080000
                        -   non-coresize   -                            42085000
                        -     related      -                            42090000
                        -  configuration   -                            42095000
                        -    information   -                            42100000
                  db => -------------------- ;                          42105000
                                                                        42110000
          cputype:=thiscpu; <<determine which hp3000 this is>> <<tp.00>>42115000
          date:=calendar;                                      <<00072>>42120000
          time:=clock;                                         <<00072>>42125000
          tos := attachio(sysdisc,0,0,@comm,0,128,0,31,1);     <<07039>>42130000
          ioerrcheck(*,*);                                     <<07039>>42135000
          if multi'imb'sys            <<set max allowable drt>><<m8393>>42140000
                              <<based on cpu type>>            <<03006>>42145000
          then maxdrt := 511  <<expanded 9 bit drt>>           <<03006>>42150000
          else maxdrt := 127; <<orig 7 bit drt>>               <<03006>>42155000
          if seriesii'iii then                                 <<02509>>42160000
             mindrt:=4                                         <<00072>>42165000
          else                                                 <<00072>>42170000
             if postseries3 then                               <<01402>>42175000
                mindrt:=8                                      <<00072>>42180000
             else                                              <<00072>>42185000
                message(m2804);                                <<*8393>>42190000
          ctabfnum := fopen(ctabfile,%(2)10000000001,%(2)110000);       42195000
                                           <<configuration file>>       42200000
          if <> then goto ctaberr;                                      42205000
          devfnum := fopen(devfile,1,%60);                     <<06763>>42210000
deverr:   if <> then ferror( devfnum, devfile);                <<06763>>42215000
          deffnum := fopen(deffile,1,%60);                     <<t8393>>42220000
          if <> then ferror( deffnum, deffile);                <<t8393>>42225000
          dllen := dlsize(-ctabsize-ctab0size);<<room for first<<07039>>42230000
          if <> then                                                    42235000
            begin                                                       42240000
  dlerr:      message(m2466); <<unable to obtain stack space>> <<*8393>>42245000
              quit(0);                                                  42250000
            end;                                                        42255000
          tos := -ctab0size;                                            42260000
          @ctab0 := s0;                                                 42265000
          @ctab := tos-ctabsize;                                        42270000
          fread(ctabfnum,ctab0,ctab0size);                     <<07039>>42275000
ctaberr:  if <> then ferror(ctabfnum,ctabfile);                <<07039>>42280000
          i := ctab0( ctabchecksum);                           <<07039>>42285000
          if i <> checksum( ctab0(1), 127, not(seed)) then     <<07039>>42290000
             begin                                             <<07039>>42295000
             move binbuf := "CHECKSUM ERROR - CONFDATA";       <<07039>>42300000
             print( inbuf, -25, 0);                            <<07039>>42305000
             quit( 1);                                         <<07039>>42310000
             end;                                              <<07039>>42315000
          if ctab0(ctabver) <> ctabcurversion then             <<07039>>42320000
             begin  << old version of confdata file >>         <<07039>>42325000
             move binbuf := "INCOMPATIBLE CONFDATA FILE";      <<07039>>42330000
             print( inbuf, -26, 0);                            <<07039>>42335000
             quit( 1);                                         <<07039>>42340000
             end;                                              <<07039>>42345000
          freaddir(devfnum,devrec0,devrec0size,0d);            <<06763>>42350000
          if <> then goto deverr;                              <<06763>>42355000
          i := devchecksum;                                    <<06763>>42360000
          if i <> checksum( devrec0(1), 127, seed) then        <<06763>>42365000
             begin                                             <<06763>>42370000
             move binbuf := "CHECKSUM ERROR - DEVDATA";        <<06763>>42375000
             print( inbuf, -24, 0);                            <<06763>>42380000
             quit(1);                                          <<06763>>42385000
             end;                                              <<06763>>42390000
          if devversion <> devcurversion then                  <<06763>>42395000
             begin  << old version of devdata file >>          <<06763>>42400000
             move binbuf := "INCOMPATIBLE DEVDATA FILE";       <<06763>>42405000
             print( inbuf, -25, 0);                            <<06763>>42410000
             quit(1);                                          <<06763>>42415000
             end;                                              <<06763>>42420000
          hldev := devhldev;          <<highest logical device <<h8274>>42425000
          comm(hldev') := devhldev;                            <<h8274>>42430000
          comm(cstabsize) := getdevtabsize( devcstabnr);       <<07039>>42435000
          comm(drtnum) := devhdrt;                             <<07039>>42440000
          comm(systapeldev') := 0;  << set by initial >>       <<i8885>>42445000
          nvol := comm(hvol');        <<mvol/hvol>>            <<07039>>42450000
          freaddir(ctabfnum,ctab,ctabsize,d'l(ctabrec)));      <<07039>>42455000
          if <> then goto ctaberr;                                      42460000
          rsir := getsir( rinsir);                             <<06814>>42465000
          mfds( glarea, rindstn, 1, 1);                        <<06814>>42470000
          mfds( grins, rindstn, glarea+1, 1);                  <<06814>>42475000
          rins := glarea/3 -1;                                 <<06814>>42480000
          rinlen := (glarea + grins*12 + 4);                   <<06814>>42485000
          ctab(rins') := rins;                                 <<06814>>42490000
          ctab(grins') := grins;                               <<06814>>42495000
          maxlength := 18560;                                  <<06814>>42500000
          i := -maxlength;                                     <<06814>>42505000
          getdseg( rindseg, i, 0);                             <<06814>>42510000
          if <> then                                           <<06814>>42515000
             begin                                             <<06814>>42520000
             message(3003);                                    <<07091>>42525000
             quit( 1);                                         <<07091>>42530000
             end;                                              <<06814>>42535000
          altdseg( rindseg, rinlen-maxlength, i);              <<06814>>42540000
          if <> then                                           <<06814>>42545000
             begin                                             <<06814>>42550000
             message(3004);                                    <<07091>>42555000
             quit( 1);                                         <<07091>>42560000
             end;                                              <<06814>>42565000
          mds( rindseg, 0, rindstn, 0, rinlen);                <<06814>>42570000
          relsir( rinsir, rsir);                               <<06814>>42575000
          tos := setsysdb;                                              42580000
          tos := dbarray(coldloadcnt);                                  42585000
          tos := s1;                                                    42590000
          resetdb(*);                                                   42595000
          coldloadid := tos;                                            42600000
          del;                                                          42605000
   tos:=0;                                                     <<00506>>42610000
          dirsect := ctab(dirsect');  <<size of directory>>             42615000
   tos:=ctab(nlogprocs)*33+33;  <<size of lidtab>>             <<00506>>42620000
   lidtablen:=s0;                                              <<00506>>42625000
   tos:=-tos+@ctab;                                            <<00506>>42630000
   @lidtab:=s0;                                                <<00506>>42635000
          rins := ctab(rins');        <<# of rins>>                     42640000
          grins := ctab(grins');      <<# of global rins>>              42645000
                                                               <<00506>>42650000
          tos := (mvol+1)*vtabsize;  <<size of volume table>>  <<rh.pv>>42655000
          assemble(neg,dup; cab,add; dup);                              42660000
          @oldvtab := tos;<<ptr to unchanged copy of volume table>>     42665000
          assemble(add,dup);                                            42670000
          @vtab := tos;   <<ptr to volume table>>                       42675000
          @tl'buf := s0;                                       <<t8393>>42680000
          tos := tos - getdevtabsize( devttdtnr);              <<*7657>>42685000
          @tdtab := s0;                                        <<*7657>>42690000
          tos := tos - getdevtabsize( devclassnr);             <<*7657>>42695000
          @dctab := s0;                                        <<06763>>42700000
          tos := tos - size'of'dct'head;                       <<*7657>>42705000
          @dct'head := s0;                                     <<06763>>42710000
          tos := tos - 2; << temp class is 2 words long     >> <<06812>>42715000
          @tclass := s0;                                       <<06812>>42720000
          tos := tos-comm(cstabsize);                          <<07039>>42725000
          @cstab := s0;                                                 42730000
          @blinbuf:=s0&lsl(1);<<byte ptr to file name buffer>> <<03704>>42735000
                                                               <<06762>>42740000
           <<**************************>>                      <<06762>>42745000
      comment                                                  <<06762>>42750000
           we will now allocate some extra dl space for        <<06762>>42755000
           temporay storage of the i/o tables while reading    <<06762>>42760000
           them from devdata and into their dsegs.  note       <<06762>>42765000
           that this area is sucked back in after the dsegs    <<06762>>42770000
           are filled in.                                      <<06762>>42775000
      ;                                                        <<06762>>42780000
           <<**************************>>                      <<06762>>42785000
                                                               <<06762>>42790000
           dlsizeneeded := s0;                                 <<06762>>42795000
           tos := tos - (maxldev * dvrsize);                   <<06762>>42800000
           @tempbuf := s0;                                     <<06762>>42805000
          dllen := dlsize(*);  <<get space for rest of tables>>         42810000
          if <> then goto dlerr;                                        42815000
                                                               <<06762>>42820000
          <<--------------------------->>                      <<06762>>42825000
          << allocate dsegs for tables >>                      <<06762>>42830000
          <<--------------------------->>                      <<06762>>42835000
                                                               <<06762>>42840000
          tempbuf(0) := 0;                                     <<06762>>42845000
          move tempbuf(1) := tempbuf, (maxldev * dvrsize);     <<06762>>42850000
             << dvrsize is the largest entry size >>           <<06762>>42855000
             << we will now use tempbuf to        >>           <<06762>>42860000
             << initialize the table dsegs        >>           <<06762>>42865000
                                                               <<06762>>42870000
          cnt := -(maxldev*ldtsize);                           <<07387>>42875000
          getdseg( ldt'dst'index, cnt, 0);                     <<06762>>42880000
          if <> then purgetempsl;                              <<06762>>42885000
          mtds(ldt'dst'index,0,tempbuf,cnt);                   <<06762>>42890000
                                                               <<06762>>42895000
          cnt := -(lpdtsize*maxldev);                          <<07387>>42900000
          getdseg( lpdt'dst'index, cnt, 0);                    <<06762>>42905000
          if <> then purgetempsl;                              <<06762>>42910000
          mtds(lpdt'dst'index,0,tempbuf,cnt);                  <<06762>>42915000
                                                               <<06762>>42920000
          cnt := -(maxldev*ldtxsize);                          <<07387>>42925000
          getdseg( ldtx'dst'index, cnt, 0);                    <<06762>>42930000
          if <> then purgetempsl;                              <<06762>>42935000
          mtds(ldtx'dst'index,0,tempbuf,cnt);                  <<06762>>42940000
                                                               <<06762>>42945000
          cnt := -(maxldev*dvrsize);                           <<07387>>42950000
          getdseg( dvrtab'dst'index, cnt, 0);                  <<06762>>42955000
          if <> then purgetempsl;                              <<06762>>42960000
          mtds(dvrtab'dst'index,0,tempbuf,cnt);                <<06762>>42965000
                                                               <<06762>>42970000
                                                                        42975000
          <<--------------------------                                  42980000
            move tables into dl area                                    42985000
          -------------------------->>                                  42990000
          mfds( lidtab, liddst, 0, lidtablen);                 <<06763>>42995000
          i := (mvol+1) * vtabsize;                            <<06763>>43000000
          mfds( oldvtab, vtabdstn, 0, i);                      <<06763>>43005000
          mfds( vtab, vtabdstn, 0, i);<<copy to be changed>>   <<06763>>43010000
                                                               <<06762>>43015000
          readdevfile( devldtnr, tempbuf, length);             <<06763>>43020000
          mtds( ldt'dst'index, 0, tempbuf, length);            <<06763>>43025000
                                                               <<06762>>43030000
          readdevfile( devclassnr, dctab, length);             <<06763>>43035000
          readdevfile( devlpdtnr, tempbuf, length);            <<06763>>43040000
          mtds( lpdt'dst'index, 0, tempbuf, length);           <<06763>>43045000
          readdevfile( devcstabnr, cstab, length);             <<06763>>43050000
          readdevfile( devhdrnr, dct'head, length);            <<06763>>43055000
          readdevfile( devttdtnr, tdtab, length);              <<*7657>>43060000
          readdevfile( devldtxnr, tempbuf, length);            <<06763>>43065000
          mtds( ldtx'dst'index, 0, tempbuf, length);           <<06763>>43070000
          readdevfile( devdvrnr, tempbuf, length);             <<06763>>43075000
          mtds( dvrtab'dst'index, 0, tempbuf, length);         <<06763>>43080000
          readdevfile( devcsdefnr, csdef, length);             <<06763>>43085000
          readdevfile( devcsdvrnr, csdvr, length);             <<06763>>43090000
                                                               <<06763>>43095000
          tclass := 0;  << no entries yet  >>                  <<06812>>43100000
          tclass(1) := 2; << header is 2 words >>              <<06812>>43105000
                                                               <<06812>>43110000
                                                               <<06763>>43115000
          @tl'head := @defrec0;                                <<t8393>>43120000
          freaddir(deffnum,defrec0,defrec0size,0d);            <<t8393>>43125000
          if <> then ferror(deffnum,deffile);                  <<t8393>>43130000
          i := tlh'checksum;                                   <<t8393>>43135000
          if i <> checksum( defrec0(1), 127, seed) then        <<t8393>>43140000
             begin                                             <<t8393>>43145000
             move binbuf := "CHECKSUM ERROR - DEFDATA";        <<t8393>>43150000
             print( inbuf, -24, 0);                            <<t8393>>43155000
             quit(1);                                          <<t8393>>43160000
             end;                                              <<t8393>>43165000
          if tlh'version <> defcurversion then                 <<t8393>>43170000
             begin  << old version of defdata file >>          <<t8393>>43175000
             move binbuf := "INCOMPATIBLE DEFDATA FILE";       <<t8393>>43180000
             print( inbuf, -25, 0);                            <<t8393>>43185000
             quit(1);                                          <<t8393>>43190000
             end;                                              <<t8393>>43195000
          << read in defdata file >>                           <<t8393>>43200000
          tl'incr := tlh'table'size;                           <<t8393>>43205000
          movedltables;                                        <<t8393>>43210000
          @tl'ent := @tl'buf;                                  <<t8393>>43215000
          freaddir(deffnum,tl'ent,tlh'table'size,1d);          <<t8393>>43220000
          if <> then ferror(deffnum,deffile);                  <<t8393>>43225000
          fgetinfo( devfnum, b); <<get real file name>>        <<06763>>43230000
          if b <> devfile,(16) then                            <<06763>>43235000
             begin << redirected with file equation>>          <<06763>>43240000
             move filename := "DEVDATA ";                      <<06763>>43245000
             add'to'sysprog'chg'table( filename, b);           <<06763>>43250000
             end;                                              <<06763>>43255000
          fclose( devfnum, 0, 0);                              <<06763>>43260000
          if <> then go deverr;                                <<06763>>43265000
                                                               <<06763>>43270000
          fgetinfo( deffnum, b); <<get real file name>>        <<t8393>>43275000
          if b <> deffile,(16) then                            <<t8393>>43280000
             begin << redirected with file equation>>          <<t8393>>43285000
             move filename := "DEFDATA ";                      <<t8393>>43290000
             add'to'sysprog'chg'table( filename, b);           <<t8393>>43295000
             end;                                              <<t8393>>43300000
          fclose( deffnum, 0, 0);                              <<t8393>>43305000
          if <> then ferror(deffnum,deffile);                  <<t8393>>43310000
          tos := comm(cstabsize);                              <<07039>>43315000
                                                               <<t8393>>43320000
          dlsizeneeded := dlsizeneeded - tlh'table'size;       <<t8393>>43325000
                                                               <<t8393>>43330000
          cstab := comm(cstabsize);<<update size of table>>    <<07039>>43335000
          dllen := dlsize(dlsizeneeded);                       <<06762>>43340000
          if <> then goto dlerr;                               <<06762>>43345000
          ldt'index := 0;                                      <<06762>>43350000
          lpdt'index := 0;                                     <<06762>>43355000
          ldtx'index := 0;                                     <<06762>>43360000
          dvr'index := 0;                                      <<06762>>43365000
          get'ldev'entries(0);                                 <<06762>>43370000
          lpdt'serv'req'count := 0;                            <<06762>>43375000
          put'ldev'entries(0);                                 <<06762>>43380000
          i:=1;                                                <<01.00>>43385000
          do                                                   <<01.00>>43390000
            begin <<clean up logical-physical device table>>   <<01.00>>43395000
            get'ldev'entries(i);                               <<06762>>43400000
            if not ldev'exists(i) then                         <<03544>>43405000
                                                               <<03544>>43410000
              begin <<device does not exist>>                  <<01.00>>43415000
              lpdt(lpdt'index):=0;                             <<06762>>43420000
              lpdt(x:=x+1):=0;                                 <<01.00>>43425000
              end                                              <<01.00>>43430000
            else                                               <<01.00>>43435000
              begin <<device exists>>                          <<01.00>>43440000
              tos:=lpdt(lpdt'index+1);                         <<06762>>43445000
              if logical(lpdt'non'sys'domain) and              <<06762>>43450000
                 ldt'access'type = ldt'direct'access then      <<06762>>43455000
                tos := tos land %30017   <<clear non-sys dev>> <<rh.pv>>43460000
              else                                             <<rh.pv>>43465000
                tos := tos land %33017;  <<clear>>             <<rh.pv>>43470000
              <<non-configuration bits>>                       <<01.00>>43475000
              lpdt(lpdt'index+1) := tos;                       <<06762>>43480000
              lpdt'vdev'direction := 0;                        <<06762>>43485000
              lpdt'dit'ptr := 0;                               <<06762>>43490000
              end;                                             <<01.00>>43495000
            put'ldev'entries(i);                               <<06762>>43500000
            end <<clean up>>                                   <<01.00>>43505000
          until (i:=i+1) > hldev;                              <<01.00>>43510000
          i := 1;                                                       43515000
          do                                                            43520000
            begin  <<clean up logical device table and ldtx>>  <<00134>>43525000
              get'ldev'entries(i);                             <<06762>>43530000
              if not ldev'exists(i) then                       <<03544>>43535000
                                                               <<03544>>43540000
                begin                                                   43545000
                ldt(ldt'index) := 0;                           <<06762>>43550000
                tos := @ldt(x)+1;                                       43555000
                move *:=ldt(x),(ldtsize-1);                    <<00134>>43560000
                ldtx(ldtx'index):=0;                           <<06762>>43565000
                tos:=@ldtx(x)+1;                               <<00134>>43570000
                move *:=ldtx(x),(ldtxsize-1);                  <<00134>>43575000
                end                                                     43580000
              else                                                      43585000
                begin                                                   43590000
                ldt'file'use'cnt := 0;                         <<06762>>43595000
                ldt'control'y'pin := 0;                        <<06762>>43600000
                ldt'volume'tbl'index := 0;                     <<06762>>43605000
                ldt'special'forms := 0;                        <<06762>>43610000
                ldt'avail'to'sys := 1;                         <<06762>>43615000
                ldt'header := 0;                               <<06762>>43620000
                ldt'avail'to'diag := 0;                        <<06762>>43625000
                ldt'trailer := 0;                              <<06762>>43630000
                ldt'down'pending := 0;                         <<06762>>43635000
                if ldt'spool'state = ldt'output'spooled then   <<06762>>43640000
                  ldt'spool'queues := ldt'qopen;               <<06762>>43645000
                <<set the offset into the ttdt (ldtx wd. 1) >> <<06068>>43650000
                <<to -1 for terms if this is the first time >> <<06068>>43655000
                if ldt'device'type = ldt'terminal or           <<06762>>43660000
                   ldt'device'type = ldt'printer and           <<06762>>43665000
                   (lpdt'subtype = 14 or                       <<06762>>43670000
                   lpdt'subtype = 15) then                     <<06762>>43675000
                else  <<not a term>>                           <<06068>>43680000
                  ldtx'sdisc'gpt'xds :=0; <<clear dst for>>    <<06762>>43685000
                                           <<allocated sdisc>> <<06068>>43690000
                end;                                                    43695000
            put'ldev'entries(i);                               <<06762>>43700000
            end                                                <<06762>>43705000
          until (i:=i+1) > hldev;                                       43710000
          compactrin;                                                   43715000
          setversion;                                          <<14.km>>43720000
      end;                                                     <<01073>>43725000
$page "             INITIALIZE SYSDUMP CHANGES"                <<01073>>43730000
$control segment=inialize                                      <<01073>>43735000
  procedure initialize'ch;                                     <<01073>>43740000
  option privileged,uncallable;                                <<01073>>43745000
  begin                                                        <<01073>>43750000
          do                                                   <<12.km>>43755000
            begin                                              <<12.km>>43760000
            setversion;                                        <<14.km>>43765000
          if seriesii'iii then                                 <<02509>>43770000
            move binbuf:="SYSTEM ID = HP32002",2               <<00072>>43775000
          else                                                 <<00072>>43780000
            if cputype=lc3000 or cputype=icf44 or              <<03761>>43785000
              cputype=icf55 or cputype=series'37 then          <<m8393>>43790000
              move binbuf:="SYSTEM ID = HP32033",2             <<03761>>43795000
            else                                               <<03761>>43800000
              message (m2804);                                 <<*8393>>43805000
            bps0:=bversion;   tos:=tos+logical(1);             <<12.km>>43810000
            bps0:=".";        tos:=tos+logical(1);             <<12.km>>43815000
            move * := bupdatel,(2),2;                          <<12.km>>43820000
            bps0:=".";        tos:=tos+logical(1);             <<12.km>>43825000
            move * := bfixlevel,(2),2;                         <<12.km>>43830000
            move * := ".?";                                    <<12.km>>43835000
            print(inbuf,14,%320);                              <<12.km>>43840000
            readinput;                                         <<12.km>>43845000
            end                                                <<12.km>>43850000
          until changeversion(inbuf,bversid'end);              <<12.km>>43855000
  reqcore:temp := ctab0(coresize);                                      43860000
          getnewval(m2007,temp,256,4096);  <<memory size = xxxx<<s8940>>43865000
          x := 0;                                                       43870000
          do if coresizes(x)=temp then goto coreok   <<valid size>>     43875000
          until (x:=x+1) = ncoresizes;                                  43880000
        <<invalid core size specified>>                                 43885000
          message(m2453);                                      <<*8393>>43890000
          go reqcore;                                                   43895000
        <<valid core size>>                                             43900000
coreok:                                                        <<07039>>43905000
          ctab0(coresize) := temp;                                      43910000
  end;                                                         <<01073>>43915000
$page "             I/O CONFIGURATION CHANGES"                 <<01073>>43920000
$control segment=iochange                                      <<01073>>43925000
  procedure io'config'ch;                                      <<01073>>43930000
  option privileged,uncallable;                                <<01073>>43935000
  begin                                                        <<01073>>43940000
        byte array e1(0:15)=pb:="UNDEFINED CLASS ";            <<01073>>43945000
        byte array e2(0:41)=pb:="USED AS OUTPUT DEVICE BY",    <<01073>>43950000
                                " FOLLOWING DEVICES";          <<01073>>43955000
        integer    << one line at a time, alphabetical order >><<t8393>>43960000
                bindx,                                         <<t8393>>43965000
                csindx,                                        <<t8393>>43970000
                idinx,                                         <<t8393>>43975000
                lastpollent,                                   <<t8393>>43980000
                new'ldev,                                      <<t8393>>43985000
                phinx = bindx,                                 <<t8393>>43990000
                speedcde,                                      <<t8393>>43995000
                tspeed,                                        <<t8767>>44000000
                subtyp,                                        <<t8393>>44005000
                type,                                          <<t8393>>44010000
                unit,                                          <<t8393>>44015000
                initspool,                                     <<t8393>>44020000
                val;                                           <<t8393>>44025000
        byte pointer                                           <<t8393>>44030000
                bcsldtx,                                       <<t8393>>44035000
                idlist,                                        <<t8393>>44040000
                phone = bcsldtx;                               <<t8393>>44045000
integer name'ptr;                                              <<t8393>>44050000
        equate cmax = 1000 , sdisc = 31, fdisc = 7;            <<01115>>44055000
        byte array btemp(0:81);                                <<01073>>44060000
        byte array dev'name(0:15);                             <<t8393>>44065000
        array tempcsldtx(0:500);                               <<03616>>44070000
        logical warn,                                          <<t8393>>44075000
                dsdevice,                                      <<t8393>>44080000
                term'defaults := false,                        <<d8821>>44085000
                default'chosen;                                <<d8821>>44090000
                                                               <<06068>>44095000
        integer array messbuf(0:35);     <<used to print>>     <<06068>>44100000
        byte array bmess(*) = messbuf;      <<messages>>       <<06068>>44105000
        byte pointer pout;                                     <<06068>>44110000
                                                               <<06068>>44115000
        byte array file (0:7),     <<filename>>                <<06068>>44120000
                   group(0:7),     <<group name>>              <<06068>>44125000
                   acct (0:7);     <<account name>>            <<06068>>44130000
                                                               <<06068>>44135000
        integer bindex,     <<points to # ldevs in ent>>       <<06068>>44140000
                bttdtsize:=0,<<size in bytes>>                 <<06068>>44145000
                cnt:=0,     <<# words to move>>                <<06068>>44150000
                fqfnsize:=0,<<fully qualified filename size>>  <<06068>>44155000
                fsize:=0,   <<file part of filename>>          <<06068>>44160000
                gsize:=0,   <<group part of filename>>         <<06068>>44165000
                asize:=0,   <<acct part of filename>>          <<06068>>44170000
                termtype,                                      <<06068>>44175000
                len,                                           <<06068>>44180000
                insize,                                        <<06068>>44185000
                termcntl;  <<terminating control>>             <<06068>>44190000
        pointer                                                <<06762>>44195000
                dest,      << points to destination of move  >><<06762>>44200000
                source;    << points to source of move       >><<06762>>44205000
                                                               <<06762>>44210000
        integer                                                <<06762>>44215000
                count;     << number of words to move        >><<06762>>44220000
        double pointer                                         <<06813>>44225000
                dblptr;                                        <<06813>>44230000
                                                               <<04327>>44235000
        << subroutine to zero the ldtx entry for a given ldev>><<04327>>44240000
                                                               <<04327>>44245000
        subroutine zeroldtx;                                   <<04327>>44250000
          begin                                                <<04327>>44255000
          tos := @ldtx(ldtx'index);                            <<06762>>44260000
          ps0 := 0;                                            <<04327>>44265000
          assemble (dup,incb);                                 <<04327>>44270000
          tos := ldtxsize-1;                                   <<04327>>44275000
          assemble (move 3);                                   <<04327>>44280000
          end;                                                 <<04327>>44285000
                                                               <<04327>>44290000
                                                               <<06068>>44295000
        << subroutine to fully qualify a filename >>           <<06068>>44300000
                                                               <<06068>>44305000
        logical subroutine fully'qualify;                      <<06068>>44310000
          begin                                                <<06068>>44315000
          <<returns true if a valid filename was input.>>      <<06068>>44320000
          <<file, group, and acct contain the fully    >>      <<06068>>44325000
          <<fully qualified filename upon exiting.     >>      <<06068>>44330000
          move file  := "        ";                            <<06068>>44335000
          move group := "        ";                            <<06068>>44340000
          move acct  := "        ";                            <<06068>>44345000
          fqfname := " ";                                      <<06068>>44350000
          move fqfname(1):=fqfname,(25);  <<blank>>            <<06068>>44355000
          if bpinbuf = alpha then                              <<06068>>44360000
            begin                                              <<06068>>44365000
            if insize > 26 then                                <<06068>>44370000
              goto ttferrs;                                    <<06068>>44375000
            fully'qualify := true;                             <<06068>>44380000
            fqfnsize:=getstr(@done,fqfname,termcntl,".",       <<06068>>44385000
                                              insize);         <<06068>>44390000
            if < then                                          <<06068>>44395000
              if termcntl=1 then                               <<06068>>44400000
                goto ttferrs;  <<comma follows input>>         <<06068>>44405000
            move file := fqfname while ans,1;                  <<06068>>44410000
            fsize := tos-@file; <<size of name in file>>       <<06068>>44415000
            if not (1 <= fsize <= 8) then goto ttferrs;        <<06068>>44420000
            bindex := fsize; <<intermediate size>>             <<06068>>44425000
            if bindex < fqfnsize then goto gname               <<06068>>44430000
            else                                               <<06068>>44435000
              begin                                            <<06068>>44440000
              move group := "PUB     ";                        <<06068>>44445000
              move acct  := "SYS     ";                        <<06068>>44450000
              return; <<done>>                                 <<06068>>44455000
              end;                                             <<06068>>44460000
gname:      bindex := bindex + 1;   <<skip the ".">>           <<06068>>44465000
            if fqfname(bindex) <> alpha then                   <<06068>>44470000
              goto ttferrs;                                    <<06068>>44475000
            move group  := fqfname(bindex) while ans,1;        <<06068>>44480000
            gsize := tos - @group;                             <<06068>>44485000
            if not (1 <= gsize <= 8) then goto ttferr;         <<06068>>44490000
            bindex := bindex + gsize;                          <<06068>>44495000
            if bindex < fqfnsize then goto aname               <<06068>>44500000
            else                                               <<06068>>44505000
              begin                                            <<06068>>44510000
              move acct := "SYS     ";                         <<06068>>44515000
              return;                                          <<06068>>44520000
              end;                                             <<06068>>44525000
aname:            bindex := bindex + 1;   <<skip the ".">>     <<06068>>44530000
            if fqfname(bindex) <> alpha then                   <<06068>>44535000
              goto ttferrs;                                    <<06068>>44540000
            move acct := fqfname(bindex) while ans,1;          <<06068>>44545000
            asize := tos - @acct;                              <<06068>>44550000
            if (fsize+gsize+asize+2) <> fqfnsize then          <<06068>>44555000
              goto ttferrs;                                    <<06068>>44560000
            if not (1 <= asize <= 8) then goto ttferrs;        <<06068>>44565000
            << pad with blanks >>                              <<06068>>44570000
            while fsize < 8 do                                 <<06068>>44575000
              begin                                            <<06068>>44580000
              file(fsize) := " ";                              <<06068>>44585000
              fsize := fsize + 1;                              <<06068>>44590000
              end;                                             <<06068>>44595000
            while gsize < 8 do                                 <<06068>>44600000
              begin                                            <<06068>>44605000
              group(gsize) := " ";                             <<06068>>44610000
              gsize := gsize + 1;                              <<06068>>44615000
              end;                                             <<06068>>44620000
            while asize < 8 do                                 <<06068>>44625000
              begin                                            <<06068>>44630000
              acct(asize) := " ";                              <<06068>>44635000
              asize := asize + 1;                              <<06068>>44640000
              end;                                             <<06068>>44645000
            end  <<alpha>>                                     <<06068>>44650000
          else   <<not alpha>>                                 <<06068>>44655000
            begin                                              <<06068>>44660000
ttferrs:    message(01);   <<illegal input>>                   <<06068>>44665000
done:       fully'qualify := false;                            <<06068>>44670000
            end;                                               <<06068>>44675000
          end;  <<subroutine fully'qualify>>                   <<06068>>44680000
                                                               <<s8966>>44685000
     subroutine inoutspool;                                    <<s8966>>44690000
        begin                                                  <<s8966>>44695000
                                                               <<s8966>>44700000
        if 8<=ldt'device'type<=15 then                         <<s8966>>44705000
   inonly:  ldt'spool'state := 1                               <<s8966>>44710000
          else if 32<=ldt'device'type<=39 then                 <<s8966>>44715000
                 begin                                         <<s8966>>44720000
   outonly:      ldt'spool'state := 2;                         <<s8966>>44725000
                 ldt'spool'queues := 1;                        <<s8966>>44730000
                 end                                           <<s8966>>44735000
               else if 16<=ldt'device'type<=31 then            <<s8966>>44740000
                      begin                                    <<s8966>>44745000
   askagain:          message(-m2308);<<spool in or out>>      <<s8966>>44750000
                      readinput;                               <<s8966>>44755000
                      move binbuf:=binbuf while ans;           <<s8966>>44760000
                      if binbuf="IN" then go inonly            <<s8966>>44765000
                        else if binbuf="OUT" then go outonly;  <<s8966>>44770000
                      message(m2453);                          <<s8966>>44775000
                      go askagain;                             <<s8966>>44780000
                      end;                                     <<s8966>>44785000
       end;  << subroutine inoutspool >>                       <<s8966>>44790000
                                                               <<s8966>>44795000
          if yesanswer(m2009) then listiodev; <<list i/0 device<<*8393>>44800000
          if cspresent then                                    <<01073>>44805000
           if yesanswer(m2100) then listcsdev;                 <<*8393>>44810000
          if yesanswer(m2043) then list'defaults;              <<t8393>>44815000
          getnewval(m2010,comm(drtnum),mindrt,maxdrt);         <<m8928>>44820000
             <<note: allow drt up to 511 in case user is>>     <<03006>>44825000
             <<configuring a system for use on cpu which>>     <<03006>>44830000
             <<supports extended 9bit drt>>                    <<03006>>44835000
             <<checkdev will give warning later if this cpu>>  <<03006>>44840000
             <<won't support large drt>>                       <<03006>>44845000
  reqldev:ldev := getval(m2011,0,999,2);  <<logical device #?>><<*8393>>44850000
          if ldev=0 then go reqvdev;                                    44855000
          dev'defaults := false;                               <<t8393>>44860000
          term'defaults := false;                              <<t8393>>44865000
  reqname:message(-m2041); << default device name >>           <<t8393>>44870000
          readinput;                                           <<t8393>>44875000
          tos := getstr(@reqname,dev'name,3,0,16);             <<t8393>>44880000
          if tos > 0 then                                      <<t8393>>44885000
             if name'found(dev'name) then                      <<t8393>>44890000
                dev'defaults := true                           <<t8393>>44895000
             else                                              <<t8393>>44900000
                begin                                          <<t8393>>44905000
                message(m2052);                                <<t8393>>44910000
                go reqname;                                    <<t8393>>44915000
                end;                                           <<t8393>>44920000
                                                               <<t8393>>44925000
  reqdrtn:dsdevice := false;                                            44930000
          message(-m2012);   <<drtn?>>                         <<*8393>>44935000
          readinput;                                                    44940000
          scan bpinbuf while blank,1; <<delete leading blanks>>         44945000
          if bps0="#" then                                              44950000
            begin  <<ds device>>                                        44955000
            dsdevice := true;                                           44960000
            @bpinbuf := tos+1;                                          44965000
            drtn := inval(@reqdrtn,",");                                44970000
            if < then                                                   44975000
              begin <<not followed by cr>>                              44980000
              message(m2453);                                  <<*8393>>44985000
              go reqdrtn;                                               44990000
              end;                                                      44995000
            if not non'ds'ldev(drtn)                           <<03726>>45000000
            then                                               <<03006>>45005000
              begin <<ds device linked to ds or non existing device>>   45010000
              message(m114);                                   <<*8393>>45015000
              go reqdrtn;                                               45020000
              end;                                                      45025000
            end                                                         45030000
          else                                                          45035000
            begin <<real device>>                                       45040000
            drtn := inval(@reqdrtn,",");                                45045000
            if <= or (1 <= drtn <= mindrt-1) or                <<03023>>45050000
            (drtn < 0) or (drtn > 511) then                    <<03023>>45055000
              begin                                            <<03023>>45060000
              message(m2453);                                  <<*8393>>45065000
              go reqdrtn;                                               45070000
              end;                                                      45075000
            end;                                                        45080000
          if ldev'exists(ldev) then                            <<03703>>45085000
            begin   <<old ldev exists>>                        <<03703>>45090000
              << remove ttdt entry if ldev is a terminal >>    <<06068>>45095000
              if ldt'device'type = ldt'terminal or             <<06762>>45100000
                 ldt'device'type = ldt'printer and             <<06762>>45105000
                 (lpdt'subtype = 14 or                         <<06762>>45110000
                 lpdt'subtype = 15) then                       <<06762>>45115000
                 removettdtrefs(ldev);                         <<*7657>>45120000
             type := ldt'device'type;                          <<*8393>>45125000
              zerobuf( dvrtab, dvrsize );                      <<06762>>45130000
              zerobuf( lpdt, lpdtsize );                       <<06762>>45135000
              zerobuf( ldt, ldtsize );                         <<06762>>45140000
              zerobuf( ldtx, ldtxsize );                       <<06762>>45145000
              put'ldev'entries(ldev);                          <<06762>>45150000
  killcsdev:   if csdev17<=type<=csdev19 then                  <<01165>>45155000
               begin<<delete csldtx entry>>                    <<+0.06>>45160000
               cstab(x):=cstab(csxentries)-1;<<one less>>      <<+0.06>>45165000
               <<cs device in table>>                          <<+0.06>>45170000
               tos:=csdef(ldev);<<csldtx entry # for device>>  <<+0.06>>45175000
               <<to be deleted>>                               <<+0.06>>45180000
               csdef(x):=0;<<this device is no longer in>>     <<+0.06>>45185000
               <<csldtx table>>                                <<+0.06>>45190000
               x := 0;                                                  45195000
                do  <<scan entire cs-device index table>>      <<+0.06>>45200000
                  if s0<=csdef(x) then <<any device with a>>   <<+0.06>>45205000
                    csdef(x):=csdef(x)-1 <<csldtx index #>>    <<+0.06>>45210000
                until (x:=x+1)=csdefsize;<<greater than the>>  <<+0.06>>45215000
                <<one to be deleted should have its index>>    <<+0.06>>45220000
                <<decremented by one to reflect the new>>      <<+0.06>>45225000
                <<shorter table>>                              <<+0.06>>45230000
               temp := tos;                                             45235000
                @csldtx:=@cstab+csxstart;<<reset csldtx to>>   <<+0.06>>45240000
                <<start of table holding entries>>             <<+0.06>>45245000
               i := -1;                                                 45250000
               while (i:=i+1) < temp do                                 45255000
                  @csldtx:=csldtx+@csldtx;<<set to start>>     <<+0.06>>45260000
                  <<address of entry to be deleted>>           <<+0.06>>45265000
                temp:=csldtx;<<save length of this entry>>     <<+0.06>>45270000
                tos:=@csldtx;<<destination address of move>>   <<+0.06>>45275000
                tos:=s0+temp;<<source address of move>>        <<+0.06>>45280000
                tos:=-s0+cstab+@cstab;<<length of remainder>>  <<+0.06>>45285000
                <<of csldtx table--part to be moved>>          <<+0.06>>45290000
                assemble(move 3);<<contract csldtx table>>     <<+0.06>>45295000
                tos:=cstab-temp;<<size of new cs-table>>       <<+0.06>>45300000
               cstab := s0;                                             45305000
                cstab(csxsize):=s0;<<size of new cs-extension>><<+0.06>>45310000
               cstab(4) := tos;                                         45315000
                cstabincr:=-temp;<<set length parameter for>>  <<+0.06>>45320000
                <<compression of dl-area tables>>              <<+0.06>>45325000
               movedltables;                                            45330000
               end;                                                     45335000
              removeclassrefs;  <<remove references to this device>>    45340000
              remtempclass(ldev);                              <<06812>>45345000
              if drtn=0 and ldev=hldev then                             45350000
                do until ldev'exists(hldev:=hldev-1)                    45355000
                   or hldev=0;                                          45360000
  classesclean:                                                         45365000
              if drtn=0 then go reqldev;                                45370000
            end                                                         45375000
          else if drtn=0 then                                           45380000
            begin                                                       45385000
              message(m2410);  <<no such device>>              <<*8393>>45390000
              go reqldev;                                               45395000
            end                                                         45400000
          else                                                 <<h7508>>45405000
             begin                                             <<h7508>>45410000
             if ldev > hldev then hldev := ldev;               <<h7508>>45415000
             zerobuf( dvrtab, dvrsize );                       <<h7508>>45420000
             zerobuf( lpdt, lpdtsize );                        <<h7508>>45425000
             zerobuf( ldt, ldtsize );                          <<h7508>>45430000
             zerobuf( ldtx, ldtxsize );                        <<h7508>>45435000
             put'ldev'entries(ldev);                           <<h7508>>45440000
             end;                                              <<h7508>>45445000
          get'ldev'entries(ldev);                              <<06762>>45450000
  requnit:unit := getval(m2013,0,maxunit,1);    <<unit number>><<t8393>>45455000
          if dsdevice then                                              45460000
            begin                                                       45465000
            dvrdsbit := 1;                                     <<06762>>45470000
            dvrmasterldev := drtn;                             <<06762>>45475000
            end                                                         45480000
          else dvrdrtnum := drtn;                              <<06762>>45485000
          dvrunitnum := unit;                                  <<06762>>45490000
          val := tl'chan'num;                                  <<t8393>>45495000
          verify'values(m2014,val,0,4,1);                      <<t8393>>45500000
          dvrchannum := val;                                   <<t8393>>45505000
          ldt'avail'to'sys := 1;  <<belongs to file system>>   <<06762>>45510000
  reqtype:                                                     <<t8393>>45515000
          val := tl'dev'type;                                  <<t8393>>45520000
          verify'values(m2015,val,0,63,1);                     <<t8393>>45525000
          type := val;                                         <<t8393>>45530000
          if csdev and unit<>0 or type=sdisc or                <<03544>>45535000
          type=fdisc then                                      <<03544>>45540000
            begin                                              <<03544>>45545000
            message(m2140);  << illegal type or unit >>        <<*8393>>45550000
            go requnit;                                        <<03544>>45555000
            end;                                               <<03544>>45560000
          ldt'device'type := type;  << put type in ldt >>      <<06762>>45565000
          if csdev then                                        <<03544>>45570000
            begin     <<cs device>>                                     45575000
            ldt'cs'device:=1;<<this ldev is a cs-device>>      <<06762>>45580000
            cstab(x):=cstab(csxentries)+1;<<there is going to>><<+0.06>>45585000
            <<be one more cs-device in the system>>            <<+0.06>>45590000
            @csldtx:=@tempcsldtx;<<set pointer to unused area>><<03616>>45595000
            csldtx:=0;<<zero the temp array in preparation>>   <<+0.06>>45600000
            move csldtx(1):=csldtx,(500);<<to build csldtx>>   <<+0.06>>45605000
            <<entry for this new device>>                      <<+0.06>>45610000
            csindx:=contrstart;<<pointer to start of control>> <<+0.06>>45615000
            <<section. (will also be used to point to phone>>  <<+0.06>>45620000
            <<number section and id section)>>                 <<+0.06>>45625000
            csldtxexp:= 1;    <<set table expanded bit>>       <<04936>>45630000
            if type=csdev17 then csldtxmax'dumps:=20;          <<04936>>45635000
            end;                                                        45640000
reqstyp:                                                       <<t8393>>45645000
          val := tl'dev'subtype;                               <<t8393>>45650000
          verify'values(m2016,val,0,15,1);                     <<t8393>>45655000
          subtyp := val;                << subtype? >>         <<t8393>>45660000
          if (type=csdev17 or type=csdev18) and                <<03544>>45665000
            subtyp<>0 and subtyp<>1 and                        <<03544>>45670000
            subtyp<>3 and subtyp<>7 and                        <<l8585>>45675000
            subtyp<>9 or                                       <<l8585>>45680000
            type=csdev19 and                                   <<03544>>45685000
            subtyp<>0 and subtyp<>3 then                       <<03544>>45690000
             begin                                             <<03544>>45695000
             message(m2141); << illegal type or subtype >>     <<*8393>>45700000
             go reqstyp;                                       <<03544>>45705000
             end;                                              <<03544>>45710000
          lpdt'subtype := subtyp;                              <<06762>>45715000
                                                               <<06068>>45720000
      <<---------------------------------------------------->> <<t8753>>45725000
      << begin terminal type/descriptor filename changes for>> <<t8753>>45730000
      << lynxii.                                            >> <<t8753>>45735000
      <<---------------------------------------------------->> <<t8753>>45740000
                                                               <<t8753>>45745000
                                                               <<06068>>45750000
          if type=ldt'terminal or                              <<06762>>45755000
          type= ldt'printer and                                <<06762>>45760000
           (subtyp=14 or subtyp=15) then                       <<03544>>45765000
            begin                                                       45770000
reqtermt:   term'defaults := false;                            <<t8393>>45775000
            termtype := %37; <<default termtype>>              <<t8393>>45780000
            ldtx'tdt'offset := -1;  <<offset into ttdt>>       <<t8393>>45785000
            move bmess:=("ENTER [TERM TYPE #],[DESCRIPTOR ",   <<t8393>>45790000
                         "FILENAME] "), 2;                     <<t8393>>45795000
            if dev'defaults then                               <<t8393>>45800000
               begin                                           <<t8393>>45805000
               move bps0 := "= ( ",2;                          <<t8393>>45810000
               if tl'term'type <> 0  then                      <<t8393>>45815000
                  begin                                        <<t8393>>45820000
                  termtype := tl'term'type;                    <<t8393>>45825000
                  tos := tos + ascii(termtype,10,bps0);        <<t8393>>45830000
                  term'defaults := true;                       <<t8393>>45835000
                  end;                                         <<t8393>>45840000
               if tl'ttdf'ptr <> 0  then                       <<t8393>>45845000
                  begin                                        <<t8393>>45850000
                  name'ptr := tl'ttdf'ptr & lsl (1);           <<t8393>>45855000
               move * := " , ", 2;                             <<t8393>>45860000
                  move * := tl'entb(name'ptr), (8), 2;         <<t8393>>45865000
                  move * := ".", 2;                            <<t8393>>45870000
                  move * := tl'entb(name'ptr + 8), (8), 2;     <<t8393>>45875000
                  move * := ".", 2;                            <<t8393>>45880000
                  move * := tl'entb(name'ptr + 16) , (8), 2;   <<t8393>>45885000
                  term'defaults := true;                       <<t8393>>45890000
                  end;                                         <<t8393>>45895000
               move * := " )", 2;                              <<t8393>>45900000
               end;                                            <<t8393>>45905000
            move * := " ?",2;                                  <<t8393>>45910000
            @pout:=tos;                                        <<t8393>>45915000
            print (messbuf, @bmess-@pout, %320);               <<t8393>>45920000
            readinput;                                         <<t8393>>45925000
            scan binbuf while blank, 1;                        <<t8393>>45930000
            if term'defaults and carry then                    <<t8393>>45935000
               begin  <<defaults used>>                        <<t8393>>45940000
               move bpinbuf:=bmess(46),(@pout-@bmess(46)-4),2; <<t8753>>45945000
               move * := %15; <<carriage return>>              <<t8393>>45950000
               tos := @bpinbuf;                                <<t8393>>45955000
            scan binbuf while blank, 1;                        <<06068>>45960000
               end;                                            <<t8393>>45965000
            if nocarry or term'defaults then                   <<t8393>>45970000
              begin  <<not carraige return input>>             <<t8393>>45975000
              @bpinbuf := tos;                                 <<t8393>>45980000
              <<if 1st byte= #, a termtype # was input>>       <<t8393>>45985000
              if bpinbuf = numeric then                        <<t8393>>45990000
                begin                                          <<t8393>>45995000
                termtype := inval(@ttferr,",");                <<t8393>>46000000
                if < then   <<comma delimiter>>                <<t8393>>46005000
                  if not (0 <= termtype <= %36) then           <<t8393>>46010000
                    goto ttferr                                <<t8393>>46015000
                  else                                         <<t8393>>46020000
                    goto fname;  <<bpinbuf pointing to name>>  <<t8393>>46025000
                if not (0 <= termtype <= %36) then             <<t8393>>46030000
                  goto ttferr;                                 <<t8393>>46035000
                goto ttdone;  << only a # was input >>         <<t8393>>46040000
                end                                            <<t8393>>46045000
              else                                             <<t8393>>46050000
                begin                                          <<t8393>>46055000
fname:          insize := 26;  <<max len>>                     <<t8393>>46060000
                termcntl := 1; <<cr deliminator>>              <<t8393>>46065000
                if not fully'qualify then                      <<t8393>>46070000
                  goto reqtermt;                               <<t8393>>46075000
                end;                                           <<t8393>>46080000
              end  <<not a carriage return input>>             <<t8393>>46085000
            else <<carriage return input, default used>>       <<06068>>46090000
              goto ttdone;                                     <<06068>>46095000
goodinput: << "#,FILENAME", or "FILENAME" has been input >>    <<06068>>46100000
            @tdt := @tdtab;                                    <<*7657>>46105000
            @tdt'b := @tdt & lsl(1);                           <<*7657>>46110000
            i := 0;                                            <<*7657>>46115000
            while (i:=i+1) <= dcth'num'tdt'entries do          <<*7657>>46120000
              begin                                            <<06068>>46125000
              if (tdtb'file'name = file,(8)) and               <<*7657>>46130000
                 (tdtb'group'name = group,(8)) and             <<*7657>>46135000
                 (tdtb'acct'name = acct,(8)) then              <<*7657>>46140000
                   goto filnexst;                              <<06068>>46145000
              @tdt := @tdt + tdt'next'entry;                   <<*7657>>46150000
              @tdt'b := @tdt & lsl(1);                         <<*7657>>46155000
              end;                                             <<06068>>46160000
            <<make room for new entry>>                        <<06068>>46165000
            ttdtincr := 14;                                    <<06068>>46170000
            movedltables;                                      <<06068>>46175000
            @tdt := @tdt - 14; << table has moved down >>      <<*7657>>46180000
            @tdt'b := @tdt & lsl(1);                           <<*7657>>46185000
            move tdtb'file'name := file,(8);                   <<*7657>>46190000
            move tdtb'group'name := group,(8);                 <<*7657>>46195000
            move tdtb'acct'name := acct,(8);                   <<*7657>>46200000
            tdt'num'devices := 1;                              <<*7657>>46205000
            tdt(tdt'first'ldev+1) := ldev;                     <<*7657>>46210000
            dcth'segment'size := dcth'segment'size + 14;       <<*7657>>46215000
            dcth'num'tdt'entries := dcth'num'tdt'entries + 1;  <<*7657>>46220000
            goto ttfoffset;                                    <<06068>>46225000
filnexst:   << add to an already existing entry >>             <<06068>>46230000
            ttdtincr := 1;                                     <<06068>>46235000
            movedltables;                                      <<06068>>46240000
            @tdt := @tdt - 1;                                  <<*7657>>46245000
            @dest := @dct'head + dcth'segment'size;            <<*7657>>46250000
            @source := @dest - 1;                              <<*7657>>46255000
            count := (@source - @tdt(tdt'next'entry)) + 1;     <<*7657>>46260000
            move dest := source,(-count);                      <<*7657>>46265000
            tdt(tdt'next'entry) := ldev;                       <<*7657>>46270000
            tdt'num'devices := tdt'num'devices + 1;            <<*7657>>46275000
            dcth'segment'size := dcth'segment'size + 1;        <<*7657>>46280000
            goto ttfoffset;                                    <<06068>>46285000
ttferr:     message(m2453);   <<illegal input>>                <<t8393>>46290000
            goto reqtermt;                                     <<06068>>46295000
ttfoffset:                                                     <<*7657>>46300000
            put'ldev'entries(ldev);                            <<*7657>>46305000
            calc'ttf'offset;                                   <<*7657>>46310000
            get'ldev'entries(ldev);                            <<*7657>>46315000
ttdone:     <<recalculate ents because of call to movedltabs>> <<06068>>46320000
            ldt'dflt'term'type := termtype;                    <<06762>>46325000
reqspeed:                                                      <<t8393>>46330000
            if dev'defaults then                               <<t8767>>46335000
               begin                                           <<t8767>>46340000
               speedcde := tl'term'speed;                      <<t8767>>46345000
               tspeed   := -1;                                 <<t8767>>46350000
               checkspeed(tspeed, speedcde);                   <<t8767>>46355000
               val := tspeed;                                  <<t8767>>46360000
               end;                                            <<t8767>>46365000
                                                               <<t8767>>46370000
            verify'values(m2018,val,0,3840,2);                 <<t8393>>46375000
            i := val;                      << term speed >>    <<t8393>>46380000
                                                               <<03702>>46385000
            if postseries3 and i = 0 then   << default 240  >> <<03702>>46390000
               i := 240;                    << on 33, 44, 64>> <<03702>>46395000
                                                               <<03702>>46400000
            << call checkspeed to check term. speed reply >>   <<03702>>46405000
            if checkspeed(i, speedcde) then                    <<03702>>46410000
                                                               <<03702>>46415000
               << subtypes > 3 are terminals which are non- >> <<03702>>46420000
               << speedsensing, therefore a valid speed     >> <<03702>>46425000
               << must be entered.                          >> <<03702>>46430000
                                                               <<03702>>46435000
               if not (speedcde = 0 land subtyp > 3) then      <<03702>>46440000
                  goto speedok;                                <<03702>>46445000
                                                               <<03702>>46450000
            message(m130);   << not a supported speed >>       <<*8393>>46455000
            go reqspeed;     << request term speed again >>    <<03702>>46460000
                                                               <<03702>>46465000
speedok:    ldtx'baud'rate'code := speedcde;                   <<06762>>46470000
            end;     << terminal specific prompts >>           <<03702>>46475000
          if csdevice and                                      <<l8585>>46480000
             lpdt'subtype <> 9  then                           <<l8585>>46485000
            begin                                                       46490000
            <<skip all cs-related dialogue for the lanic>>     <<l8585>>46495000
            <<driver : type = 17; subtype = 9           >>     <<l8585>>46500000
            if type=csdev19 then                               <<01165>>46505000
              csldtxhsi'chan:=getval(m2101,1,15,1);<<port mask><<*8393>>46510000
            if type<>17 then                                   <<01165>>46515000
            begin                                              <<01165>>46520000
            csldtxprotocol:=getval(m2102,1,255,1);<<protocol>> <<*8393>>46525000
            csldtxmode:= getval(m2103,1,15,1);<<local mode>>   <<*8393>>46530000
            csldtxcode := getval(m2104,1,63,1);<<transmission c<<*8393>>46535000
            end;                                               <<01165>>46540000
            tos := getval(m2105,0,32767,2);  <<receive timeout><<*8393>>46545000
            if = then                                                   46550000
              begin  <<carriage return>>                                46555000
              del;                                                      46560000
              tos := 20;                                                46565000
              end;                                                      46570000
            csldtxrecv'timeout := tos;                                  46575000
            tos := getval(m2106,0,32767,2);<<local timeout>>   <<*8393>>46580000
            if = then                                                   46585000
              begin  <<carriager return>>                               46590000
              del;                                                      46595000
              tos := 60;                                                46600000
              end;                                                      46605000
            csldtxlocal'timeout := tos;                                 46610000
            tos := getval(m2107,0,32767,2);<<connect timeout>> <<*8393>>46615000
            if = then                                                   46620000
              begin << cr >>                                            46625000
              del;                                                      46630000
              tos := 900;                                               46635000
              end;                                                      46640000
            csldtxconct'timeout := tos;                                 46645000
            if hardwired then go speedch;                               46650000
            if not(modem) or switched then                              46655000
              begin                                                     46660000
  reqdial:    message(-m2108);  <<dial facility?>>             <<*8393>>46665000
              readinput;                                       <<01165>>46670000
              scan binbuf while blank,1;                       <<01165>>46675000
              assemble(dup,dup);                               <<01165>>46680000
              move * := * while ans;                           <<01165>>46685000
              if nocarry and (bps0<>"N") then                  <<01165>>46690000
                 if bps0 = "Y" then                            <<01165>>46695000
                    begin                                      <<01165>>46700000
                    csldtxdial := 1;                           <<01165>>46705000
                    end                                        <<01165>>46710000
                 else                                          <<01165>>46715000
                    begin                                      <<01165>>46720000
                    @bpinbuf := @binbuf;                       <<01165>>46725000
                    tos:=inval(@dialerr,",");                  <<01165>>46730000
                    if <= then                                 <<01165>>46735000
                       begin                                   <<01165>>46740000
                       del;                                    <<01165>>46745000
                       go dialerr;                             <<01165>>46750000
                       end;                                    <<01165>>46755000
                    if 0<=s0<=255 then                         <<01165>>46760000
                       begin                                   <<01165>>46765000
                       csldtxdial := 1;                        <<01165>>46770000
                       csldtxauto'dial'ldn := tos;             <<01165>>46775000
                       end;                                    <<01165>>46780000
                    end;                                       <<01165>>46785000
              del; go reqansw;                                 <<01165>>46790000
  dialerr:    del;                                             <<01165>>46795000
              message(m2453);                                  <<*8393>>46800000
              go reqdial;                                      <<01165>>46805000
  reqansw:    getyesno(@reqdusp,m2109);<<answer facility?>>    <<*8393>>46810000
              getyesno(@manual,m2110); <<automatic answer?>>   <<*8393>>46815000
              csldtxanswer := autoanswer;                               46820000
              go reqdusp;                                               46825000
  manual:     csldtxanswer := manlanswer;                               46830000
              end;                                                      46835000
  reqdusp:  getyesno(@speedch,m2111);<<dual speed?>>           <<*8393>>46840000
            csldtxdual'speed := 1;                                      46845000
            getyesno(@reqtrsp,m2112); <<half speed?>>          <<*8393>>46850000
            csldtxhalf'speed := 1 ;                                     46855000
            go reqtrsp;                                                 46860000
  speedch:  getyesno(@reqtrsp,m2113); <<speed changeable?>>    <<*8393>>46865000
            csldtxspeedchngble:= 1;                                     46870000
  reqtrsp:  message(-m2114);  <<transmission speed?>>          <<*8393>>46875000
            readinput;                                                  46880000
            tos := 0d;                                                  46885000
            tos := @transer;                                            46890000
            tos := inval(*,",",true);                                   46895000
            if <= then                                                  46900000
  transer:    begin                                                     46905000
              message(m2453);                                  <<*8393>>46910000
              go reqtrsp;                                               46915000
              end;                                                      46920000
            assemble(ddup);                                             46925000
            @dblptr := @csldtxinspeed;                         <<06813>>46930000
            dblptr := ds0;                                     <<06813>>46935000
            @dblptr := @csldtxoutspeed;                        <<06813>>46940000
            dblptr := tos;                                     <<06813>>46945000
            csldtxxmsnmode:=getval(m2115,0,3,1);<<transmission <<*8393>>46950000
            csldtxpbuffsize:=getval(m2116,1,4095,1);<<preferred<<*8393>>46955000
            getyesno(@reqdop,m2117); <<driver changeable?>>    <<*8393>>46960000
            csldtxdvrchangable := 1;                                    46965000
  reqdop:   csldtxdoptions:=getval(m2118,0,32767,1);<<dvr optio<<*8393>>46970000
            go reqdvr;                                                  46975000
            end;                                                        46980000
          if csdevice and lpdt'subtype = 9 then go reqdvr;     <<l8585>>46985000
          val := tl'rec'width;                                 <<t8393>>46990000
          verify'values(m2019,val,1,255,1);                    <<t8393>>46995000
          ldt'record'width := val;                             <<t8393>>47000000
                                   <<record width#?>>                   47005000
  reqodev:                                                     <<t8393>>47010000
          if dev'defaults then                                 <<t8393>>47015000
             if logical(tl'def'out'class) then                 <<t8393>>47020000
                begin                                          <<t8393>>47025000
                binbuf(0) :=%10;<<count for genmessage str>>   <<t8393>>47030000
                name'ptr := tl'def'out'dev & lsl(1);           <<t8393>>47035000
                move binbuf(1) := tl'entb(name'ptr),(8);       <<t8393>>47040000
                message(-m2044,,,,,binbuf);                    <<t8393>>47045000
                end                                            <<t8393>>47050000
             else                                              <<t8393>>47055000
                begin                                          <<t8393>>47060000
                if tl'def'out'dev < 0 then                     <<t8393>>47065000
                   message(-m2045,ldev)                        <<t8393>>47070000
                else                                           <<t8393>>47075000
                   message(-m2045,tl'def'out'dev);             <<t8393>>47080000
                end                                            <<t8393>>47085000
          else                                                 <<t8393>>47090000
             message(-m2020);   <<output device?>>             <<t8393>>47095000
          readinput;                                                    47100000
          tos := inval(@trystr,",");                                    47105000
          if < then goto odeverr;                              <<t8393>>47110000
          if = then                                            <<t8393>>47115000
             if dev'defaults then                              <<t8393>>47120000
                if logical(tl'def'out'class) then              <<t8393>>47125000
                   begin                                       <<t8393>>47130000
                   name'ptr := tl'def'out'dev & lsl(1);        <<t8393>>47135000
                   fill'(binbuf, 80, " ");                     <<t8393>>47140000
                   move binbuf := tl'entb(name'ptr),(8),2;     <<t8393>>47145000
                   move * := %15;  <<cr>>                      <<t8393>>47150000
                   goto trystr;                                <<t8393>>47155000
                   end                                         <<t8393>>47160000
                else                                           <<t8393>>47165000
                   begin                                       <<t8393>>47170000
                   if tl'def'out'dev < 0 then                  <<t8393>>47175000
                      s0 := ldev                               <<t8393>>47180000
                   else                                        <<t8393>>47185000
                      s0 := tl'def'out'dev;                    <<t8393>>47190000
                   end                                         <<t8393>>47195000
             else                                              <<t8393>>47200000
                goto odeverr;                                  <<t8393>>47205000
          if 0 <= s0 <= 999 then go setodev;                   <<06815>>47210000
  odeverr:del;                                                          47215000
  odeverr1:message(m2453);                                     <<*8393>>47220000
          go reqodev;                                                   47225000
  trystr: @bpinbuf := @binbuf;                                          47230000
          getstr(@odeverr1,devclass,1,"A",8);                           47235000
          tos := clindex(devclass);   <<get class index>>               47240000
          if s0=0 then putintempclass(devclass,ldev);          <<06812>>47245000
          ldt'class'index := 1;                                <<06762>>47250000
  setodev:ldt'dflt'out'dev := tos;                             <<s8966>>47255000
reqmodes: if dev'defaults then                                 <<s8966>>47260000
             begin                                             <<s8966>>47265000
             lpdt'job'accept := defyesanswer(tl'job'accept,    <<s8966>>47270000
                                             m2046);           <<s8966>>47275000
             lpdt'data'accept := defyesanswer(tl'data'accept,  <<s8966>>47280000
                                             m2047);           <<s8966>>47285000
             lpdt'interactive := defyesanswer(tl'interactive,  <<s8966>>47290000
                                             m2048);           <<s8966>>47295000
             lpdt'duplicative := defyesanswer(tl'duplicative,  <<s8966>>47300000
                                              m2049);          <<s8966>>47305000
             initspool := 0;                                   <<s8966>>47310000
             if tl'spool'state = 1 or                          <<s8966>>47315000
                tl'spool'state = 2 then initspool := 1;        <<s8966>>47320000
             ldt'spool'state :=                                <<s8966>>47325000
             defyesanswer(initspool, m2050, default'chosen);   <<s8966>>47330000
             if default'chosen or                              <<s8966>>47335000
                logical(ldt'spool'state) = logical(initspool)  <<s8966>>47340000
                then begin                                     <<s8966>>47345000
                     ldt'spool'state := tl'spool'state;        <<s8966>>47350000
                     ldt'spool'queues := tl'spool'queues;      <<s8966>>47355000
                     end                                       <<s8966>>47360000
                 else if not default'chosen then               <<s8966>>47365000
                         begin                                 <<s8966>>47370000
                         if logical(initspool) then go reqreply<<s8966>>47375000
                         else if logical(ldt'spool'state)      <<s8966>>47380000
                                 then inoutspool;              <<s8966>>47385000
                         end;                                  <<s8966>>47390000
  reqreply:  lpdt'auto'alloc := defyesanswer(tl'auto'reply,    <<s8966>>47395000
                                             m2056);           <<s8966>>47400000
             goto ckauto;                                      <<s8966>>47405000
             end; <<default modes>>                            <<s8966>>47410000
          getyesno(@reqaccd,m2021); <<accept jobs/sessions?>>  <<*8393>>47415000
          lpdt'job'accept := 1;                                <<06762>>47420000
  reqaccd:getyesno(@reqint,m2022); <<accept data?>>            <<*8393>>47425000
          lpdt'data'accept := 1;                               <<06762>>47430000
  reqint: getyesno(@reqdup,m2023); <<interactive?>>            <<*8393>>47435000
          lpdt'interactive := 1;                               <<06762>>47440000
  reqdup: lpdt'duplicative := yesanswer(m2024);                         47445000
                                                               <<02704>>47450000
          if seriesii'iii and                                  <<02704>>47455000
            (type=disc0 or type=disc1) then                    <<03544>>47460000
            ldtx'seek'ahead := yesanswer(m2029);               <<*8393>>47465000
          tos := @reqrep2;                                     <<s8966>>47470000
reqspool: getyesno(*,m2025);  <<initially spooled?>>           <<t8393>>47475000
          inoutspool;                                          <<s8966>>47480000
                                                               <<s8966>>47485000
          <<------------------------------------------->>      <<s8966>>47490000
          << this fix was made to allow auto allocation>>      <<s8966>>47495000
          << for serial discs.  to allow compatability >>      <<s8966>>47500000
          << with the existing method of subtype defs  >>      <<s8966>>47505000
          << >= 8 for magtapes, the lpdt bit for auto  >>      <<s8966>>47510000
          << allocation is set even if the user ignores>>      <<s8966>>47515000
          << this question.  also, the bit is not set  >>      <<s8966>>47520000
          << even if the user replies "Y" but the devic>>      <<s8966>>47525000
          << cannot be made auto reply. (i.e. magtapes >>      <<s8966>>47530000
          << and sdiscs only).                         >>      <<s8966>>47535000
          <<------------------------------------------->>      <<s8966>>47540000
reqrep2:  lpdt'auto'alloc := yesanswer(m2055);                 <<s8966>>47545000
ckauto:   if type = magtapetype then                           <<s8966>>47550000
             begin                                             <<s8966>>47555000
             lpdt'auto'alloc :=                                <<s8966>>47560000
             if  logical(lpdt'tape'auto'alloc) = 1             <<s8966>>47565000
             or                                                <<s8966>>47570000
             logical(lpdt'auto'alloc) = 1                      <<s8966>>47575000
             then 1 else 0;                                    <<s8966>>47580000
             end                                               <<s8966>>47585000
          else if not sdisc'type(type, subtyp)                 <<s8966>>47590000
                     then lpdt'auto'alloc := false;            <<s8966>>47595000
                                                               <<s8966>>47600000
  reqdvr:                                                      <<t8393>>47605000
          if dev'defaults then                                 <<t8393>>47610000
             begin                                             <<t8393>>47615000
             binbuf(0) :=%10; <<count for genmessage str>>     <<t8393>>47620000
             move binbuf(1) := tl'driver'name,(8);             <<t8393>>47625000
             message(-m2051,,,,,binbuf);                       <<t8393>>47630000
             readinput;                                        <<t8393>>47635000
             scan bpinbuf while blank,1;                       <<t8393>>47640000
             if carry then << cr entered, use default >>       <<t8393>>47645000
                begin                                          <<t8393>>47650000
                del;     << remove scanned lgth from tos >>    << 9097>>47655000
                fill'(binbuf, 80, " ");                        << 9097>>47660000
                dvrcoreres := tl'core'res;                     <<t8393>>47665000
                move binbuf := tl'driver'name,(8),2;           <<t8393>>47670000
                move * := %15;  <<cr>>                         <<t8393>>47675000
                tos := @binbuf; << prep tos for getstr >>      << 9097>>47680000
                end;                                           <<t8393>>47685000
             end                                               <<t8393>>47690000
          else                                                 <<t8393>>47695000
             begin                                             <<t8393>>47700000
             message(-m2026);                                  <<t8393>>47705000
             readinput;                                        <<t8393>>47710000
             scan bpinbuf while blank,1;                       <<t8393>>47715000
             end;                                              <<t8393>>47720000
          if bps0="*" then                                              47725000
            begin   <<core resident driver>>                            47730000
              tos := tos+1;                                             47735000
              if csdevice or dsdevice then message(m2406)      <<*8393>>47740000
                else dvrcoreres:=1; <<core resident>>          <<06762>>47745000
            end;                                                        47750000
          @bpinbuf := tos;                                              47755000
          getstr(@reqdvr,dvrname,1,"A",8);  <<get driver name>><<06762>>47760000
          put'ldev'entries(ldev);                              <<06762>>47765000
  if csdevice then                                             <<01165>>47770000
     begin                                                     <<01165>>47775000
     if switched then                                          <<01165>>47780000
        begin                                                  <<01165>>47785000
            getyesno(@reqlid,m2120);  <<phone list>>           <<*8393>>47790000
          tos := csindx;                                                47795000
          csldtxphlistptr := s0;                                        47800000
          @phone :=(tos+@csldtx)&lsl(1);                       <<03704>>47805000
          phinx := 4;   <<point past sequence length>>                  47810000
          j:=0;                                                         47815000
  phonenb:message(-m2121);   <<phone number>>                  <<*8393>>47820000
          readinput;                                                    47825000
          i:=getphnb(@phonenb,btemp,"-");                               47830000
          if > then                                                     47835000
            begin                                                       47840000
            move phone(phinx):=btemp,(i);                               47845000
            phone(x:=x-1) := i;                                         47850000
            phinx := phinx+i+1;  <<point past next sequence length>>    47855000
            j:=j+1;                                                     47860000
            go phonenb;                                                 47865000
            end;                                                        47870000
          if j<=0 then                                                  47875000
           begin  <<no phone list>>                                     47880000
           csldtxphlistptr := 0;                                        47885000
           end                                                          47890000
          else                                                          47895000
            begin                                                       47900000
            phone(numseq) := j; <<# of phone sequences>>                47905000
            tos := phinx&lsr(1);                                        47910000
            csldtx(csindx) := s0-1; <<size of list in words>>           47915000
            csindx := tos+csindx;                                       47920000
            end;                                                        47925000
        end;                                                   <<01165>>47930000
     if contention or ldt'device'type=csdev17 then             <<06762>>47935000
        begin                                                  <<01165>>47940000
        if switched then                                       <<01165>>47945000
          begin                                                <<01165>>47950000
  reqlid: tos:=csindx;                                         <<00.05>>47955000
          csldtxidlistptr := s0;                                        47960000
          @idlist := (tos+@csldtx)&lsl(1);                     <<03704>>47965000
          idinx := 4;                                                   47970000
          j := 0;                                                       47975000
          i:=0;                                                         47980000
  reqlids:message(-m2122); <<local id sequence?>>              <<*8393>>47985000
          readinput;                                                    47990000
          scan bpinbuf while blank,1;                                   47995000
          if carry then                                                 48000000
            begin                                                       48005000
            del;                                                        48010000
            idlist(idinx-1):=0;<<null local id>>;                       48015000
            idinx:=idinx+1;   <<point to 1st remote id>>                48020000
            end                                                         48025000
          else                                                          48030000
            begin                                                       48035000
            tos := getseq(@reqlids,btemp);                              48040000
            duplicate;                                                  48045000
            tos := tos land %77;                                        48050000
            temp := tos;          <<length>>                            48055000
            idlist(idinx-1):=tos;       <<length and in type>>          48060000
            move idlist(idinx):=btemp,(temp);                           48065000
            idinx := idinx+temp+1;  <<bump index>>                      48070000
            i := i+1;                                                   48075000
            end;                                                        48080000
  reqrids:  message(-m2123); <<remote id sequence?>>           <<*8393>>48085000
          readinput;                                                    48090000
          tos := getseq(@reqrids,btemp);                                48095000
          if s0=0 then                                                  48100000
            begin <<no input>>                                          48105000
            del;                                                        48110000
            if i<=0 then                                                48115000
              begin     <<null id list>>                                48120000
              csldtxidlistptr := 0;                                     48125000
              go reqclss;                                               48130000
              end;                                                      48135000
            idlist(numseq) := i;                                        48140000
            tos := idinx&lsr(1);                                        48145000
            csldtx(csindx) := s0-1;  <<size of lidt in words>>          48150000
            csindx := tos+csindx;                                       48155000
            go reqclss;                                                 48160000
            end;                                                        48165000
          duplicate;                                                    48170000
          tos := tos land %77;  <<length>>                              48175000
          temp := tos;                                                  48180000
          idlist(idinx-1) := tos;                                       48185000
          move idlist(idinx) := btemp,(temp);                           48190000
          idinx := idinx+temp+1;                                        48195000
          i := i+1;                                                     48200000
          go reqrids;                                                   48205000
          end;                                                 <<01165>>48210000
        end                                                    <<01165>>48215000
     else                                                      <<01165>>48220000
        if controlst then                                      <<01165>>48225000
          begin                                                <<01165>>48230000
  reqidlay: csldtx(csindx+intcomdelay)                                  48235000
                :=getval(m2124,0,32767,1);<<intercomponent dela<<*8393>>48240000
            tos := getval(m2125,0,32767,1); <<# of polls repeat<<*8393>>48245000
            csldtx(csindx) := s0;                                       48250000
            if tos=0 then go reqcpst;                                   48255000
  reqcirp:  csldtx(csindx+cirpdelay)                                    48260000
               := getval(m2126,0,32767,1);<<circular poll delay<<*8393>>48265000
  reqcpst:  i := getval(m2127,0,255,1);<<components per station<<*8393>>48270000
  reqncom:  n := getval(m2128,0,63,1); <<# of components>>     <<*8393>>48275000
            csldtxcontptr:=csindx;                                      48280000
            if controlst then csindx:=csindx+conseqstart                48285000
            else csindx:=csindx+1; <<tributary>>                        48290000
            @bcsldtx := @csldtx&lsl(1);<<byte pointer for seque<<03704>>48295000
            bindx := csindx&lsl(1);<<index for byte array>>             48300000
            if controlst then bcsldtx(bindx-2):=(n+i-1)/i;              48305000
               <<determine # of stations if control station>>           48310000
            bcsldtx(bindx-1) := n;    <<# of components>>               48315000
            lastpollent := 0;                                           48320000
            i := -1;                                                    48325000
            while(i:=i+1)<n  do                                         48330000
              begin                                                     48335000
              tos := getval(m2129,0,2,1);<<component type>>    <<*8393>>48340000
              bcsldtx(bindx) := s0;                                     48345000
              if tos<>2 or not(controlst) then                          48350000
                go reqcompseq;                                          48355000
              getyesno(@reqcompseq,m2130);<<component in poll l<<*8393>>48360000
              if lastpollent=0  then                                    48365000
                 begin                                                  48370000
                 csldtx(contrstart+firstcomp) := i;                     48375000
                 lastpollent := bindx;                                  48380000
                 tos := bcsldtx(bindx);                                 48385000
                 tos.(8:6) := i;                                        48390000
                 bcsldtx(x) := tos;                                     48395000
                 end                                                    48400000
              else                                                      48405000
                 begin                                                  48410000
                 tos := bcsldtx(lastpollent);                           48415000
                 tos.(8:6) := i;                                        48420000
                 bcsldtx(x) := tos;                                     48425000
                 lastpollent := bindx;                                  48430000
                 end;                                                   48435000
  reqcompseq: message(-m2131); <<component sequence?>>         <<*8393>>48440000
              readinput;                                                48445000
              tos := getseq(@reqcompseq,btemp);                         48450000
              if s0=0 then                                              48455000
                begin                                                   48460000
                del;                                                    48465000
  badseq:       message(m2453);                                <<*8393>>48470000
                go reqcompseq;                                          48475000
                end;                                                    48480000
              duplicate;                                                48485000
              tos := tos land %77;<<length>>                            48490000
              if s0>8 then                                              48495000
                begin                                                   48500000
                ddel;                                                   48505000
                goto badseq;                                            48510000
                end;                                                    48515000
              duplicate;                                                48520000
              tos := @bcsldtx+bindx+2; <<sequence start>>               48525000
              tos := @btemp;   <<get ready for move bytes>>             48530000
              assemble(cab;mvb 3;xch); <<rove sequence into csldtx>>    48535000
              bcsldtx(bindx+1) := tos;  <<in type and length>>          48540000
              bindx := tos+bindx+2; <<point past this sequence>>        48545000
              end;                                                      48550000
            if n>0 then csindx := (bindx+1)&lsr(1);                     48555000
          end;                                                 <<01165>>48560000
     end;                                                      <<01165>>48565000
  reqclss:                                                     <<t8393>>48570000
          if dev'defaults then                                 <<t8393>>48575000
             begin                                             <<t8393>>48580000
             fill'(bmess,80," ");                              <<t8393>>48585000
             move bmess := "DEVICE CLASSES = ",2;              <<t8393>>48590000
             i := 0;                                           <<t8393>>48595000
             name'ptr := tl'dev'class'ptr & lsl(1);            <<t8393>>48600000
             while (i:=i+1) <= tl'num'dev'class do             <<t8393>>48605000
                begin                                          <<t8393>>48610000
                move bps0 := tl'entb(name'ptr),(8);            <<t8393>>48615000
                scan * until blank,1;                          <<t8393>>48620000
                if i < tl'num'dev'class then                   <<t8393>>48625000
                   move * := ", ",2;                           <<t8393>>48630000
                name'ptr := name'ptr + 8;                      <<t8393>>48635000
                end;                                           <<t8393>>48640000
             move * := "?",2;                                  <<t8393>>48645000
             temp := tos-@bmess;                               <<t8393>>48650000
             print(messbuf,-temp,%320);                        <<t8393>>48655000
             readinput;                                        <<t8393>>48660000
             scan bpinbuf while blank, 1;                      <<t8393>>48665000
             if carry and tl'dev'class'ptr <> 0 then           <<t8393>>48670000
                begin  << default values used >>               <<t8393>>48675000
                fill'(binbuf, 80, " ");                        <<t8393>>48680000
                temp := temp - 18;  <<count for dev classes>>  <<t8393>>48685000
                move binbuf := bmess(17),(temp),2;             <<t8393>>48690000
                bps0   := %15;  <<cr>>   del;                  <<t8393>>48695000
                end;                                           <<t8393>>48700000
             end                                               <<t8393>>48705000
          else                                                 <<t8393>>48710000
             begin                                             <<t8393>>48715000
             message(-m2027);                                  <<t8393>>48720000
             readinput;                                        <<t8393>>48725000
             end;                                              <<t8393>>48730000
  nextclass:                                                            48735000
          more := false;                                                48740000
          tos := 0;  <<return from getstr>>                             48745000
          tos := @clserr;                                               48750000
          getstr(*,devclass,2,"A",8);   <<class name>>                  48755000
          if = then go putincs;  <<no class>>                           48760000
          if < then more := true;   <<followed by comma>>               48765000
          devclass(8) := " "; <<terminator>>                   <<00844>>48770000
          @dct := @dct'head + dcth'dct'base;                   <<06762>>48775000
          @dct'b := @dct & lsl(1);                             <<06762>>48780000
          i := -1;                                                      48785000
          while (i:=i+1) < dcth'num'dct'entries do             <<06762>>48790000
            begin                                                       48795000
              if dctb'class'name = devclass,(8)                <<06762>>48800000
                then goto entexst;                             <<06762>>48805000
              @dct := @dct + dct'next'entry;                   <<06762>>48810000
              @dct'b := @dct & lsl(1);                         <<06762>>48815000
            end;                                                        48820000
          dctabincr := 7; <<make room for new entry>>          <<06762>>48825000
          movedltables;                                                 48830000
          @dct := @dct - 7;  << table has moved down   >>      <<06762>>48835000
          @dct'b := @dct & lsl(1);                             <<06762>>48840000
          move dctb'class'name := devclass,(8);                <<06762>>48845000
          dct'cyclical'ptr := 1;                               <<06762>>48850000
          if sdisc'type(type,subtyp) then                      <<03544>>48855000
             begin <<creating a disc class--could be serial>>  <<sd.00>>48860000
             move blbuf:="IS ",2;                              <<sd.00>>48865000
             assemble(dup);                                    <<sd.00>>48870000
             move *:=devclass while an,1;                      <<sd.00>>48875000
             assemble(dup,cab;sub);                            <<sd.00>>48880000
             temp:=tos; <<length of classname>>                <<sd.00>>48885000
             move *:=" A SERIAL DISC CLASS?";                  <<sd.00>>48890000
             print(lbuf,-temp-24,%320);                        <<sd.00>>48895000
             dct'class'acc'type := ldt'serial'disc;            <<06762>>48900000
             read(lbuf,-3); <<get yes or no--default=no>>      <<sd.00>>48905000
             move blbuf:= blbuf while ans;                     <<03700>>48910000
             if blbuf="Y" then go issdisc;                     <<sd.00>>48915000
             move blbuf:="IS ",2;                              <<01115>>48920000
             assemble(dup);                                    <<01115>>48925000
             move *:=devclass while an,1;                      <<01115>>48930000
             assemble(dup,cab;sub);                            <<01115>>48935000
             temp:=tos;<<length of classname>>                 <<01115>>48940000
             move *:=" A FOREIGN DISC CLASS?";                 <<01115>>48945000
             print(lbuf,-temp-25,%320);                        <<01115>>48950000
             dct'class'acc'type := ldt'foreign'disc;           <<06762>>48955000
             read(lbuf,-3);<<yes or no -- default no>>         <<01115>>48960000
             move blbuf:= blbuf while ans;                     <<03700>>48965000
             if blbuf="Y" then go isfdisc;                     <<01115>>48970000
             dct'class'acc'type := type;                       <<06762>>48975000
issdisc:                                                       <<sd.00>>48980000
isfdisc:                                                       <<01115>>48985000
             end                                               <<sd.00>>48990000
          else                                                 <<sd.00>>48995000
             dct'class'acc'type := ldt'device'type;            <<06762>>49000000
          dct'num'devices := 1;                                <<06762>>49005000
          dct(dct'first'ldev) := ldev;                         <<06762>>49010000
          dcth'num'dct'entries := dcth'num'dct'entries + 1;    <<06762>>49015000
          dcth'tdt'base := dcth'tdt'base + 7;                  <<06762>>49020000
          dcth'segment'size := dcth'segment'size + 7;          <<06762>>49025000
          cktempclass(dctb'class'name);                        <<06812>>49030000
          if more then go nextclass else go putincs;                    49035000
  entexst:i := -1;                                             <<06762>>49040000
          while (i:=i+1) < dct'num'devices do                  <<06762>>49045000
          if dct(dct'first'ldev + i) = ldev then               <<06762>>49050000
            begin    <<duplicate entry>>                                49055000
              del;                                                      49060000
              message(m2453);                                  <<*8393>>49065000
  clserr:     removeclassrefs;                                          49070000
              go reqclss;                                               49075000
            end;                                                        49080000
          dctabincr := 1; <<add 1 word>>                       <<06762>>49085000
          movedltables;                                        <<06762>>49090000
          @dct := @dct - 1; <<count word has moved by 1 word>> <<06762>>49095000
          @dest := (@dct'head + dcth'tdt'base);                <<*7657>>49100000
          @source := @dest - 1;                                <<06762>>49105000
          count := (@source - @dct(dct'next'entry)) + 1;       <<06762>>49110000
          move dest := source, (-count);                       <<06762>>49115000
                                                               <<06762>>49120000
          dct(dct'next'entry) := ldev;                         <<06762>>49125000
          dct'num'devices := dct'num'devices + 1;              <<06762>>49130000
          dcth'tdt'base := dcth'tdt'base + 1;                  <<06762>>49135000
          dcth'segment'size := dcth'segment'size + 1;          <<06762>>49140000
          determctyp(@sameplace,dct,false);                    <<06762>>49145000
sameplace:if more then go nextclass;                           <<03610>>49150000
  putincs:if csdevice then                                     <<06762>>49155000
            begin                                                       49160000
            csldtx := csindx;                                           49165000
            cstabincr := csindx;                                        49170000
            movedltables;                                               49175000
            tos := @cstab+cstab;   <<first free byte>>                  49180000
            duplicate;                                                  49185000
            move *:=csldtx,(csindx);                                    49190000
            cstab := cstab+csindx; <<update segment size>>              49195000
            i := -1;                                                    49200000
            @csldtx := @cstab + csxstart;                               49205000
            do i:=i+1                                                   49210000
            until(@csldtx:=@csldtx+csldtx)>s0;                          49215000
            del;                                                        49220000
            csdef(ldev) := i;                                           49225000
            end;                                                        49230000
          go reqldev;                                                   49235000
  reqvdev:i:=-1;                                                        49240000
          j:=0;                                                         49245000
          while (i:=i+1) <= hldev do                                    49250000
            begin                                              <<06762>>49255000
            get'ldev'entries(i);                               <<06762>>49260000
            if dvrdrtnum <> 0 or <<count used drts>>           <<06762>>49265000
              dvrdsbit = 1 then j:=j+1;                        <<06762>>49270000
            end;                                               <<06762>>49275000
  maxospool:                                                            49280000
          getnewval(m2352,ctab0(maxspoolf),0,1023-j);          <<*8393>>49285000
                              << max num open spoolfiles >>    <<*8393>>49290000
          if ctab0(maxspoolf)>(1023-j) then                    <<06815>>49295000
            <<must make this test in the case where a large>>           49300000
            <<number of real devices have been added and   >>           49305000
            <<the number of open spoolfiles was not changed>>           49310000
            begin <<must change max # of open spoolfiles>>              49315000
            message(m2355);                                    <<*8393>>49320000
            message(m2356);                                    <<*8393>>49325000
            move  binbuf := "IS ";                                      49330000
            i := ascii(1023-j,10,binbuf(3));                   <<06815>>49335000
            print(inbuf,-i-3,0);                                        49340000
            goto maxospool;                                             49345000
            end;                                                        49350000
           getyesno(@reqnlcs,m2009);<<list i/o devices>>       <<*8393>>49355000
          listiodev;                                                    49360000
  reqnlcs:if cspresent then                                             49365000
            begin                                                       49370000
            getyesno(@reqttfc,m2100);  <<list cs devices>>     <<t8753>>49375000
            listcsdev;                                                  49380000
            end;                                               <<06068>>49385000
reqttfc:                                                       <<06068>>49390000
          tos := @reqclc;                                      <<06068>>49395000
          getyesno(*,m2312); <<term type changes?>>            <<*8393>>49400000
   reqlttf:                                                    <<06068>>49405000
          tos := @reqdttf;                                     <<06068>>49410000
          getyesno(*,m2310); <<list termtype descr files?>>    <<*8393>>49415000
          if dcth'num'tdt'entries <> 0 then                    <<*7657>>49420000
            list'ttdt                                          <<06068>>49425000
          else                                                 <<06068>>49430000
            message (m2311); <<no term type files defined>>    <<*8393>>49435000
reqdttf:                                                       <<06068>>49440000
          tos := @reqattf;                                     <<06068>>49445000
          getyesno(*,m2313); <<delete term type files>>        <<*8393>>49450000
getttf:   warn := false;                                       <<06068>>49455000
          message(m2315); <<files?>>                           <<*8393>>49460000
          readinput;                                           <<06068>>49465000
nextttf:  scan bpinbuf while blank, 1;                         <<06068>>49470000
          if nocarry then  <<not a carraige return input>>     <<06068>>49475000
            begin                                              <<06068>>49480000
            more := true;                                      <<06068>>49485000
            @bpinbuf := tos;                                   <<06068>>49490000
            scan bpinbuf until cr'comma, 1;                    <<06068>>49495000
            if carry then  <<only one file to delete>>         <<06068>>49500000
              more := false;                                   <<06068>>49505000
            insize := tos - @bpinbuf;                          <<06068>>49510000
            termcntl := 2;  <<comma deliminator>>              <<06068>>49515000
            if not fully'qualify then                          <<06068>>49520000
              goto getttf;                                     <<06068>>49525000
            @tdt := @tdtab;                                    <<*7657>>49530000
            @tdt'b := @tdt & lsl(1);                           <<*7657>>49535000
            i := 0;                                            <<*7657>>49540000
            while  (i:=i+1) <= dcth'num'tdt'entries do         <<*7657>>49545000
              begin                                            <<06068>>49550000
              if (tdtb'file'name = file,(8)) and               <<*7657>>49555000
                 (tdtb'group'name = group,(8)) and             <<*7657>>49560000
                 (tdtb'acct'name = acct,(8)) then              <<*7657>>49565000
                 begin                                         <<06068>>49570000
                 delete'ttdt;                                  <<06068>>49575000
                 goto next;                                    <<06068>>49580000
                 end;                                          <<06068>>49585000
              @tdt := @tdt + tdt'next'entry;                   <<*7657>>49590000
              @tdt'b := @tdt & lsl(1);                         <<*7657>>49595000
              end;                                             <<06068>>49600000
            warn := true;                                      <<06068>>49605000
            move bmess := "FILENAME ",2;                       <<06068>>49610000
            move * := fqfname,(fqfnsize),2;                    <<06068>>49615000
            move * := " DOES NOT EXIST";                       <<06068>>49620000
            print(bmess,-(24+fqfnsize),0);                     <<06068>>49625000
next:       if more = true then                                <<06068>>49630000
              goto nextttf                                     <<06068>>49635000
            else                                               <<06068>>49640000
              if warn = true then                              <<06068>>49645000
                begin                                          <<06068>>49650000
                getyesno(@getttf,m2310);<<list tt descr files?><<*8393>>49655000
                if dcth'num'tdt'entries <> 0 then              <<*7657>>49660000
                  begin                                        <<06068>>49665000
                  list'ttdt;                                   <<06068>>49670000
                  goto getttf;                                 <<06068>>49675000
                  end                                          <<06068>>49680000
                else                                           <<06068>>49685000
                  begin                                        <<06068>>49690000
                  message(m2311);  <<no term type files def>>  <<*8393>>49695000
                  goto getttf;                                 <<06068>>49700000
                  end;                                         <<06068>>49705000
                end;                                           <<06068>>49710000
              goto getttf;                                     <<06068>>49715000
            end;  <<not a carriage return input>>              <<06068>>49720000
reqattf:  tos := @reqlntc;                                     <<06068>>49725000
          getyesno (*,m2314);  <<add termtype descr files>>    <<*8393>>49730000
getaddf:  message(m2316);     <<filename?>>                    <<*8393>>49735000
          readinput;                                           <<06068>>49740000
nextaddf: scan bpinbuf while blank,1;                          <<06068>>49745000
          if carry then  <<carriage return input>>             <<06068>>49750000
            goto reqlntc                                       <<06068>>49755000
          else                                                 <<06068>>49760000
            begin                                              <<06068>>49765000
            insize := 26;                                      <<06068>>49770000
            termcntl := 1;  <<cr deliminator>>                 <<06068>>49775000
            if not fully'qualify then                          <<06068>>49780000
              goto getaddf;                                    <<06068>>49785000
            end;                                               <<06068>>49790000
reqldevs: message(m2305);  <<logical ldevs?>>                  <<*8393>>49795000
          readinput;                                           <<06068>>49800000
          more := true;                                        <<06068>>49805000
nextldev: while more=true do                                   <<06068>>49810000
            begin  <<ldevs>>                                   <<06068>>49815000
            ldev := inval(@ttfaerr,",");                       <<06068>>49820000
            if = then                                          <<06068>>49825000
              goto getaddf;                                    <<06068>>49830000
            if > then      <<only one ldev to add>>            <<06068>>49835000
              more := false;                                   <<06068>>49840000
            if not ldev'exists(ldev) then                      <<06068>>49845000
              begin                                            <<06068>>49850000
              tos := 0;                                        <<06068>>49855000
              tos := ldev;                                     <<06068>>49860000
              tos := 10;                                       <<06068>>49865000
              move bmess := "LDEV ",2;                         <<06068>>49870000
              len := ascii(*,*,*);                             <<06068>>49875000
              move bmess(len +5) := " DOES NOT EXIST",2;       <<06068>>49880000
              print (bmess,(-20-len),0);                       <<06068>>49885000
              goto nextldev;                                   <<06068>>49890000
              end;                                             <<06068>>49895000
            if not (ldt'device'type = ldt'terminal lor         <<06762>>49900000
                   ldt'device'type = ldt'printer land          <<06762>>49905000
                   (lpdt'subtype=14 lor                        <<06762>>49910000
                   lpdt'subtype=15)) then                      <<06762>>49915000
              begin                                            <<06068>>49920000
              tos := 0;                                        <<06068>>49925000
              tos := ldev;                                     <<06068>>49930000
              tos := 10;                                       <<06068>>49935000
              move bmess := "LDEV ",2;                         <<06068>>49940000
              len := ascii(*,*,*);                             <<06068>>49945000
              move bmess(len+5):=" IS NOT A SERIAL I/O DEVICE",<<06068>>49950000
                                                             2;<<06068>>49955000
              print (bmess,(-32-len),0);                       <<06068>>49960000
              goto nextldev;                                   <<06068>>49965000
              end;                                             <<06068>>49970000
            index := ldtx'tdt'offset;                          <<06762>>49975000
            if ldtx'tdt'offset = -1 then                       <<*7657>>49980000
              goto addname                                     <<06068>>49985000
            else  <<has a filename associated with it already>><<06068>>49990000
              begin                                            <<06068>>49995000
              @tdt := @tdtab + ldtx'tdt'offset;                <<*7657>>50000000
              @tdt'b := @tdt & lsl(1);                         <<*7657>>50005000
              if (tdtb'file'name = file,(8)) and               <<*7657>>50010000
                 (tdtb'group'name = group,(8)) and             <<*7657>>50015000
                 (tdtb'acct'name = acct,(8)) then              <<*7657>>50020000
                 goto nextldev   <<same name-do nothing>>      <<06068>>50025000
              else                                             <<06068>>50030000
                 begin  <<replacing an existing filename>>     <<06068>>50035000
                 move bmess := tdtb'file'name,(8);             <<*7657>>50040000
                 move bmess(8) := ".";                         <<06068>>50045000
                 move bmess(9) := tdtb'group'name,(8);         <<*7657>>50050000
                 move bmess(17) := ".";                        <<06068>>50055000
                 move bmess(18) := tdtb'acct'name,(8);         <<*7657>>50060000
                 tos := 0;                                     <<06068>>50065000
                 tos := ldev;                                  <<06068>>50070000
                 tos := 10;                                    <<06068>>50075000
                 move bmess(26) := " REPLACED FOR LDEV ",2;    <<06068>>50080000
                 len := ascii(*,*,*);                          <<06068>>50085000
                 print(bmess,-(len+45),0);                     <<06068>>50090000
                 removettdtrefs(ldev);                         <<*7657>>50095000
                 end;                                          <<06068>>50100000
              end;                                             <<06068>>50105000
addname:                                                       <<06359>>50110000
            @tdt := @tdtab;                                    <<*7657>>50115000
            @tdt'b := @tdt & lsl(1);                           <<*7657>>50120000
            i:= 0;                                             <<*7657>>50125000
            while (i:=i+1) <= dcth'num'tdt'entries do          <<*7657>>50130000
              begin                                            <<06068>>50135000
              if (tdtb'file'name = file,(8)) and               <<*7657>>50140000
                 (tdtb'group'name = group,(8)) and             <<*7657>>50145000
                 (tdtb'acct'name = acct,(8)) then              <<*7657>>50150000
                 goto oldtfent;                                <<06068>>50155000
              @tdt := @tdt + tdt'next'entry;                   <<*7657>>50160000
              @tdt'b := @tdt & lsl(1);                         <<*7657>>50165000
              end;                                             <<06068>>50170000
            <<make room for new entry>>                        <<06068>>50175000
            ttdtincr := 14;                                    <<*7657>>50180000
            movedltables;                                      <<*7657>>50185000
            @tdt := @tdt - 14; << table has moved down >>      <<*7657>>50190000
            @tdt'b := @tdt & lsl(1);                           <<*7657>>50195000
            move tdtb'file'name := file,(8);                   <<*7657>>50200000
            move tdtb'group'name := group,(8);                 <<*7657>>50205000
            move tdtb'acct'name := acct,(8);                   <<*7657>>50210000
            tdt'num'devices := 1;                              <<*7657>>50215000
            tdt(tdt'first'ldev+1) := ldev;                     <<*7657>>50220000
            dcth'segment'size := dcth'segment'size + 14;       <<*7657>>50225000
            dcth'num'tdt'entries := dcth'num'tdt'entries + 1;  <<*7657>>50230000
            goto offset;                                       <<06068>>50235000
oldtfent:   << add to an already existing entry >>             <<06068>>50240000
            ttdtincr := 1;                                     <<*7657>>50245000
            movedltables;                                      <<*7657>>50250000
            @tdt := @tdt - 1;                                  <<*7657>>50255000
            @dest := @dct'head + dcth'segment'size;            <<*7657>>50260000
            @source := @dest - 1;                              <<*7657>>50265000
            count := (@source - @tdt(tdt'next'entry)) + 1;     <<*7657>>50270000
            move dest := source,(-count);                      <<*7657>>50275000
            tdt(tdt'next'entry) := ldev;                       <<*7657>>50280000
            tdt'num'devices := tdt'num'devices + 1;            <<*7657>>50285000
            dcth'segment'size := dcth'segment'size + 1;        <<*7657>>50290000
            goto offset;                                       <<06068>>50295000
ttfaerr:    message(01);   <<illegal input>>                   <<06068>>50300000
            goto reqldevs;                                     <<06068>>50305000
offset:     calc'ttf'offset;                                   <<06068>>50310000
            end;  <<ldevs>>                                    <<06068>>50315000
          goto reqldevs;                                       <<06068>>50320000
reqlntc:  getyesno(@reqclc,m2310); <<list termtype desc files>><<*8393>>50325000
          if dcth'num'tdt'entries <> 0 then                    <<*7657>>50330000
            list'ttdt                                          <<06068>>50335000
          else                                                 <<06068>>50340000
            message(m2311);  <<no term type files defined>>    <<*8393>>50345000
                                                               <<06068>>50350000
                                                               <<06068>>50355000
   reqclc:tos := @updodev;                                     <<06068>>50360000
          getyesno(*,m2300);  <<class changes?>>               <<*8393>>50365000
   reqloc:tos := @reqdcls;                                              50370000
          getyesno(*,m2301);  <<list classes?>>                <<*8393>>50375000
          listclasses;                                                  50380000
   reqdcls:getyesno(@reqacls,m2302); <<delete classes>>        <<*8393>>50385000
           error := false;                                              50390000
   getclassn:                                                           50395000
          message(-m2304);  <<class names>>                    <<*8393>>50400000
          readinput;                                                    50405000
   nextcl:more := false;                                                50410000
          getstr(@reqlic,devclass,2,"A",8);                             50415000
          if = and last  then go dclerr;                                50420000
          if < then more := last  := true else last:=false;             50425000
          i := deleteclass(@reqloc);                                    50430000
          k := 0;                                                       50435000
          while (k:=k+1) <=hldev do                                     50440000
            begin                                              <<06762>>50445000
            get'ldev'entries(k);                               <<06762>>50450000
          if logical(ldt'class'index) then                     <<06762>>50455000
            begin <<output device is class>>                            50460000
            tos := ldt'dflt'out'dev;   <<index to class table>><<06762>>50465000
            if s0=i then                                       <<00.03>>50470000
              begin <<output device is deleted class>>         <<00.03>>50475000
              ldt'dflt'out'dev:= 0;                            <<06762>>50480000
              putintempclass(devclass,k);                      <<06812>>50485000
              end                                              <<00.03>>50490000
            else if s0>i then ldt'dflt'out'dev:=s0-1;          <<06762>>50495000
            del;                                                        50500000
            put'ldev'entries(k);                               <<06762>>50505000
            end;                                                        50510000
          end;                                                 <<06762>>50515000
          if more then go nextcl else go reqacls;                       50520000
   reqlic:getyesno(@getclassn,m2301);                          <<*8393>>50525000
          listclasses;                                                  50530000
          go getclassn;                                                 50535000
   dclerr:message(m2453);                                      <<*8393>>50540000
          go getclassn;                                                 50545000
   reqacls:getyesno(@reqlnc,m2303);<<add classes>>             <<*8393>>50550000
   reqncl:message(-m2307); <<class name>>                      <<*8393>>50555000
          readinput;                                                    50560000
          getstr(@reqncl ,devclass,3,"A",8);                            50565000
          if = then go reqlnc; <<carriage return>>                      50570000
   reqdevs:i := 0;                                                      50575000
          message(-m2305);  <<logical devices #'s>>            <<*8393>>50580000
          readinput;                                                    50585000
   getndev:i:=i+1;                                                      50590000
          more := false;                                                50595000
          tos := inval(@claserr,",");                          <<01009>>50600000
          if = then                                            <<01009>>50605000
   claserr: begin                                              <<01009>>50610000
              message(m2453);                                  <<*8393>>50615000
              tos:=i;                                          <<01009>>50620000
              assemble(subs 0);  <<delete input from stack>>   <<01009>>50625000
              go to reqdevs;  <<try again>>                    <<01009>>50630000
             end;                                              <<01009>>50635000
          if < then more := true;                                       50640000
          new'ldev:= s0;                                       <<03610>>50645000
          if not ldev'exists(new'ldev) then                    <<03610>>50650000
            go claserr; <<device not defined>>                          50655000
          if more then go getndev;                                      50660000
          @dct := @dct'head + dcth'dct'base;                   <<06762>>50665000
          @dct'b := @dct & lsl(1);                             <<06762>>50670000
          j:= -1;                                                       50675000
          while (j:=j+1) < dcth'num'dct'entries do             <<06762>>50680000
            begin                                                       50685000
            if dctb'class'name = devclass,(8) then go oldent;  <<06762>>50690000
            @dct := @dct + dct'next'entry;                     <<06762>>50695000
            @dct'b := @dct & lsl(1);                           <<06762>>50700000
            end;                                                        50705000
          dctabincr := dct'first'ldev + i;                     <<06762>>50710000
          @dct := @dct - dctabincr;    << tables have moved >> <<06762>>50715000
          @dct'b := @dct & lsl(1);                             <<06762>>50720000
          movedltables;                                                 50725000
          move dctb'class'name:=devclass,(8);                  <<06762>>50730000
          dct'cyclical'ptr := 1;                               <<06762>>50735000
          dct'class'acc'type := 0;                             <<06762>>50740000
          dct'num'devices := i; <<#devices in class>>          <<06762>>50745000
          tos := @dct(dct'first'ldev);                         <<06762>>50750000
          x := -i-1;                                                    50755000
          while (x:=x+1)<0  do                                          50760000
            begin                                                       50765000
            ps0 := ias0(x);                                    <<06762>>50770000
            tos := tos + 1;                                             50775000
            end;                                                        50780000
          dcth'num'dct'entries := dcth'num'dct'entries + 1;    <<06762>>50785000
          dcth'tdt'base := dcth'tdt'base + dct'first'ldev + i; <<06762>>50790000
         dcth'segment'size:=dcth'segment'size+dct'first'ldev+i;<<06762>>50795000
          determctyp(@reqloc,dct,true); <<determine class tp>> <<06762>>50800000
          cktempclass(dctb'class'name);                        <<06812>>50805000
          go reqncl;                                                    50810000
  oldent:                   <<class already existed>>          <<06762>>50815000
          k := -i;                                             <<06762>>50820000
          while (k:=k+1) <= 0 do                               <<06762>>50825000
            begin                                                       50830000
            m := -1;                                           <<06762>>50835000
            while (m:=m+1) < dct'num'devices do                <<06762>>50840000
              if ias0(k) = dct(dct'first'ldev + m) then        <<06762>>50845000
                begin <<duplicate entries>>                             50850000
                message(m2306);                                <<*8393>>50855000
                tos := i;                                      <<06762>>50860000
                assemble(subs 0);                                       50865000
                getyesno(@reqdevs,m2301);                      <<*8393>>50870000
                listclasses;                                            50875000
                go reqdevs;                                             50880000
                end;                                                    50885000
            end;                                                        50890000
          dctabincr := i;                                      <<06762>>50895000
          movedltables;                                                 50900000
          @dct := @dct - i;                                    <<06762>>50905000
          @dct'b := @dct & lsl(1);                             <<06762>>50910000
          @dest := (@dct'head + dcth'tdt'base);                <<*7657>>50915000
          @source := @dest - i;                                <<06762>>50920000
          count := (@source - @dct(dct'next'entry)) + 1;       <<06762>>50925000
          move dest := source, (-count);                       <<06762>>50930000
          tos := @dct(dct'next'entry);                         <<06762>>50935000
          x := -i-1;                                           <<06762>>50940000
          while (x:=x+1)<0 do                                           50945000
            begin                                                       50950000
            ps0 := ias0(x);                                    <<06762>>50955000
            tos := tos+1;                                               50960000
            end;                                                        50965000
          dct'num'devices := dct'num'devices + i;              <<06762>>50970000
          dcth'tdt'base := dcth'tdt'base + i;                  <<06762>>50975000
          dcth'segment'size := dcth'segment'size + i;          <<06762>>50980000
          go reqncl;                                                    50985000
   reqlnc:getyesno(@updodev,m2301);<<list classes>>            <<*8393>>50990000
          listclasses;                                                  50995000
   updodev:                                                    <<06812>>51000000
          clean'tclasses;                                      <<06812>>51005000
         if error then go confdone;                            <<01073>>51010000
  reqnlio:tos := @reqdvrc;                                              51015000
          getyesno(*,m2009);   <<list i/o devices>>            <<*8393>>51020000
          listiodev;                                                    51025000
  reqdvrc:if comm(numadvrs)>0 then                             <<07039>>51030000
            begin <<delete dvrs from cs list if configured>>            51035000
            i := -1;                                                    51040000
            tos := @bcsdvr;                                             51045000
            while(i:=i+1)<comm(numadvrs) do                    <<07039>>51050000
              begin <<check if configured>>                             51055000
              j := 0;                                                   51060000
              while(j:=j+1)<=comm(drtnum) do                   <<07039>>51065000
                begin                                                   51070000
                duplicate;                                              51075000
                get'ldev'entries(j);                           <<06762>>51080000
                tos := @dvrtab & lsl(1);                       <<06762>>51085000
                if *=*,(8) then                                         51090000
                  begin <<delete from cs list>>                         51095000
                  duplicate;                                            51100000
                  tos:=s0+8; <<move all following dvrs up>>             51105000
                  tos:=-s0+comm(numadvrs)*csdvrsize;<<length>> <<07039>>51110000
                  assemble(mvb 3);                                      51115000
                  comm(x) := comm(numadvrs)-1;                 <<07039>>51120000
                  i:=i-1;  <<reflect deleted dvr in count>>             51125000
                  goto nextcsd;                                         51130000
                  end;                                                  51135000
                end;                                                    51140000
              tos := tos+8; <<next cs driver>>                          51145000
  nextcsd:    end;                                                      51150000
            del;                                                        51155000
            end;                                                        51160000
          if comm(numadvrs)>0  or cspresent then               <<07039>>51165000
            begin                                                       51170000
            getyesno(@confdone, m2150);<< addit dvr changes? >><<*8393>>51175000
            if comm(numadvrs)<=0 then go reqadvr;              <<07039>>51180000
  reqldvr:  getyesno(@reqddvr,m2151); <<list additional drivers<<*8393>>51185000
            listdvrs;                                                   51190000
  reqddvr:  getyesno(@reqadvr,m2152); <<delete drivers?>>      <<*8393>>51195000
  getdnam:  message(-m2026);   <<driver name>>                 <<*8393>>51200000
            readinput;                                                  51205000
            getstr(@getdnam,bdname,3,"A",8);                   <<00.04>>51210000
            if = then go reqadvr;                                       51215000
            i := -1;                                                    51220000
            while(i:=i+1)<comm(numadvrs) do                    <<07039>>51225000
              if bcsdvr((i*csdvrsize)&lsl(1))=bdname,(8),2 then         51230000
                begin  <<found it>>                                     51235000
                tos := wordaddress(bps0); delb; <<make word add<<03704>>51240000
                tos := s0-4;                                            51245000
                assemble(xch,dup,neg);                                  51250000
                tos:=tos+comm(numadvrs)*csdvrsize+@csdvr;      <<07039>>51255000
                <<calculate remaining size of table to move>>  <<00.06>>51260000
                assemble(move 3); <<compact table>>                     51265000
                comm(x) := comm(numadvrs)-1;                   <<07039>>51270000
                go getdnam;                                             51275000
                end                                                     51280000
              else del;                                                 51285000
            message(m2153); <<driver not in list>>             <<*8393>>51290000
            goto getdnam;                                      <<00.04>>51295000
  reqadvr:  getyesno(@reqlndvr,m2156); <<add drivers?>>        <<*8393>>51300000
  reqdname: message(-m2026);    <<driver name?>>               <<*8393>>51305000
            readinput;                                                  51310000
            getstr(@reqadvr,bdname,3,"A",8);                            51315000
            if = then go reqlndvr;                                      51320000
            if comm(numadvrs)>=csdrivers then                  <<07039>>51325000
              begin <<max # of extra drivers exceeded>>                 51330000
              message(m2155);                                  <<*8393>>51335000
              go reqldvr;                                               51340000
              end;                                                      51345000
            i := -1;                                                    51350000
            while(i:=i+1)<comm(numadvrs) do                    <<07039>>51355000
              if bdname=bcsdvr(i*8),(8) then                            51360000
                begin <<already exists>>                                51365000
  dvrerr:       message(m2154);                                <<*8393>>51370000
                go reqldvr;                                             51375000
                end;                                                    51380000
            i := 0;                                                     51385000
            while(i:=i+1)<=hldev do                                     51390000
              begin                                                     51395000
              get'ldev'entries(i);                             <<06762>>51400000
              tos := @dvrtab & lsl(1);                         <<06762>>51405000
              if *=bdname,(8) then go dvrerr;                           51410000
              end;                                                      51415000
            tos := @csdvr+comm(numadvrs)*csdvrsize;            <<07039>>51420000
            move *:=dname,(4);                                          51425000
            comm(x) := comm(numadvrs)+1;                       <<07039>>51430000
            goto reqdname;                                              51435000
  reqlndvr: if comm(numadvrs) <= 0 then go to confdone;        <<07039>>51440000
            getyesno(@confdone,m2151);                         <<*8393>>51445000
            listdvrs;                                                   51450000
            end;                                                        51455000
  confdone:                                                             51460000
      end <<mainseg1>> ;                                                51465000
$page "MAINSEG2  --  CONFIGURATION CHANGES"                             51470000
$control segment=mainseg2                                               51475000
$page "             SYSTEM TABLE CHANGES"                      <<01073>>51480000
$control segment=systemch                                      <<01073>>51485000
procedure system'table'ch;                                     <<06815>>51490000
   option privileged,uncallable;                               <<06815>>51495000
begin                                                          <<06815>>51500000
   getnewval(m3001,ctab(cstnum),80, 2048);<<shareable area cst><<j8889>>51505000
   getnewval(m3002,ctab(cstxnum),16,8191); <<program area cst>><<*8393>>51510000
   getnewval(m3003,ctab(dstnum),70,4096);   <<dst>>            <<j8889>>51515000
   getnewval(m3004,ctab(pcbnum),12,1024);   <<pcb>>            <<j8889>>51520000
   getnewval(m3005,ctab(ioqnum),20,1300);   <<ioq>>            <<j8889>>51525000
   getnewval(m3006,ctab(discreqtable),20,900);<<disc req table><<j8889>>51530000
   getnewval(m3007,ctab(tbufnum),1,  << no. tbufs/port >>      <<*8393>>51535000
     perportmax);                                              <<06815>>51540000
                                                               <<06815>>51545000
    << the following value is type-ahead buffer size  >>       <<06815>>51550000
    << for terminals.  it is reserved for future use. >>       <<06815>>51555000
                                                               <<06815>>51560000
   <<   getnewval(174,ctab(typebuf),0,60); <<type-ahead   >>   <<*8393>>51565000
   <<                                      << buffer size >>   <<06815>>51570000
   getnewval(m3008,ctab(sbufnum),8,253); <<system buffers>>    <<j8889>>51575000
   getnewval(m3009,ctab(swaptable),128,5400);<<swap table>>    <<j8889>>51580000
   getnewval(m3010,ctab(primarymsgtable),10,1023);<<prm msg tab<<j8889>>51585000
   getnewval(m3011,ctab(secndrymsgtable),10,1023);<<sec msg tab<<j8889>>51590000
   getnewval(m3012,ctab(specialreqtable),10,2048);<<spcl req ta<<j8889>>51595000
   getnewval(m3013,ctab(icssize),256,4096);<<ics>>             <<j8889>>51600000
   getnewval(m3017,ctab(lstsize),2048,32760);                  <<*8585>>51605000
   getnewval(m3014,ctab(ucrqnum),1,1024);  <<ucop request queue<<j8889>>51610000
   getnewval(m3015,ctab(trlnum),6,1023);   <<trl>>             <<j8889>>51615000
   getnewval(m3016,ctab(stopnum),1,1024);  <<bkpt table>>      <<j8889>>51620000
   getnewval(m2656,ctab(nlogprocs),2,64); <<users/log proc>>   <<*8393>>51625000
   getnewval(m2657,ctab(logids),1,256);   <<# log processes>>  <<j8889>>51630000
end;                                                           <<06815>>51635000
$page "             MISCELLANEOUS TABLE CHANGES"               <<01073>>51640000
$control segment=systemch                                      <<01073>>51645000
procedure misc'config'ch;                                      <<06814>>51650000
   option privileged,uncallable;                               <<06814>>51655000
begin                                                          <<06814>>51660000
   integer array buf(0:11) = q;                                <<06814>>51665000
   integer                                                     <<06814>>51670000
      jcwstatus,                                               <<m9096>>51675000
      len,                                                     <<06814>>51680000
      rinnr,                                                   <<06814>>51685000
      glarea,  << pointer to global rin area >>                <<06814>>51690000
      index;                                                   <<06814>>51695000
                                                               <<06814>>51700000
   mfds( glarea, rindseg, 1, 1);                               <<06814>>51705000
   if yesanswer(m2702) then listrin;                           <<*8393>>51710000
   if yesanswer(m2703) then                                    <<*8393>>51715000
      begin                   << delete global rin >>          <<06814>>51720000
      do begin                                                 <<06814>>51725000
         rinnr := getval(m2705,1,1024,2);<<enter rin number>>  <<*8393>>51730000
         if rinnr <> 0 then                                    <<06814>>51735000
            begin                                              <<06814>>51740000
            if rinnr <= minrin then                            <<06814>>51745000
               mfds( buf, rindseg, rinnr*3, 1);                <<06814>>51750000
          if rinnr > minrin or buf.(0:2)<>2                    <<*8393>>51755000
            then message(m2701)                                <<*8393>>51760000
            else                                               <<06814>>51765000
               begin  <<delete it>>                            <<06814>>51770000
               index := buf.(2:14) + glarea;                   <<06814>>51775000
               zerobuf( buf, 12);                              <<06814>>51780000
               mtds(rindseg,rinnr*3,buf,1); <<make free entry>><<06814>>51785000
               mtds(rindseg,index,buf,12); <<zero global area>><<06814>>51790000
               mds(rindseg,index,rindseg,glarea,1);<<link entry<<06814>>51795000
               mtds(rindseg,glarea,index,1);<<update free ptr>><<06814>>51800000
               end;                                            <<06814>>51805000
            end;                                               <<06814>>51810000
         end until rinnr = 0;                                  <<06814>>51815000
          if yesanswer(m2702) then listrin;                    <<*8393>>51820000
     compactrin;                                               <<06814>>51825000
     end;                                                      <<06814>>51830000
                                                               <<06814>>51835000
   if ctab(rins')<minrin then ctab(x) := minrin;<<coresize chng<<06814>>51840000
   if ctab(grins')<mingrin  then ctab(x) := mingrin;           <<06814>>51845000
   rinchange := true;                                          <<06814>>51850000
   getnewval(m2707,ctab(rins'),minrin,1024,minrin);            <<*8393>>51855000
   getnewval(m2708,ctab(grins'),mingrin,1024,mingrin);         <<*8393>>51860000
          getnewval(m2706,ctab0(logon),10,600);<<# of seconds t<<*8393>>51865000
          getnewval(m2715,ctab(maxrses),1,500);<<max # of      <<j8889>>51870000
                               << concurrent running sessions>><<*8393>>51875000
          getnewval(m2704,ctab(maxrjob),1,500);<<max running jo<<j8889>>51880000
          getnewval(m2710,ctab0(cpulim),0,32767);              <<*8393>>51885000
chngmc:   getyesno(@reqsdfc,m2712);                            <<*8393>>51890000
      message(-m2714); <<catalog input filename?>>             <<*8393>>51895000
      readinput;                                               <<dl.01>>51900000
      scan binbuf while blank,1;                               <<dl.01>>51905000
      @bpinbuf:=tos;                                           <<dl.01>>51910000
      tos:=0; <<space for return from getstr>>                 <<dl.01>>51915000
      tos:=@makecaterror; <<error return point>>               <<dl.01>>51920000
      move b:="FILE INPUT=",2;                                 <<dl.01>>51925000
      temp:=getstr(*,*,1,".",27);                              <<dl.01>>51930000
      b(11+temp):=byte(%15);                                   <<dl.01>>51935000
      command(b,i,j);                                          <<dl.01>>51940000
      if <> then goto makecaterror;                            <<dl.01>>51945000
      setjcw(0);                                               <<dl.01>>51950000
      if <> then goto makecaterror;                            <<dl.01>>51955000
      create(makecatprog,,makecatpin,,makecatflag);            <<dl.01>>51960000
      if <> then goto makecaterror;                            <<dl.01>>51965000
      activate(makecatpin,makecatsusp);                        <<dl.01>>51970000
      if <> then goto makecaterror;                            <<dl.01>>51975000
      move b := "CIERROR ";                                    <<m9096>>51980000
      findjcw( b, makecatjcw, jcwstatus);                      <<m9096>>51985000
      if <> then goto makecaterror;                            <<dl.01>>51990000
      if makecatjcw<>0 then                                    <<dl.01>>51995000
        begin <<error>>                                        <<dl.01>>52000000
makecaterror:                                                  <<dl.01>>52005000
        message(m2716); <<**makecat error**>>                  <<*8393>>52010000
    if not logical(mode) then quit(1); << die, if in batch>>   <<m9096>>52015000
        if makecatjcw<0 then                                   <<dl.01>>52020000
          purgetempsl                                          <<dl.01>>52025000
        else                                                   <<dl.01>>52030000
          goto chngmc;                                         <<dl.01>>52035000
        end   <<error>>                                        <<dl.01>>52040000
      else                                                     <<dl.01>>52045000
        begin <<replace catalog>>                              <<dl.01>>52050000
                                                               <<04253>>52055000
        add'to'sysprog'chg'table(catalogfile,catalogfile'rep); <<04253>>52060000
                                                               <<04253>>52065000
                                                               <<04253>>52070000
        end;  <<change message catalog>>                       <<04253>>52075000
                                                               <<00150>>52080000
reqsdfc:                                                       <<00150>>52085000
        if postseries3 then                                    <<01402>>52090000
           begin <<allow changes to softdump facility>>        <<00150>>52095000
           if not yesanswer(m2717) then return;                <<*8393>>52100000
           <<changes?>>                                        <<00150>>52105000
           message(-m2718); <<sdf command file name>>          <<*8393>>52110000
           readinput;                                          <<00150>>52115000
           scan binbuf while blank,1;                          <<00150>>52120000
           @bpinbuf:=tos;                                      <<00150>>52125000
           tos:=0; <<space for return from getstr>>            <<00150>>52130000
           tos:=@sdferr; <<error return label>>                <<00150>>52135000
           move b:="FILE INPUT=",2;                            <<00150>>52140000
           temp:=getstr(*,*,1,".",27);                         <<00150>>52145000
           b(11+temp):=byte(%15);                              <<00150>>52150000
           command(b,i,j);                                     <<00150>>52155000
           if <> then goto sdferr;                             <<00150>>52160000
           setjcw(0);                                          <<00150>>52165000
           if <> then goto sdferr;                             <<00150>>52170000
           create(sdfprog,,sdfpin,,sdfflag);                   <<00150>>52175000
           if <> then goto sdferr;                             <<00150>>52180000
           activate(sdfpin,sdfsusp);                           <<00150>>52185000
           if <> then goto sdferr;                             <<00150>>52190000
           sdfjcw:=getjcw;                                     <<00150>>52195000
           if <> then goto sdferr;                             <<00150>>52200000
           if sdfjcw<>0 then                                   <<00150>>52205000
              begin <<error>>                                  <<00150>>52210000
sdferr:                                                        <<00150>>52215000
              message(m2719); <<sdf error>>                    <<*8393>>52220000
              if sdfjcw<0 then                                 <<00150>>52225000
                 purgetempsl <<fatal>>                         <<00150>>52230000
              else                                             <<00150>>52235000
                 goto reqsdfc; <<retry>>                       <<00150>>52240000
              end   <<error>>                                  <<00150>>52245000
           else                                                <<00150>>52250000
              begin <<replace sdf command file >>              <<00150>>52255000
                                                               <<04253>>52260000
                                                               <<04253>>52265000
                                                               <<04253>>52270000
          add'to'sysprog'chg'table(sdfcomfile,sdfcomfile'rep); <<04253>>52275000
              end;  <<replace>>                                <<00150>>52280000
           end;  <<sdf changes>>                               <<00150>>52285000
                                                               <<00150>>52290000
     end;                                                      <<01073>>52295000
$page "             LOGGING CHANGES"                           <<01073>>52300000
$control segment=systemch                                      <<01073>>52305000
     procedure logging'ch;                                     <<01073>>52310000
     option privileged,uncallable;                             <<01073>>52315000
     begin                                                     <<01073>>52320000
         if yesanswer(m2651) then listlog;                     <<*8393>>52325000
         if yesanswer(m2652) then                              <<*8393>>52330000
         begin                  << change status >>            <<01073>>52335000
  reqlc:  message(-m2653);  <<enter type, on/off>>             <<*8393>>52340000
          readinput;                                                    52345000
          n := inval(@logerr,",");     <<log type>>                     52350000
          if = then goto reqnllg;                                       52355000
          if > then                                                     52360000
            begin  <<followed by cr>>                                   52365000
  logerr:     message(m2453);                                  <<*8393>>52370000
              go reqlc;                                                 52375000
            end;                                                        52380000
          if not (1<=n<=logrmax) then goto logerr;             <<rh.pv>>52385000
          getstr(@reqlc,vname,1,"A",3); <<get "ON" or "OFF">>           52390000
          if vname = "OFF" then tos := 0                                52395000
          else if vname="ON" then tos := 1                              52400000
          else goto logerr;                                             52405000
          more := tos;                                                  52410000
        event'word:=n/16;     <<logging mask word #>>          <<01762>>52415000
        tos:=ctab0(logbits+event'word);    <<get mask word>>   <<01762>>52420000
        x:=15 - n mod 16;          <<compute bit position>>    <<01762>>52425000
          if more then assemble(tsbc 0,x) else assemble(trbc 0,x);      52430000
        ctab0(logbits+event'word):=tos;    <<set mask word>>   <<01762>>52435000
          go reqlc;                                                     52440000
  reqnllg:ctab0(logbits).(15:1) := ctab0(logbits).(14:1);               52445000
          if yesanswer(m2651) then listlog;                    <<*8393>>52450000
         end;                                                  <<01073>>52455000
          getnewval(m2654,ctab0(logrecsize),1,8);              <<*8393>>52460000
          getnewval(m2655,ctab0(logfilesize),16,32767);<<log fi<<*8393>>52465000
     end;                                                      <<01073>>52470000
$page "             DISK ALLOCATION CHANGES"                   <<01073>>52475000
$control segment=systemch                                      <<01073>>52480000
     procedure disk'alloc'ch;                                  <<01073>>52485000
     option privileged,uncallable;                             <<01073>>52490000
     begin                                                     <<01073>>52495000
     double  vdslen;     << v.m. length in sectors >>          <<01549>>52500000
     logical volume,                                           <<01549>>52505000
             vdslen1     = vdslen,                             <<01549>>52510000
             vdslen2     = vdslen+1;                           <<01549>>52515000
     byte array name(0:79);                                    <<01549>>52520000
     double  ddirc;                                            <<de>>   52525000
     logical ldirc1 = ddirc,                                   <<de>>   52530000
             ldirc2 = ddirc+1;                                 <<de>>   52535000
                                                               <<01549>>52540000
          tos := 0d;  <<for ascii>>                                     52545000
          dsir := getsir(dirsir);   <<directory sir>>                   52550000
          tos:=setsysdb; <<fetch directory address from sys glob>>      52555000
          tos:=dbarray(dirdisc1);                              <<00215>>52560000
          tos:=dbarray(dirdisc2);                              <<00215>>52565000
          tos:=s2;                                             <<00215>>52570000
          resetdb(*);                                          <<00215>>52575000
          dirdiscadr:=tos;                                     <<00215>>52580000
          del;                                                 <<00215>>52585000
          ddirc := dirsize ( dirsect );                        <<de>>   52590000
          relsir(dirsir,dsir);                                          52595000
          if logical(ctab(dirsect')) < ldirc2 then             <<*8393>>52600000
             ctab(dirsect') := ldirc2;                         <<*8393>>52605000
          getnewval(m2551,ctab(dirsect'),                      <<*8393>>52610000
                      ldirc2,65000,ldirc1);                    <<*8393>>52615000
          if yesanswer(m2201) then listvol;                    <<*8393>>52620000
  reqdvol:getyesno(@reqavol,m2202);  <<delete volume>>         <<*8393>>52625000
  reqvname1:                                                            52630000
          message(-m2204);    <<enter volume name>>            <<*8393>>52635000
          readinput;                                                    52640000
          scan binbuf while blank;                                      52645000
          if carry then go reqavol;   <<carraige return input>>         52650000
          getstr(@reqvname1,vname,1,"A",8);                             52655000
          index := findvol(vname);                                      52660000
          if <> then                                                    52665000
            begin    <<not found>>                                      52670000
              message(m2205);                                  <<*8393>>52675000
              go reqvname1;                                             52680000
            end;                                                        52685000
          if index/vtabsize = mvol then                        <<rh.pv>>52690000
            begin  <<must compact table>>                               52695000
              do                                               <<rh.pv>>52700000
                 begin                                         <<rh.pv>>52705000
                 mvol:=mvol-1;                                 <<rh.pv>>52710000
                 i:=mvol;                                      <<rh.pv>>52715000
                 if vtab(i*vtabsize) <> 0 then                 <<rh.pv>>52720000
                    goto squishvtab;                           <<rh.pv>>52725000
                 end                                           <<rh.pv>>52730000
              until <>;  <<will always be =>>                  <<rh.pv>>52735000
squishvtab:   hvol:=mvol;                                      <<rh.pv>>52740000
              vtabincr := x-index;                             <<rh.pv>>52745000
              movedltables;  <<compact table>>                          52750000
            end                                                         52755000
          else                                                          52760000
            begin  <<zero entry>>                                       52765000
              vtab(index) := 0;                                         52770000
              move vtab(x:=x+1) := vtab(x:=x-1),(vtabsize-1);           52775000
            end;                                                        52780000
          go reqvname1;                                                 52785000
 reqavol:if yesanswer(m2203) then                              <<*8393>>52790000
         begin                                                 <<01073>>52795000
  reqvname2:                                                            52800000
          message(-m2204);   <<enter volume name>>             <<*8393>>52805000
          readinput;                                                    52810000
          scan binbuf while blank;                                      52815000
          if carry then go reqnvl;                                      52820000
          getstr(@reqvname2,vname,1,"A",8);                             52825000
          findvol(vname);                                               52830000
          if = then                                                     52835000
            begin  <<duplicate>>                                        52840000
              message(m2206);                                  <<*8393>>52845000
              go reqvname2;                                             52850000
            end;                                                        52855000
          i := 0;                                                       52860000
          while (i:=i+1) <= hvol do                                     52865000
          if vtab(vtabsize*i)=0 then go insertvol;                      52870000
          if i=256 then                                                 52875000
            begin                                                       52880000
              message(m2212); <<too many volumes>>             <<*8393>>52885000
              go reqdvol;                                               52890000
            end;                                                        52895000
          hvol := hvol+1;                                               52900000
          mvol := mvol+1;                                      <<rh.pv>>52905000
          vtabincr := vtabsize;                                         52910000
          movedltables;    <<make room for new entry>>                  52915000
  insertvol:                                                            52920000
          << zero out the volume table entry >>                <<d7834>>52925000
          zerobuf(vtab(i*vtabsize),vtabsize);                  <<d7834>>52930000
          move vtab(i*vtabsize) := ivname,(4);  <<move in name>>        52935000
          go reqvname2;                                                 52940000
         end;                                                  <<01073>>52945000
  reqnvl: if yesanswer(m2201) then listvol;                    <<*8393>>52950000
        <<-------------------------->>                         <<01549>>52955000
        <<  virtual memory changes  >>                         <<01549>>52960000
        <<-------------------------->>                         <<01549>>52965000
                                                               <<01549>>52970000
while yesanswer(m2215) do                                      <<*8393>>52975000
  begin  << virtual memory changes? >>                         <<01549>>52980000
  if yesanswer(m2216) then listvm;                             <<*8393>>52985000
  << list virtual memory allocation? >>                        <<01549>>52990000
redo:                                                          <<01549>>52995000
  message(-m2217);  << enter volume, size in kilo sectors >>   <<*8393>>53000000
  readinput;                                                   <<01549>>53005000
  scan binbuf while blank, 1;                                  <<01549>>53010000
  if nocarry then  << not carrage return input >>              <<01549>>53015000
    begin                                                      <<01549>>53020000
    @bpinbuf := tos;                                           <<01549>>53025000
    << if 1st byte = alpha name was input else ldev was input>><<01549>>53030000
    if bpinbuf = alpha then                                    <<01549>>53035000
      begin  << get volume # from name >>                      <<01549>>53040000
      move name := "        ";  << 8 blanks >>                 <<01549>>53045000
      move name := bpinbuf while ans, 0;                       <<01549>>53050000
      delb;  << save source, delete destination >>             <<01549>>53055000
      if bps0 <> "," then                                      <<01549>>53060000
        begin                                                  <<01549>>53065000
wrong:  message(m2453);  << illegal input >>                   <<*8393>>53070000
        goto redo;                                             <<01549>>53075000
        end;                                                   <<01549>>53080000
      @bpinbuf := tos+1;  << skip comma >>                     <<01549>>53085000
      volume := findvol(name);                                 <<01549>>53090000
      if <> then                                               <<01549>>53095000
        begin                                                  <<01549>>53100000
        message(m2205);  << no such volume >>                  <<*8393>>53105000
        goto redo;                                             <<01549>>53110000
        end;                                                   <<01549>>53115000
      volume := volume / vtabsize;                             <<01549>>53120000
      end                                                      <<01549>>53125000
    else                                                       <<01549>>53130000
      begin  << get volume # from ldev >>                      <<01549>>53135000
      ldev := inval(@wrong, ",");                              <<01549>>53140000
      if >= then goto wrong;                                   <<01549>>53145000
      << bpinbuf now pointing just past comma >>               <<01549>>53150000
      volume := getvol(ldev);                                  <<01549>>53155000
      if <> then                                               <<01549>>53160000
        begin                                                  <<01549>>53165000
        message(m2205);  << no such volume >>                  <<*8393>>53170000
        goto redo;                                             <<01549>>53175000
        end;                                                   <<01549>>53180000
      end;                                                     <<01549>>53185000
                                                               <<01549>>53190000
  << got volume now get requested length >>                    <<01549>>53195000
    tos := 0;  << for double value returned by inval >>        <<01549>>53200000
    tos := inval(@wrong,,true);                                <<01549>>53205000
    if <= then goto wrong;                                     <<01549>>53210000
    vdslen := tos * 1024d;                                     <<01549>>53215000
                                                               <<01549>>53220000
  << virtual memory size has changed - update vtab >>          <<01549>>53225000
    vtab(volume*vtabsize+vtab8) := 0;  << zero address >>      <<01549>>53230000
    vtab(x:=x+1) := 0;                                         <<01549>>53235000
    vtab(x:=x+1) := vdslen1;                                   <<01549>>53240000
    vtab(x:=x+1) := vdslen2;                                   <<01549>>53245000
    if vdslen = 0d then vtab(x:=x+1).vms := 0                  <<01549>>53250000
    else vtab(x:=x+1).vms := 1;                                <<01549>>53255000
                                                               <<01549>>53260000
    goto redo;                                                 <<01549>>53265000
    end;  << not a carrage return input >>                     <<01549>>53270000
  end;  << virtual memory changes >>                           <<01549>>53275000
    getnewval'doub(m2353,dctab0(kilosects),0d,777777d);        <<*8393>>53280000
rqextssect:                                                    <<00311>>53285000
         tos:=ctab0(extssect');                                <<00311>>53290000
          getnewval(m2354,ctab0(extssect'),128,32767);         <<*8393>>53295000
         if ctab0(extssect').(14:2) <> 0 then                  <<00311>>53300000
            begin                                              <<00311>>53305000
              message(m2357);                                  <<*8393>>53310000
              ctab0(extssect'):=tos; <<restore old value>>     <<00311>>53315000
              go rqextssect;                                   <<00311>>53320000
            end                                                <<00311>>53325000
         else                                                  <<00311>>53330000
           del;                                                <<00311>>53335000
     end;                                                      <<01073>>53340000
$page "             SCHEDULING CHANGES"                        <<01073>>53345000
$control segment=systemch                                      <<01073>>53350000
     procedure scheduling'ch;                                  <<01073>>53355000
     option privileged,uncallable;                             <<01073>>53360000
     begin                                                     <<01073>>53365000
     end;                                                      <<01073>>53370000
$page "             SEGMENT LIMIT CHANGES"                     <<01073>>53375000
$control segment=systemch                                      <<01073>>53380000
     procedure seg'limit'ch;                                   <<01073>>53385000
     option privileged,uncallable;                             <<01073>>53390000
     begin                                                     <<01073>>53395000
          getnewval(m2752,ctab(conprognum),1,511);             <<j8889>>53400000
          getnewval(m2753,ctab(mcss),1024,16384);              <<*8393>>53405000
          getnewval(m2754,ctab(mcsp),1,255);                   <<j8889>>53410000
          getnewval(m2755,ctab(mstack),256,31232);             <<*8393>>53415000
          getnewval(m2756,ctab(mxdss),0,32764);<<max xdseg size<<m8981>>53420000
          getnewval(m2757,ctab(mxdsp),0,255);                  <<*8393>>53425000
          getnewval(m2758,ctab0(sss),256,4096);                <<*8393>>53430000
     end;                                                      <<01073>>53435000
$page "             SYSTEM PROGRAM CHANGES"                    <<01073>>53440000
$control segment=systemch                                      <<04253>>53445000
     procedure system'prog'ch;                                 <<04253>>53450000
     option privileged,uncallable;                             <<04253>>53455000
     begin                                                     <<04253>>53460000
     define cr=%15#;                                           <<04253>>53465000
     logical table'full;                                       <<04253>>53470000
     integer i,error,parm;                                     <<04253>>53475000
     array msgbuf(0:19);                                       <<04253>>53480000
     byte array bmsgbuf(*)=msgbuf;                             <<04253>>53485000
     byte array progname(0:7),                                 <<04253>>53490000
                repname(0:25),                                 <<04253>>53495000
                ckrepfile(0:39);                               <<04253>>53500000
  reqspc: message(-m2603);                                     <<*8393>>53505000
          readinput;                                           <<04253>>53510000
          scan binbuf while blank,1;                           <<04253>>53515000
          if carry then                                        <<04253>>53520000
            begin   <<carriage return input>>                  <<04253>>53525000
              del;                                             <<04253>>53530000
              go reqsslc;                                      <<04253>>53535000
            end;                                               <<04253>>53540000
          @bpinbuf := tos;                                     <<04253>>53545000
          progname:= " ";                                      <<04253>>53550000
          move progname(1):= progname,(7);                     <<04253>>53555000
          getstr(@badspc,progname,0,"A",8);                    <<04253>>53560000
          table'full:= true;                                   <<04253>>53565000
          i:= 0;                                               <<04253>>53570000
          while i<sysprog'chg'table'limit-68 do                <<04253>>53575000
            begin                                              <<04253>>53580000
            if progname = bspc(i),(8) then                     <<04253>>53585000
              begin   <<already in table>>                     <<04253>>53590000
              bspc(i):= 0;                                     <<04253>>53595000
              go to getnewp;                                   <<04253>>53600000
              end;                                             <<04253>>53605000
            if bspc(i)=0 then                                  <<04253>>53610000
              table'full:= false;                              <<04253>>53615000
            i:= i+34;  <<update table ptr>>                    <<04253>>53620000
            end;                                               <<04253>>53625000
          if table'full then                                   <<04253>>53630000
            begin                                              <<04253>>53635000
            move bmsgbuf:=                                     <<04253>>53640000
              "SYSTEM PROGRAM CHANGE TABLE FULL        ";      <<04253>>53645000
            print(msgbuf,20,%40);                              <<04253>>53650000
            move bmsgbuf:= "NO SYSTEM PROGRAM CHANGE FOR ";    <<04253>>53655000
            move bmsgbuf(29):= progname,(8);                   <<04253>>53660000
            move bmsgbuf(37):= "   ";                          <<04253>>53665000
            print(msgbuf,20,%40);                              <<04253>>53670000
            go to reqspc;                                      <<04253>>53675000
            end;                                               <<04253>>53680000
                                                               <<04253>>53685000
          i:= -1;                                              <<04253>>53690000
          x:= -8;                                              <<04253>>53695000
          while (i:=i+1) < nsysprog do <<check if system prog>><<04253>>53700000
            begin                                              <<04253>>53705000
              if sysprog(x:=x+8) = progname,(8)                <<04253>>53710000
                              then goto getnewp;               <<04253>>53715000
            end;                                               <<04253>>53720000
          if postseries3 then                                  <<04253>>53725000
             begin <<system programs unique to series'33>>     <<04253>>53730000
             i:=-1;                                            <<04253>>53735000
             x:=-8;                                            <<04253>>53740000
             while (i:=i+1) < nsysprog'33 do                   <<04253>>53745000
                begin                                          <<04253>>53750000
                if sysprog'33(x:=x+8) = progname,(8)           <<04253>>53755000
                                   then goto getnewp;          <<04253>>53760000
                end;                                           <<04253>>53765000
             end;  <<system programs unique to series'33>>     <<04253>>53770000
          if seriesii'iii then                                 <<04253>>53775000
             begin <<unique system programs>>                  <<04253>>53780000
             i:=-1;                                            <<04253>>53785000
             x:=-8;                                            <<04253>>53790000
             while (i:=i+1) < nsysprog'2 do                    <<04253>>53795000
                begin                                          <<04253>>53800000
                if sysprog'2(x:=x+8)=progname,(8)              <<04253>>53805000
                                  then goto getnewp;           <<04253>>53810000
                end;                                           <<04253>>53815000
             end;                                              <<04253>>53820000
          i := -1;                                             <<04253>>53825000
          @bdvrtab := @dvrname & lsl(1);                       <<06762>>53830000
          while (i:=i+1)<=hldev do                             <<04253>>53835000
            begin  <<check if non-std driver>>                 <<04253>>53840000
              get'ldev'entries(i);                             <<06762>>53845000
              if bdvrtab = progname,(8)                        <<04267>>53850000
                         then go to getnewp;                   <<04253>>53855000
            end;                                               <<04253>>53860000
          i := -1;                                             <<04253>>53865000
          temp := comm(numadvrs);                              <<07039>>53870000
          x := -8;                                             <<04267>>53875000
          while(i:=i+1)<temp do                                <<04253>>53880000
            begin  <<check if additional cs drivers>>          <<04253>>53885000
            if bcsdvr(x:=x+8)=progname,(8) then goto getnewp;  <<04267>>53890000
            end;                                               <<04253>>53895000
          message(m2609);  <<not a system program>>            <<*8393>>53900000
          if logical(mode) then go reqspc <<interactive>>      <<04253>>53905000
             else quit(1); <<batch>>                           <<04253>>53910000
  getnewp:getstr(@badspc,repname,1,".",26);  <<file name>>     <<04253>>53915000
          move ckrepfile:= "LISTF ";                           <<04253>>53920000
          move ckrepfile(6):= repname,(26);                    <<04253>>53925000
          move ckrepfile(32):= ";$NULL";                       <<04253>>53930000
          move ckrepfile(38):= cr;                             <<04253>>53935000
          error:= 0;                                           <<04253>>53940000
          command(ckrepfile,error,parm);                       <<04253>>53945000
          if error <> 0 then                                   <<04253>>53950000
            begin                                              <<04253>>53955000
            move bmsgbuf:=                                     <<04253>>53960000
              "REPLACEMENT FILE DOES NOT EXIST         ";      <<04253>>53965000
            print(msgbuf,20,%40);                              <<04253>>53970000
            move bmsgbuf:= "NO SYSTEM PROGRAM CHANGE FOR ";    <<04253>>53975000
            move bmsgbuf(29):= progname,(8);                   <<04253>>53980000
            move bmsgbuf(37):= "   ";                          <<04253>>53985000
            print(msgbuf,20,%40);                              <<04253>>53990000
            go to reqspc;                                      <<04253>>53995000
            end;                                               <<04253>>54000000
          add'to'sysprog'chg'table(progname,repname);          <<04253>>54005000
          go to reqspc;                                        <<04253>>54010000
badspc:                                                        <<04253>>54015000
          if logical(mode) then go reqspc;                     <<04253>>54020000
          quit(1);                                             <<04253>>54025000
reqsslc:                                                       <<04253>>54030000
     end;                                                      <<04253>>54035000
$page "             SYSTEM SL CHANGES"                         <<01073>>54040000
$control segment=systemch                                      <<01073>>54045000
     procedure system'sl'ch;                                   <<01073>>54050000
     option privileged,uncallable;                             <<01073>>54055000
     begin                                                     <<01073>>54060000
        integer patchsize;                                     <<01073>>54065000
        switch segsw := reqsegr,reqsega,reqnsll;               <<01073>>54070000
          addpubsys(pslfile);                                           54075000
          pslfnum := fopen(fullname,1,%(2)100110000);                   54080000
  pslerr: if <> then ferror(pslfnum,fullname);                          54085000
          flock(pslfnum,true);                                          54090000
          if <> then goto pslerr;                                       54095000
          fgetinfo(pslfnum,,,,,,,,filecode,,eof,flimit,,,,              54100000
            extsize,numextents);                                        54105000
          if <> then goto pslerr;                                       54110000
          tos := eof;                                                   54115000
          tos := extsize;                                               54120000
          assemble(ldiv);                                               54125000
          if tos<>0 then tos := tos+1;                                  54130000
          initalloc := tos;   <<initial allocation for tempsl>>         54135000
          tslfnum:=fopen(tslfile,2);<<purge job-temp-file>>    <<01.00>>54140000
          fclose(tslfnum,4,0);<<"TEMPSL" from aborted sysdump>><<01.00>>54145000
          tslfnum := fopen(tslfile,,%(2)111010100,,,,,,,flimit,         54150000
            numextents,initalloc,filecode);                             54155000
  tslerr: if <> then ferror(tslfnum,tslfile);                           54160000
  copynext:                                                             54165000
          fread(pslfnum,lbuf,4096);                            <<03604>>54170000
          if > then goto eofread;                                       54175000
          if < then goto pslerr;                                        54180000
          fwrite(tslfnum,lbuf,4096,0);                         <<03604>>54185000
          if <> then goto tslerr;                                       54190000
          goto copynext;                                                54195000
  eofread:fread(pslfnum,lbuf,128);                                      54200000
          if > then goto copydone;                                      54205000
          if < then goto pslerr;                                        54210000
          fwrite(tslfnum,lbuf,128,0);                                   54215000
          if <> then goto tslerr;                                       54220000
          goto eofread;                                                 54225000
  copydone:                                                             54230000
          fclose(pslfnum,0,0);                                          54235000
          if <> then goto pslerr;                                       54240000
          fclose(tslfnum,2,0);                                          54245000
          if <> then goto tslerr;                                       54250000
          tempslsaved := true;                                          54255000
                                                               <<04253>>54260000
                                                               <<04253>>54265000
                                                               <<04253>>54270000
                                                               <<04253>>54275000
          add'to'sysprog'chg'table(pslfile,tslfile);           <<04253>>54280000
                                                               <<04253>>54285000
                                                               <<04253>>54290000
                                                               <<04253>>54295000
          pin := 0;                                                     54300000
          usllen := 0;                                                  54305000
          segmenter(pin,usesl,segerror,,,,,,,,,tslfile);       <<00629>>54310000
                     <<inform segmenter of sl file>>                    54315000
          if <> then                                                    54320000
            begin                                                       54325000
  segerr:     if > then                                                 54330000
              if segerror = 1 then <<recoverable soft error>>  <<s7757>>54335000
                 go reqsegc                                    <<s7757>>54340000
              else if segerror = 0 and logical(mode) then      <<s7757>>54345000
                 go reqsegd;<<interactive>>                    <<s7757>>54350000
              tos := 0;                                                 54355000
              tos := segerror;                                          54360000
              tos := 10;                                                54365000
              move binbuf := segerrmess,(18),2;                         54370000
              x := ascii(*,*,*);                                        54375000
              print(inbuf,-x-18,0);                                     54380000
              purgetempsl;                                              54385000
            end;                                                        54390000
          tos := @reqsegd;                                              54395000
          getyesno(*,m2601);     <<list system modules?>>      <<*8393>>54400000
          segmenter(pin,listsl,segerror,,,1);  <<list sl file>>         54405000
          if <> then goto segerr;                                       54410000
  reqsegd:i := -1;   <<delete mode>>                                    54415000
          tos := @reqsegr;                                              54420000
          getyesno(*,m2604);   <<delete segment?>>             <<*8393>>54425000
  reqsegc:if i<0 then message(-m2605) else message(-m2602);    <<*8393>>54430000
          patchsize := 0;  <<default no patch>>                <<01194>>54435000
          readinput;                                                    54440000
          scan bpinbuf while blank,1;                                   54445000
          if carry then                                                 54450000
            begin       <<carriage return input>>                       54455000
              del;                                                      54460000
              goto segsw(i+1);                                          54465000
  reqsega:    i := i+1;                                                 54470000
              tos := @reqnsll;                                          54475000
              getyesno(*,m2606);   <<add segment?>>            <<*8393>>54480000
              go reqsegc;                                               54485000
  reqsegr:    i := i+1;                                                 54490000
              tos := @reqsega;                                          54495000
              getyesno(*,m2607);   <<replace segment?>>        <<*8393>>54500000
              go reqsegc;                                               54505000
            end;                                                        54510000
          @bpinbuf := tos;    <<update buffer pointer>>                 54515000
          segment(15) := " ";                                           54520000
          tos := 0;                                                     54525000
          tos := @reqsegc;                                              54530000
          tos := @segment;                                              54535000
          if i<0 then getstr(*,*,1,"'",15)                              54540000
          else                                                          54545000
            begin                                                       54550000
              getstr(*,*,0,"'",15);                                     54555000
              temp := 1;                                                54560000
              tos := 0;                                                 54565000
              tos := @reqsegc;                                          54570000
              m := getstr(*,fullname,-1,".",26);                        54575000
              if < then                                                 54580000
                begin   <<comma follows>>                               54585000
                  scan bpinbuf while blank,1;                           54590000
                  if carry then                                         54595000
                    begin                                               54600000
  acerr:              del;                                              54605000
  acerr1:             message(m2453);                          <<*8393>>54610000
                      if not logical(mode) then quit(1);<<batch<<00458>>54615000
                      go reqsegc;                                       54620000
                    end;                                                54625000
                  if bps0="S" or bps0="s" then                 <<d.005>>54630000
                     temp:=%20001 <<sys seg>>                  <<d.005>>54635000
                  else if bps0="C" or bps0="c" then            <<d.005>>54640000
                     temp:=%60001 <<core res>>                 <<d.005>>54645000
                  else if bps0="P" or bps0="p" then            <<d.005>>54650000
                     temp:=%100001 <<alloc>>                   <<d.005>>54655000
                  else if bps0="," then tos:=tos-1             <<00629>>54660000
                  else goto acerr;                                      54665000
                  tos := tos+1;                                         54670000
                  scan * while blank,1;                        <<00629>>54675000
                  if nocarry then                              <<00629>>54680000
                     begin                                     <<00629>>54685000
                     if bps0 <> "," then go acerr;             <<00629>>54690000
                     @bpinbuf := tos+1;                        <<00629>>54695000
                     patchsize := inval(@acerr1,",");          <<00629>>54700000
                     if <= then go acerr1;                     <<00629>>54705000
                     end                                       <<00629>>54710000
                  else                                         <<00629>>54715000
                     del;                                      <<00629>>54720000
                end;                                                    54725000
              fullname(m) := " ";  <<filename terminator>>              54730000
            end;                                                        54735000
          if i>=0 then   <<rep or add>>                        <<00458>>54740000
            begin                                                       54745000
              if usllen<>m or uslfile<>fullname,(usllen) then           54750000
                begin  <<new usl specification>>                        54755000
                  move uslfile := fullname,(usllen:=m);                 54760000
                  segmenter(pin,useusl,segerror,,,,,,,,,       <<00629>>54765000
                    fullname);                                          54770000
                  if <> then goto segerr;                               54775000
                                                                        54780000
                end;                                                    54785000
            end;                                               <<00458>>54790000
          if i <= 0 then <<del or rep>>                        <<00458>>54795000
             begin                                             <<00458>>54800000
             segmenter(pin,purgesl,segerror,,,,,,,segment);    <<00629>>54805000
             if <> then goto segerr;                           <<00458>>54810000
             end;                                              <<00458>>54815000
          if i >= 0 then <<rep or add>>                        <<00458>>54820000
             begin                                             <<00458>>54825000
             segmenter(pin,addsl,segerror,,,temp,,,patchsize,, <<00629>>54830000
                segment);                                      <<00629>>54835000
             if <> then                                        <<00458>>54840000
                begin                                          <<00458>>54845000
                push( status );  <<save condcode>>             <<00458>>54850000
                if i=0 and segerror<>1 then  << replace/warn >><<01592>>54855000
                   begin                                       <<00458>>54860000
                   move binbuf := "**WARNING** SEGMENT ",2;    <<00458>>54865000
                   scan segment until " ,",1;                  <<00458>>54870000
                   x := tos-@segment;                          <<00458>>54875000
                   move * := segment,(x),2;                    <<00458>>54880000
                   move * := " PURGED!",2;                     <<00458>>54885000
                   x := tos-@binbuf;                           <<00458>>54890000
                   print( inbuf,-x,0);                         <<00458>>54895000
                   end;                                        <<00458>>54900000
                set( status );  <<replace condcode>>           <<00458>>54905000
                goto segerr;                                   <<00458>>54910000
                end;                                           <<00458>>54915000
             end;                                              <<00458>>54920000
          go reqsegc;                                                   54925000
                                                                        54930000
 reqnsll:if yesanswer(m2601) then                              <<*8393>>54935000
         begin               << list system modules >>         <<01073>>54940000
          segmenter(pin,listsl,segerror,,,1);  <<list sl file>>         54945000
          if <> then goto segerr;                                       54950000
         end;                                                  <<01073>>54955000
  segexit:    segmenter(pin,exitseg,segerror);                          54960000
          if <> then goto segerr;                              <<00598>>54965000
     end;                                                      <<01073>>54970000
$page "             BUILD THE FILE MPECHECK"                   <<01073>>54975000
$control segment=mpecheck                                      <<01073>>54980000
     procedure build'mpecheck;                                 <<01073>>54985000
     option privileged,uncallable;                             <<01073>>54990000
     begin                                                     <<01073>>54995000
define                                                         <<01073>>55000000
      ba = own byte array#; << byte array definition >>        <<01073>>55005000
      ba f'name(0:8);   << temp. buffer for pub.sys file >>    <<01073>>55010000
      ba a'(0:44):=                                            <<01073>>55015000
      "BUILD SCR;DISC=2000,16;REC=-12,,F,ASCII;TEMP ";         <<01073>>55020000
      ba b'(0:20):=                                            <<01073>>55025000
      "FILE SCR=SCR,OLDTEMP "; << file declaration >>          <<01073>>55030000
      ba c'(0:20):="LISTF @.PUB.SYS;*SCR ";  <<listf cmd>>     <<01073>>55035000
      ba d'(0:3):="SCR ";                                      <<01073>>55040000
      ba e'(0:9):="PURGE SCR ";                                <<01073>>55045000
      ba cr(0:1):=%15,%0;                                      <<01073>>55050000
        ba chekfile(0:8):=                                     <<01073>>55055000
        "MPECHECK ";    << checksum file >>                    <<01073>>55060000
double dcksum;          << double checksum word >>             <<01073>>55065000
                                                               <<01073>>55070000
integer array                                                  <<01073>>55075000
        cksum (*) = dcksum; << integer addr.>>                 <<01073>>55080000
                                                               <<01073>>55085000
logical array                                                  <<01073>>55090000
        bufl(*)=lbuf;   << logical working buffer >>           <<01073>>55095000
                        << lbuf=integer array (0:4000) >>      <<01073>>55100000
                                                               <<01073>>55105000
        byte array bybuf(*)=bufl(512);  <<byte buffer addr.>>  <<01073>>55110000
                                                               <<01073>>55115000
        byte array bbuf(*)=bufl(384);<<byte addr/outpt buffer>><<01073>>55120000
                                                               <<01073>>55125000
byte pointer bufp;      << byte pointer >>                     <<01073>>55130000
                                                               <<01073>>55135000
integer chekfnum,       << file no. for mpecheck >>            <<01073>>55140000
        ii,             << scr word >>                         <<01073>>55145000
        f'code,         << file code >>                        <<01073>>55150000
        rec'cnt,        << record count >>                     <<01073>>55155000
        jj,             << counter >>                          <<01073>>55160000
        sl'wd,          << seg. length count >>                <<01073>>55165000
        seg'len,        << segment length >>                   <<01073>>55170000
        i1,             << command intr. parm >>               <<01073>>55175000
        i2,             << commend intr. parm >>               <<01073>>55180000
        fnscr,          << file # for scr file >>              <<01073>>55185000
        fnsys,          << system file # >>                    <<01073>>55190000
        space:=%20040,  << temporary >>                        <<01073>>55195000
        ix40:=40,                                              <<01073>>55200000
        ix79:=79,                                              <<01073>>55205000
        ix128:=128,                                            <<01073>>55210000
        ix255:=255,                                            <<01073>>55215000
        ix256:=256,                                            <<01073>>55220000
        w'eof:=6,                                              <<01073>>55225000
        p'file:=4,                                             <<01073>>55230000
        entry'cnt;      << seg entry count >>                  <<01073>>55235000
                                                               <<01073>>55240000
logical ns'sum,         << # of sections >>                    <<01073>>55245000
        nrt'sum,        << # reference table entries >>        <<01073>>55250000
        frtl'sum,       << s.a. of free r.t.entry list >>      <<01073>>55255000
        nseg'sum,       << # segments >>                       <<01073>>55260000
        el'sum,         << extent length(in records)>>         <<01073>>55265000
        fl'sum,         << file length(in records)>>           <<01073>>55270000
        s'rec,          << # of seg. records >>                <<01073>>55275000
        saddr,          << temp. starting rec. addr. >>        <<01073>>55280000
        stt'num,        << loc. of map array length >>         <<01073>>55285000
        l'seg'len,      << logical seg. length >>              <<01073>>55290000
        sum'parm:=9;    << fcontrol parm >>                    <<01073>>55295000
                                                               <<01073>>55300000
logical dpan'seg'len;   << length+stt for dpan >>              <<d8876>>55305000
double  drecnum;        << temporary rec # >>                  <<01073>>55310000
                                                               <<01073>>55315000
equate                                                         <<01073>>55320000
        eqfl'=1,        << loc. file length(in rec)>>          <<01073>>55325000
        eqel'=2,        << loc. extent length(in rec)>>        <<01073>>55330000
        eqnseg'=4,      << loc. # of segments >>               <<01073>>55335000
        eqfrtl'=7,      << loc. s.a. of free r.t. entry list>> <<01073>>55340000
        eqnrt'=9,       << loc. ref.table entries >>           <<01073>>55345000
        eqns'=11,       << loc. # of sections >>               <<01073>>55350000
        indx1=1,                                               <<01073>>55355000
        indx4=4,                                               <<01073>>55360000
        indx20=20,                                             <<01073>>55365000
        indx25=25,                                             <<01073>>55370000
        indx28=28,                                             <<01073>>55375000
        indx32=32,                                             <<01073>>55380000
        indx35=35,                                             <<01073>>55385000
        indx127=127,                                           <<01073>>55390000
        indx128=128,                                           <<01073>>55395000
        sumsegl'=0,     << seg. length >>                      <<01073>>55400000
        sumsegad'=1,    << seg. address rec # >>               <<01073>>55405000
        sumsegno'=2,    << #rec=seg + external list >>         <<01073>>55410000
        sumentry'=3,    << # entry points >>                   <<01073>>55415000
        sysseg'=1,      << loc. of # of segments/file >>       <<01073>>55420000
        syscode'=4,     << starting code segment rec# >>       <<01073>>55425000
        indx3=3,        << multiple index counter >>           <<01073>>55430000
        indx8=8,        << multiple index counter >>           <<01073>>55435000
        indx256=256,    << start index value >>                <<01073>>55440000
        indx384=384,    << end   index value >>                <<01073>>55445000
        indx512=512,    << buffer start index >>               <<01073>>55450000
        fname'ptr=8;    << file name address index >>          <<01073>>55455000
                                                               <<01073>>55460000
<<*******************************************************>>    <<00598>>55465000
                                                               <<00598>>55470000
     addpubsys(chekfile);   << cancatenate pub.sys to >>       <<00598>>55475000
                            << mpecheckfile.          >>       <<00598>>55480000
      chekfnum:=fopen(fullname,%2005,%240);                    <<00740>>55485000
     if = then              << mpecheck exists >>              <<00598>>55490000
     begin                                                     <<00598>>55495000
      fgetinfo(chekfnum,,,,,,,,f'code);<<get filecode>>        <<00598>>55500000
      if <> then ferror(chekfnum,fullname);<<dump err>>        <<00598>>55505000
      if f'code <> -1023 then                                  <<00598>>55510000
      begin                                                    <<00598>>55515000
       fclose(chekfnum,4,0); << purge file >>                  <<00598>>55520000
       if <> then ferror(chekfnum,fullname);<<dump err>>       <<00598>>55525000
       go open'check;                                          <<00598>>55530000
      end; << end: filecode <> -1023 >>                        <<00598>>55535000
                                                               <<00598>>55540000
      fclose(chekfnum,0,0); << leave it alone >>               <<00598>>55545000
      if <> then ferror(chekfnum,fullname);                    <<00598>>55550000
      go ext';              << generate checksum for sysprog>> <<00598>>55555000
     end                                                       <<00598>>55560000
     else                                                      <<00598>>55565000
     begin   <<mpecheck file is non-existent>>                 <<00598>>55570000
      fcheck(chekfnum,ii);  << find out what's wrong >>        <<00598>>55575000
                                                               <<00598>>55580000
      << **** test for non-existent permanent file **** >>     <<00598>>55585000
                                                               <<00598>>55590000
      if ii <> 52 then ferror(chekfnum,fullname);              <<00598>>55595000
                                                               <<00598>>55600000
      <<***** mpecheck file non-existent *****>>               <<00598>>55605000
open'check:                                                    <<00598>>55610000
       chekfnum:=fopen(fullname,%2004,%144,,,,,,               <<00740>>55615000
                       ,8000d,,,1023);                         <<00740>>55620000
      if <> then ferror(chekfnum,fullname);                    <<00598>>55625000
                                                               <<00598>>55630000
      <<******************************************>>           <<00598>>55635000
      <<**** write out update level, fix level, **>>           <<00598>>55640000
      <<**** version number onto mpecheck file. **>>           <<00598>>55645000
      <<******************************************>>           <<00598>>55650000
                                                               <<00598>>55655000
      move bbuf:=" ";  << blank out >>                         <<00598>>55660000
      move bbuf(1):=bbuf,(71); << output buffer >>             <<00598>>55665000
                                                               <<00598>>55670000
      ii:=-1;  << initialize loop counter >>                   <<00598>>55675000
      while (ii:=ii+1) < 3 do                                  <<00598>>55680000
      begin                                                    <<00598>>55685000
       ascii(versid(ii),8,bbuf(ii*7));                         <<00598>>55690000
      end;                                                     <<00598>>55695000
                                                               <<00598>>55700000
      fwrite(chekfnum,bufl(384),11,0); <<write it>>            <<00598>>55705000
      if <> then ferror(chekfnum,fullname);                    <<00598>>55710000
                                                               <<00598>>55715000
                                                               <<00598>>55720000
      << *********************************************>>       <<00598>>55725000
      << *********************************************>>       <<00598>>55730000
      << ****                                     ****>>       <<00598>>55735000
      << **** begin stripping sl file for check-  ****>>       <<00598>>55740000
      << **** sum calculation.                    ****>>       <<00598>>55745000
      << ****                                     ****>>       <<00598>>55750000
      << *********************************************>>       <<00598>>55755000
      << *********************************************>>       <<00598>>55760000
                                                               <<00598>>55765000
      addpubsys(pslfile);   << cancatenate pub.sys to >>       <<00598>>55770000
                            << sl                     >>       <<00598>>55775000
      pslfnum:=fopen(fullname,1,%(2)100110000);<< open >>      <<00598>>55780000
                                               << sl  >>       <<00598>>55785000
      if <> then ferror(pslfnum,fullname);                     <<00598>>55790000
      flock(pslfnum,true);  << lock sl while attempting >>     <<00598>>55795000
                            << to read                  >>     <<00598>>55800000
      if <> then ferror(pslfnum,fullname); <<error>>           <<00598>>55805000
                                                               <<00598>>55810000
      drecnum:=0d;          << initialize rec # >>             <<00598>>55815000
      freaddir(pslfnum,bufl,ix128,drecnum);<<read rec #0>>     <<00598>>55820000
      if > then go eofsum;  << eof reached >>                  <<00598>>55825000
      if < then ferror(pslfnum,fullname);<<other error>>       <<00598>>55830000
                                                               <<00598>>55835000
      fl'sum:=bufl(eqfl');  << sl file length >>               <<00598>>55840000
      el'sum:=bufl(eqel');  << sl extent length >>             <<00598>>55845000
      nseg'sum:=bufl(eqnseg');<< # of segments >>              <<00598>>55850000
      frtl'sum:=bufl(eqfrtl');<< free r.t. entry list>>        <<00598>>55855000
      nrt'sum:=bufl(eqnrt');  << ref.table entries >>          <<00598>>55860000
      ns'sum:=bufl(eqns');    << # of sections >>              <<00598>>55865000
                                                               <<00598>>55870000
      freaddir(pslfnum,bufl,ix128,drecnum+1d);<<read rec 1>>   <<00598>>55875000
      if > then go eofsum;   << eof reached >>                 <<00598>>55880000
      if < then ferror(pslfnum,fullname);<< other error>>      <<00598>>55885000
                                                               <<00598>>55890000
      ii:=-1;  << initialize buffer index >>                   <<00598>>55895000
      while (lbuf(ii:=ii+1)) <> 0 do                           <<00598>>55900000
      begin                                                    <<00598>>55905000
       freaddir(pslfnum,bufl(indx128),ix128,double(lbuf(ii))); <<00598>>55910000
       if < then ferror(pslfnum,fullname);                     <<00598>>55915000
       if > then go eofsum;  << reached eof>>                  <<00598>>55920000
       entry'cnt:=indx3;                                       <<00598>>55925000
       while (entry'cnt:=entry'cnt+1) < indx8 do               <<00598>>55930000
       begin                                                   <<00598>>55935000
        if not(bufl(indx32*entry'cnt+sumentry').(0:1)) and     <<00598>>55940000
        bufl(indx32*entry'cnt+sumentry').(6:1) then            <<00598>>55945000
        begin  << if segment non-deleted and is a mpe segment>><<00598>>55950000
         sl'wd:=0;  << initialize seg.length word count>>      <<00598>>55955000
         rec'cnt:=-1;  << initialize counter >>                <<00598>>55960000
         @bufp:=@bufl(indx32*entry'cnt+fname'ptr)&lsl(1);      <<03704>>55965000
         seg'len:=lbuf(indx32*entry'cnt+sumsegl').(2:14);      <<00598>>55970000
         s'rec:=logical(seg'len+indx127)&lsr(7);<<# of recs>>  <<00598>>55975000
         saddr:=lbuf(indx32*entry'cnt+sumsegad');<<save s.a>>  <<00598>>55980000
         freaddir(pslfnum,bufl(indx256),ix128,double(saddr)+   <<00598>>55985000
                  double(s'rec-1));<<get rec incl.stt>>        <<00598>>55990000
                                   <<length.         >>        <<00598>>55995000
         if > then go eofsum;  <<reached eof>>                 <<00598>>56000000
         if <  then                                            <<00598>>56005000
          begin                                                <<00598>>56010000
           addpubsys(pslfile);  << cancatenate pub.sys >>      <<00598>>56015000
           ferror(pslfnum,fullname); <<dump file id.>>         <<00598>>56020000
          end;                                                 <<00598>>56025000
                                                               <<00598>>56030000
         stt'num:=logical(seg'len)-(s'rec-1)&lsl(7)-1;<<get>>  <<00598>>56035000
                                       <<segment element>>     <<00598>>56040000
    dpan'seg'len:=logical(seg'len);  << save for mpecheck >>   <<d8876>>56045000
         seg'len:=logical(seg'len)-bufl(stt'num+      <<get>>  <<00598>>56050000
                  indx256).(8:8)-1;  << stt length >>          <<00598>>56055000
                                                               <<00598>>56060000
         dcksum:=0d;  << initialize checksum value>>           <<00598>>56065000
         while (rec'cnt:=rec'cnt+1) < integer(s'rec) do        <<00598>>56070000
         begin                                                 <<00598>>56075000
          freaddir(pslfnum,bufl(indx256),ix128,double(         <<00598>>56080000
          lbuf(indx32*entry'cnt+sumsegad'))+double(rec'cnt));  <<00598>>56085000
          if > then go eofsum;  << eof reached >>              <<00598>>56090000
          if < then ferror(pslfnum,fullname);<< other >>       <<00598>>56095000
                                             << error >>       <<00598>>56100000
          jj:=indx256;  << initialize index value >>           <<00598>>56105000
          do                                                   <<00598>>56110000
           begin                                               <<00598>>56115000
            dcksum:=dcksum+double(bufl(jj));<<gen. checksum >> <<00598>>56120000
            tos:=0;  << zero stack >>                          <<00598>>56125000
            tos:=cksum;                                        <<00598>>56130000
            tos:=cksum(1);                                     <<00598>>56135000
            assemble ( or );                                   <<00598>>56140000
            dcksum:=tos;                                       <<00598>>56145000
            if (sl'wd:=sl'wd+1) = seg'len then go new'rec;     <<00598>>56150000
           end                                                 <<00598>>56155000
          until (jj:=jj+1) = indx384;     << buff end >>       <<00598>>56160000
         end;    << end: while rec'cnt >>                      <<00598>>56165000
new'rec:                                                       <<00598>>56170000
                                                               <<00598>>56175000
         move bbuf:=" ";                                       <<00598>>56180000
         move bbuf(indx1):=bbuf,(ix255);     << blank output >><<00598>>56185000
                                   << buffer           >>      <<00598>>56190000
         scan bufp until space,1;  <<look for space>>          <<00598>>56195000
         jj:=tos - @bufp;  << get delta length >>              <<00598>>56200000
         move bbuf:=bufp,(jj); << move file name >>            <<00598>>56205000
         ascii(dpan'seg'len,8,bbuf(indx25));<< seglen + stt >> <<d8876>>56210000
         ascii(logical(cksum(1)),8,bbuf(indx35));<<checksum >> <<00598>>56215000
                                                               <<00598>>56220000
         <<*********************************************>>     <<00598>>56225000
         <<*** to insert mod/product id. later        ***>>    <<00598>>56230000
         <<*********************************************>>     <<00598>>56235000
                                                               <<00598>>56240000
         fwrite(chekfnum,bufl(indx384),ix128,0);<< write >>    <<00598>>56245000
                                           << mpecheck >>      <<00598>>56250000
                                           << file.    >>      <<00598>>56255000
         if <> then                                            <<00598>>56260000
          begin                                                <<00598>>56265000
           addpubsys(chekfile); << cancatenate pub.sys >>      <<00598>>56270000
           ferror(chekfnum,fullname);                          <<00598>>56275000
          end;                                                 <<00598>>56280000
         end;  << end: if seg. not deleted and mpe seg >>      <<00598>>56285000
        end; << end: while entry'cnt >>                        <<00598>>56290000
       end; << end: while ii-buffer index >>                   <<00598>>56295000
eofsum:                                                        <<00598>>56300000
       funlock(pslfnum); << unlock the file >>                 <<00598>>56305000
       if <> then                                              <<00598>>56310000
        begin                                                  <<00598>>56315000
         addpubsys(pslfile); << can pub.sys >>                 <<00598>>56320000
         ferror(pslfnum,fullname);                             <<00598>>56325000
        end;                                                   <<00598>>56330000
                                                               <<00598>>56335000
       fclose(pslfnum,0,0); << close sl file >>                <<00598>>56340000
       if <> then                                              <<00598>>56345000
        begin                                                  <<00598>>56350000
         addpubsys(pslfile); << cancatenate pub.sys >>         <<00598>>56355000
         ferror(pslfnum,fullname);                             <<00598>>56360000
        end;                                                   <<00598>>56365000
                                                               <<00598>>56370000
        << ******    good - continue   ****** >>               <<00598>>56375000
                                                               <<00598>>56380000
        << continue >>                                         <<00598>>56385000
        move a'(44):=cr,(1);  << build cmd >>                  <<00598>>56390000
        move b'(20):=cr,(1);  << file declaration >>           <<00598>>56395000
        move c'(20):=cr,(1);  << listf cmd >>                  <<00598>>56400000
        move e'(9) :=cr,(1);  << purge cmd >>                  <<00598>>56405000
                                                               <<00598>>56410000
        command(e',i1,i2);if <> then quit(0);<<purge cmd>>     <<00598>>56415000
        command(a',i1,i2);if <> then quit(1);<<build cmd>>     <<00598>>56420000
        command(b',i1,i2);if <> then quit(2);<<file declar>>   <<00598>>56425000
        command(c',i1,i2);if <> then quit(3);<<listf cmd>>     <<00598>>56430000
                                                               <<00598>>56435000
                                                               <<00598>>56440000
   fnscr:=fopen(d',3,,-80,,,,1,,300d,1,1);                     <<00598>>56445000
   if <> then                                                  <<00598>>56450000
    begin                                                      <<00598>>56455000
     addpubsys(d');  << cancatenate pub.sys >>                 <<00598>>56460000
     ferror(fnscr,fullname); << dump file id. >>               <<00598>>56465000
    end;  << end: cc unequal >>                                <<00598>>56470000
   drecnum:=2d;   << initialize record # >>                    <<00598>>56475000
   move bybuf:=%377;  << make it <> space >>                   <<00598>>56480000
   while bybuf <> " " do                                       <<00598>>56485000
   begin                                                       <<00598>>56490000
    move bybuf:=" ";  << blank out >>                          <<00598>>56495000
    move bybuf(indx1):=bybuf,(ix79); << buffer >>              <<00598>>56500000
    drecnum:=drecnum+1d;  <<increment record counter>>         <<00598>>56505000
    freaddir(fnscr,bufl(indx512),ix40,drecnum);<<rd filname>>  <<00598>>56510000
    if > then go eof'scr;  << reached eof on scr >>            <<00598>>56515000
    if < then                                                  <<00598>>56520000
     begin                                                     <<00598>>56525000
      addpubsys(d');  << cancatenate pub.sys >>                <<00598>>56530000
      ferror(fnscr,fullname); << dump file id. >>              <<00598>>56535000
     end; << end: cc less than >>                              <<00598>>56540000
                                                               <<00598>>56545000
   if bybuf = " " then go eof'scr; <<exit finished>>           <<00598>>56550000
   move f'name:=" "; <<blank out file name >>                  <<00598>>56555000
   move f'name(1):=f'name,(8);                                 <<00598>>56560000
   move f'name:=bybuf while an;  <<get filname>>               <<00598>>56565000
                                                               <<00598>>56570000
   addpubsys(f'name);  << cancatenate pub.sys >>               <<00598>>56575000
   fnsys:=fopen(fullname,1,%(2)100110000);<<open sys file>>    <<00598>>56580000
   if fnsys = 0 then go ext1';                                 <<00598>>56585000
                                                               <<00598>>56590000
   fgetinfo (fnsys,,,,,,,,f'code); << get file code >>         <<00598>>56595000
   if <> then ferror(fnsys,fullname); <<dump file id>>         <<00598>>56600000
                                                               <<00598>>56605000
   if f'code <> 1029 then go f'close; <<close files>>          <<00598>>56610000
   flock(fnsys,true);  << lock sys. file while accessing >>    <<00598>>56615000
   if <> then ferror(fnsys,fullname);<<dump file id.>>         <<00598>>56620000
                                                               <<00598>>56625000
                                                               <<00598>>56630000
   <<***********************************************>>         <<00598>>56635000
   <<***********************************************>>         <<00598>>56640000
   <<*** strip down system program file and      ***>>         <<00598>>56645000
   <<*** generate checksum code.                 ***>>         <<00598>>56650000
   <<***********************************************>>         <<00598>>56655000
   <<***********************************************>>         <<00598>>56660000
                                                               <<00598>>56665000
   freaddir(fnsys,bufl,ix256,0d);<<read 2 recs at rec# 0>>     <<00598>>56670000
   if > then go eof'sys;   << eof reached on sys. file >>      <<00598>>56675000
   if < then                                                   <<00598>>56680000
   begin                                                       <<00598>>56685000
    addpubsys(f'name);  << cancatenate pub.sys >>              <<00598>>56690000
    ferror(fnsys,fullname);<< dump file id. >>                 <<00598>>56695000
   end; << end: cc less than >>                                <<00598>>56700000
                                                               <<00598>>56705000
   l'seg'len:=0;  << initialize seg.len count >>               <<00598>>56710000
   dcksum:=0d;    << initialize checksum value >>              <<00598>>56715000
                                                               <<00598>>56720000
   nseg'sum:=bufl(indx1);<<# of segs. in prog. file>>          <<00598>>56725000
   saddr:=bufl(indx4);   <<starting code seg. addr.>>          <<00598>>56730000
   ii:=-1;           <<initialize seg. counter >>              <<00598>>56735000
   while (ii:=ii+1) < integer(nseg'sum) do                     <<00598>>56740000
   begin                                                       <<00598>>56745000
    seg'len:=bufl(indx28+(nseg'sum+1)&lsr(1)+                  <<00598>>56750000
                 logical(ii)).(2:14);                          <<00598>>56755000
    s'rec:=logical(seg'len+indx127)&lsr(7);<<# of recs>>       <<00598>>56760000
    ns'sum:=s'rec;  << save # of records >>                    <<00598>>56765000
    freaddir(fnsys,bufl(indx256),ix128,double(saddr)+          <<00598>>56770000
             double(s'rec-1)); <<read rec incl.stt>>           <<00598>>56775000
    if > then go eof'sys; <<eof reached on sys prog.file>>     <<00598>>56780000
    if < then                                                  <<00598>>56785000
     begin                                                     <<00598>>56790000
      addpubsys(f'name); <<cancatenate pub.sys>>               <<00598>>56795000
      ferror(fnsys,fullname);<< dump file id. >>               <<00598>>56800000
     end; <<end: cc less than >>                               <<00598>>56805000
                                                               <<00598>>56810000
   stt'num:=logical(seg'len)-(s'rec-1)&lsl(7)-1;<<len.ele>>    <<00598>>56815000
   dpan'seg'len := logical(seg'len);  << save for mpecheck >>  <<d8876>>56820000
   seg'len:=logical(seg'len)-bufl(stt'num+indx256).(8:8)-1;    <<00598>>56825000
   tos:=l'seg'len;  << load accumulative seg. length >>        <<00598>>56830000
   tos:=dpan'seg'len;    << sum the true seg length >>         <<d8876>>56835000
   assemble ( ladd ); << do a logicall add >>                  <<00598>>56840000
   l'seg'len:=tos;  << save accumulative seg. length >>        <<00598>>56845000
   sl'wd:=0;  << initialize code word counter >>               <<00598>>56850000
   s'rec:=logical(seg'len+indx127)&lsr(7); << # of records >>  <<00598>>56855000
   rec'cnt:=-1; << initialize record count >>                  <<00598>>56860000
   while (rec'cnt:=rec'cnt+1) < integer(s'rec) do              <<00598>>56865000
   begin                                                       <<00598>>56870000
    freaddir(fnsys,bufl(indx256),ix128,double(saddr)+          <<00598>>56875000
             double(rec'cnt)); << read code seg. record >>     <<00598>>56880000
    if > then go eof'sys; <<reached eof on sys. file>>         <<00598>>56885000
    if < then                                                  <<00598>>56890000
     begin                                                     <<00598>>56895000
      addpubsys(f'name); <<cancatenate pub.sys>>               <<00598>>56900000
      ferror(fnsys,fullname); <<dump file id.>>                <<00598>>56905000
     end;                                                      <<00598>>56910000
    jj:=indx256; <<initialize index value>>                    <<00598>>56915000
    do                                                         <<00598>>56920000
     begin                                                     <<00598>>56925000
      dcksum:=dcksum+double(bufl(jj)); <<gen.checksum>>        <<00598>>56930000
      tos:=0;                                                  <<00598>>56935000
      tos:=cksum;                                              <<00598>>56940000
      tos:=cksum(1);                                           <<00598>>56945000
      assemble ( or );                                         <<00598>>56950000
      dcksum:=tos;                                             <<00598>>56955000
      if (sl'wd:=sl'wd+1) = seg'len then go sys'rec;           <<00598>>56960000
     end                                                       <<00598>>56965000
    until (jj:=jj+1) = indx384;    <<entire record>>           <<00598>>56970000
   end;  << end: while rec'cnt >>                              <<00598>>56975000
sys'rec:                                                       <<00598>>56980000
   saddr:=saddr + ns'sum; <<computes next starting rec>>       <<00598>>56985000
                          <<address.                  >>       <<00598>>56990000
                                                               <<00598>>56995000
  end;  << end: while ii-segment counter >>                    <<00598>>57000000
  <<**********************************************>>           <<00598>>57005000
  <<**********************************************>>           <<00598>>57010000
  <<**** write out filename,segment length, and **>>           <<00598>>57015000
  <<**** checksum.                              **>>           <<00598>>57020000
  <<**********************************************>>           <<00598>>57025000
  <<**********************************************>>           <<00598>>57030000
                                                               <<00598>>57035000
  move bbuf:=" ";                                              <<00598>>57040000
  move bbuf(1):=bbuf,(ix255);     <<blank o/p buffer>>         <<00598>>57045000
  move bbuf:=f'name while an;<<move sys.file name>>            <<00598>>57050000
  ascii(l'seg'len,8,bbuf(indx25)); << dump seg. length >>      <<00598>>57055000
  ascii(logical(cksum(1)),8,bbuf(indx35));<<cksum>>            <<00598>>57060000
                                                               <<00598>>57065000
  fwrite(chekfnum,bufl(indx384),ix128,0);<<write record>>      <<00598>>57070000
  if <> then                                                   <<00598>>57075000
   begin                                                       <<00598>>57080000
    addpubsys(chekfile); <<can pub.sys>>                       <<00598>>57085000
    ferror(chekfnum,fullname); <<dump file id.>>               <<00598>>57090000
   end;                                                        <<00598>>57095000
                                                               <<00598>>57100000
eof'sys:                                                       <<00598>>57105000
   funlock(fnsys); << unlock sys. file >>                      <<00598>>57110000
   if <> then                                                  <<00598>>57115000
    begin                                                      <<00598>>57120000
     addpubsys(f'name); <<can pub.sys>>                        <<00598>>57125000
     ferror(fnsys,fullname); <<dump file id.>>                 <<00598>>57130000
    end;                                                       <<00598>>57135000
f'close:                                                       <<00598>>57140000
   fclose(fnsys,0,0); <<close sys. file>>                      <<00598>>57145000
   if <> then                                                  <<00598>>57150000
    begin                                                      <<00598>>57155000
     addpubsys(f'name);                                        <<00598>>57160000
     ferror(fnsys,fullname);                                   <<00598>>57165000
    end;                                                       <<00598>>57170000
ext1':                                                         <<00598>>57175000
 end;  << end: while bybuf <> space >>                         <<00598>>57180000
                                                               <<00598>>57185000
eof'scr:                                                       <<00598>>57190000
   fclose(fnscr,p'file,0); << purge scratch file >>            <<00598>>57195000
   if <> then                                                  <<00598>>57200000
   begin                                                       <<00598>>57205000
    addpubsys(d'); << can pub.sys >>                           <<00598>>57210000
    ferror(fnscr,fullname); <<dump file id.>>                  <<00598>>57215000
   end;                                                        <<00598>>57220000
                                                               <<00598>>57225000
   fclose(chekfnum,1,1); << close mpecheck file >>             <<00598>>57230000
   if <> then                                                  <<00598>>57235000
    begin                                                      <<00598>>57240000
     addpubsys(chekfile);                                      <<00598>>57245000
     ferror(chekfnum,fullname);                                <<00598>>57250000
    end;                                                       <<00598>>57255000
                                                               <<00598>>57260000
 end;  <<end: mpecheck file non-existent>>                     <<00598>>57265000
ext':                                                          <<00598>>57270000
     end;                                                      <<01073>>57275000
$page "FORMAT CALENDAR DATE INTO ASCII STRING"                 <<*8393>>57280000
$control segment=sysdump                                       <<*8393>>57285000
procedure format'date(dump'date);                              <<*8393>>57290000
   value dump'date;                                            <<*8393>>57295000
   logical dump'date;                                          <<*8393>>57300000
   option privileged,uncallable;                               <<*8393>>57305000
   << format binary date to ascii string >>                    <<*8393>>57310000
begin                                                          <<*8393>>57315000
   byte array save'date'(0:dump'date'len-1);                   <<*8393>>57320000
   byte pointer pdate';                                        <<*8393>>57325000
   integer mm,dd,yy;                                           <<*8393>>57330000
                                                               <<*8393>>57335000
   yy := dump'date.(0:7);                                      <<*8393>>57340000
   dd := dump'date.(7:9);                                      <<*8393>>57345000
   mm := 0;                                                    <<*8393>>57350000
   while dd > dayinmonth(mm) do                                <<*8393>>57355000
      begin                                                    <<*8393>>57360000
         dd := dd - dayinmonth(mm);                            <<*8393>>57365000
         mm := mm + 1;                                         <<*8393>>57370000
      end;                                                     <<*8393>>57375000
   mm := mm+1;                                                 <<*8393>>57380000
   if (yy mod 4) = 0 then                                      <<*8393>>57385000
      if mm > 2 then                                           <<*8393>>57390000
         begin                                                 <<*8393>>57395000
            dd := dd -1;                                       <<*8393>>57400000
            if dd = 0 then                                     <<*8393>>57405000
               begin                                           <<*8393>>57410000
                  mm:=mm-1;                                    <<*8393>>57415000
                  dd := dayinmonth(mm-1);                      <<*8393>>57420000
                  if mm = 2 then                               <<*8393>>57425000
                     dd := 29;                                 <<*8393>>57430000
               end;                                            <<*8393>>57435000
         end;                                                  <<*8393>>57440000
                                                               <<*8393>>57445000
   <<build "MM/DD/YY" in save'date'...>>                       <<*8393>>57450000
                                                               <<*8393>>57455000
   fill' (save'date', dump'date'len, " ");                     <<*8393>>57460000
                                                               <<*8393>>57465000
   @pdate':=@save'date';                                       <<*8393>>57470000
   @pdate':=@pdate'+ascii (mm, 10, pdate');                    <<*8393>>57475000
   pdate':="/";                                                <<*8393>>57480000
   @pdate':=@pdate'(1);                                        <<*8393>>57485000
   @pdate':=@pdate'+ascii (dd, 10, pdate');                    <<*8393>>57490000
   pdate':="/";                                                <<*8393>>57495000
   @pdate':=@pdate'(1);                                        <<*8393>>57500000
   @pdate':=@pdate'+ascii (yy, 10, pdate');                    <<*8393>>57505000
                                                               <<*8393>>57510000
   move dump'date':=save'date', (dump'date'len);               <<*8393>>57515000
end;                                                           <<*8393>>57520000
$page "             PROCESS THE DUMP DATE"                     <<01073>>57525000
$control segment=sysdump                                       <<01073>>57530000
     logical procedure getdumpdate;                            <<01073>>57535000
     option privileged,uncallable;                             <<01073>>57540000
     begin                                                     <<01073>>57545000
     logical autodump:=true;                                   <<*8393>>57550000
     entry getdumpdate';                                       <<*8393>>57555000
                                                               <<04659>>57560000
     integer                                                   <<04659>>57565000
         mm       := 0,       <<month: 1..12>>                 <<04659>>57570000
         dd       := 0,       <<day:   1..28/29/30/31>>        <<04659>>57575000
         yy       := 0;       <<year:  1..99>>                 <<04659>>57580000
                                                               <<04659>>57585000
          autodump := false;                                   <<*8393>>57590000
  reqdate':                                                    <<00598>>57595000
          dumpdate := -1;                                               57600000
          message(-m2461);    <<enter dump date>>              <<*8393>>57605000
          readinput;                                                    57610000
getdumpdate':                                                  <<*8393>>57615000
          getdumpdate := true;                                 <<*8393>>57620000
          dumpdate := inval(@daterr,"/"); <<month,0 or carriage return>>57625000
          if = then                                                     57630000
            begin  <<carriage return input>>                            57635000
              dumpdate := -1; <<dump no files>>                         57640000
              getdumpdate := false;                            <<01073>>57645000
              return;                                          <<01073>>57650000
            end;                                                        57655000
          if > then if dumpdate<>0 then                                 57660000
            begin  <<error - followed by cr>>                           57665000
  daterr:     message(m2471);                                  <<*8393>>57670000
              if autodump then                                 <<*8393>>57675000
                 begin                                         <<*8393>>57680000
                    getdumpdate :=false;                       <<*8393>>57685000
                    return;                                    <<*8393>>57690000
                 end                                           <<*8393>>57695000
              else                                             <<*8393>>57700000
                 go to reqdate';                               <<*8393>>57705000
            end                                                         57710000
          else return;      <<0 -- dump all files>>            <<01073>>57715000
          if not (1<=dumpdate<=12) then go daterr; <<ill. month>>       57720000
          mm:=dumpdate;                <<save the month>>      <<04659>>57725000
          m := dumpdate-1;                                              57730000
          n := inval(@daterr,"/");  <<get day>>                         57735000
          if >= then goto daterr;                                       57740000
          dd:=n;                       <<save the day>>        <<04659>>57745000
          i := inval(@daterr,"/");                                      57750000
          if <= then goto daterr;  <<not followed by cr>>               57755000
          yy:=i;                       <<save the year>>       <<04659>>57760000
          if not (1<=i<=99) then go daterr; <<bad year>>                57765000
          tos := 1;                                                     57770000
          tos := dayinmonth(m);  <<# of days in month>>                 57775000
          if (m=1) and (i mod 4)=0 then tos := tos+1;  <<leap year>>    57780000
          x := n;                                                       57785000
          assemble(cprb okday);  <<check for day correct>>              57790000
          goto daterr;                                                  57795000
  okday:  tos := n+firstday(m);  <<day in year>>                        57800000
          if ( i mod 4 = 0) and (m>1) then tos := tos+1;  <<leap year>> 57805000
          tos.(0:7) := i;  <<year>>                                     57810000
          dumpdate := tos;                                              57815000
          format'date(dumpdate);                               <<*8393>>57820000
                                                               <<04659>>57825000
     end;                                                      <<01073>>57830000
$page "             PROCESS THE DUMP FILE SUBSET(S)"           <<01073>>57835000
$control segment=sysdump                                       <<01073>>57840000
     procedure get'file'subset;                                <<01073>>57845000
     option privileged,uncallable;                             <<01073>>57850000
     begin                                                     <<01073>>57855000
        logical generic, wild, continue, syntaxerr;            <<01073>>57860000
        integer                                                <<04659>>57865000
           blinbuflen         := 0,                            <<04659>>57870000
           errnum             := 0,                            <<04659>>57875000
           err'subclass       := 0,                            <<04659>>57880000
           field              := 0,                            <<04659>>57885000
           insize             := 0,                            <<04659>>57890000
           next'byte          := 0;                            <<04659>>57895000
                                                               <<04659>>57900000
        byte pointer                                           <<04659>>57905000
           pt;                <<scratch pointer>>              <<04659>>57910000
        equate blinbufext = 128;  <<extension length in words>><<01073>>57915000
reqdl:                                                         <<00777>>57920000
      comment:  enter file set names into expandable array     <<00778>>57925000
              blinbuf.  expansion is in 126 word increments    <<00778>>57930000
              until the dl area is used up (then sysdump go    <<00778>>57935000
              bye bye).  this section of code expects blinbuf  <<00778>>57940000
              to not be in use and its length is zero words;   <<00778>>57945000
          message(m2463);  <<enter dump file subset(s)>>       <<*8393>>57950000
          syntaxerr:=false;                                    <<00777>>57955000
          blinbuflen:=0;                                       <<00778>>57960000
          next'byte:=0;                                        <<00778>>57965000
          do begin                                             <<00777>>57970000
            readinput;                                         <<00777>>57975000
            scan bpinbuf until %6446,1;  <<cr,&>>              <<00777>>57980000
            if carry then continue:=false                      <<00777>>57985000
            else                                               <<00777>>57990000
              begin                                            <<00777>>57995000
              continue:=true;                                  <<00777>>58000000
              if logical(mode) then message(m2293);            <<*8393>>58005000
              end;                                             <<00777>>58010000
            insize:=tos - @bpinbuf + 1;                        <<00778>>58015000
            if next'byte + insize >= blinbuflen then           <<00778>>58020000
              begin                                            <<00778>>58025000
              blinbufincr:=blinbufext;                         <<00778>>58030000
              movedltables;                                    <<00778>>58035000
              blinbuflen:=blinbuflen + blinbufext * 2;         <<00778>>58040000
              end;                                             <<00778>>58045000
            tos:=@blinbuf + next'byte;                         <<00778>>58050000
            move * := bpinbuf, (insize),2;                     <<00778>>58055000
            next'byte:=tos - @blinbuf - 1;                     <<00778>>58060000
            end until not continue;                            <<00778>>58065000
                                                               <<00777>>58070000
          scan blinbuf while " ", 1;                           <<04659>>58075000
          @pt:=tos;           <<first non-blank>>              <<04659>>58080000
          if pt = cr then     <<is it the end of the buffer?>> <<04659>>58085000
             move blinbuf:=("@.@.@", cr);         <<yep>>      <<04659>>58090000
                                                               <<04659>>58095000
          scan blinbuf until cr, 1;    <<find end of buffer>>  <<04659>>58100000
          insize:=tos-@blinbuf;        <<length scanned>>      <<04659>>58105000
                                                               <<04659>>58110000
          if insize > store'files'len then                     <<04659>>58115000
             begin                                             <<04659>>58120000
             message (m2801,240);   <<file subset too large>>  <<*8393>>58125000
             go reqdl;                                         <<04659>>58130000
             end;                                              <<04659>>58135000
                                                               <<04659>>58140000
          move store'files':=blinbuf, (insize), 2;             <<04659>>58145000
          move *:=(cr);                                        <<04659>>58150000
                                                               <<04659>>58155000
                                                               <<04659>>58160000
                                                               <<04659>>58165000
                <<check for valid syntax..>>                   <<04659>>58170000
                                                               <<04659>>58175000
          store'user'files (0,         <<tape file#>>          <<04659>>58180000
                            false,     <<show flag>>           <<04659>>58185000
                            true,      <<syntax only>>         <<04659>>58190000
                            errnum, err'subclass);             <<04659>>58195000
                                                               <<04659>>58200000
          if errnum = s'err'syntax then                        <<04659>>58205000
             begin                                             <<04659>>58210000
             message (m2802);       <<syntax error in store>>  <<*8393>>58215000
             go reqdl;                                         <<04659>>58220000
             end;                                              <<04659>>58225000
                                                               <<00777>>58230000
     end;                                                      <<01073>>58235000
$page "             CREATE THE DUMP TAPE"                      <<01073>>58240000
$control segment=dumptape                                      <<01073>>58245000
     procedure dumptape(show);                                 <<01073>>58250000
     value show;                                               <<01073>>58255000
     logical show;                                             <<01073>>58260000
     option privileged,uncallable;                             <<01073>>58265000
     begin                                                     <<01073>>58270000
integer err'subclass;                                          <<04659>>58275000
        equate sdisc=31;                                       <<01073>>58280000
byte array sndopendev(0:3);                                    <<01073>>58285000
integer countint; <<count of internal stt entries>>            <<06092>>58290000
integer                                                        <<02567>>58295000
   systape := 0,                                               <<02567>>58300000
   max'recsize,     << maximum record size for device >>       <<02567>>58305000
   density,         << tape density >>                         <<02567>>58310000
   errnum;                                                     <<02567>>58315000
double                                                         <<03604>>58320000
   initdl,          <<configurator dl>>                        <<03604>>58325000
   initdb,          <<configurator db>>                        <<03604>>58330000
   initpb,          <<configurator pb>>                        <<03604>>58335000
   svalue,          <<initial svalue>>                         <<03604>>58340000
   zvalue,          <<initial zvalue>>                         <<03604>>58345000
   ininbase;        <<start of internal interrupts>>           <<03604>>58350000
logical                                                        <<02567>>58355000
   ldirc,                                                      <<de>>   58360000
   fstore'flag;     << flag for 6250 bpi default case >>       <<02567>>58365000
integer                                                        <<06814>>58370000
   gllen,    << length of global rin area >>                   <<06814>>58375000
   glarea,   << disp to global rin area >>                     <<06814>>58380000
   nglarea,  << new disp to global rin area >>                 <<06814>>58385000
   loc;      << temp variable >>                               <<06814>>58390000
equate                                                         <<02567>>58395000
   xretpmaskfail = 1063;   << ci error message >>              <<02567>>58400000
double  sioadr;                                                <<03604>>58405000
integer sioadr1=sioadr,                                        <<03604>>58410000
        sioadr2=sioadr+1;                                      <<03604>>58415000
double  array coreadr(0:31);   <<init segment core adresses>>  <<03604>>58420000
integer array defaults(0:35)=pb:=                              <<07448>>58425000
                                                               <<07448>>58430000
   192,        <<cst    0>>                                    <<07448>>58435000
   200,        <<dst    1>>                                    <<07448>>58440000
    48,        <<pcb    2>>                                    <<07448>>58445000
    48,        <<i/o q  3>>                                    <<07448>>58450000
     3,        <<tbufs  4>>                                    <<07448>>58455000
   200,        <<cstx   5>>                                    <<07448>>58460000
  1024,        <<ics    6>>                                    <<f9043>>58465000
    32,        <<ucrq   7>>                                    <<07448>>58470000
    32,        <<brkpt  8>>                                    <<07448>>58475000
    32,        <<trl    9>>                                    <<07448>>58480000
    48,        <<rins  10>>                                    <<07448>>58485000
    16,        <<grins 11>>                                    <<07448>>58490000
     8,        <<sbufs 12>>                                    <<07448>>58495000
    24,        <<concp 13>>                                    <<07448>>58500000
   16384,      <<lst 14>>                                      <<07448>>58505000
     0,        << (15) type-ahead >>                           <<07448>>58510000
               <<buffer size--for >>                           <<07448>>58515000
               <<    future use   >>                           <<07448>>58520000
     0,        <<nu    16>>                                    <<07448>>58525000
     0,        <<nu    17>>                                    <<07448>>58530000
     0,        <<nu    18>>                                    <<07448>>58535000
     0,        <<nu    19>>                                    <<07448>>58540000
  5120,        <<vm    20>>                                    <<07448>>58545000
 1536,         <<dirc  21>>                                    <<07448>>58550000
  8192,        <<mcss  30>>                                    <<07448>>58555000
    63,        <<mcsp  31>>                                    <<07448>>58560000
  31232,       <<mstk32>>                                      <<07448>>58565000
  8192,        <<mxdss 33>>                                    <<07448>>58570000
     4,        <<mxdsp 34>>                                    <<07448>>58575000
    16,        <<mses  40>>                                    <<07448>>58580000
    2,         <<mjob>>                                        <<07448>>58585000
    3,         <<logprocs>>                                    <<07448>>58590000
   10,         <<users/proc>>                                  <<07448>>58595000
  128,         <<disc req>>                                    <<07448>>58600000
   64,         <<special req>>                                 <<07448>>58605000
   25,         <<primary msg table>>                           <<07448>>58610000
  384,         <<swap table>>                                  <<07448>>58615000
   25;         <<secondary msg table>>                         <<07448>>58620000
   integer array cmd'tab(0:149);                               <<02509>>58625000
   integer array tape'fmt'tab(0:299);                          <<03604>>58630000
   integer pointer                                             <<02509>>58635000
      pntr,                                                    <<02509>>58640000
      ctpntr;                                                  <<02509>>58645000
   define                                                      <<02509>>58650000
      entry'size = tape'fmt'tab.(0:8)#,                        <<02509>>58655000
      entries = tape'fmt'tab.(8:8)#,                           <<02509>>58660000
      length = pntr#,                                          <<02509>>58665000
      coreadr1 = pntr(1)#,                                     <<02509>>58670000
      coreadr2 = pntr(2)#,                                     <<02509>>58675000
      discadr1 = pntr(3)#,                                     <<02509>>58680000
      discadr2 = pntr(4)#;                                     <<02509>>58685000
   define                                                      <<02509>>58690000
      fnum                = cmd'tab#,                          <<02509>>58695000
      next'rec            = cmd'tab(1)#,                       <<02509>>58700000
      rec'before'initial  = cmd'tab(2)#,                       <<02509>>58705000
      nrent'after'wcs     = cmd'tab(3)#,                       <<02509>>58710000
      nrent'before'wcs    = cmd'tab(4)#,                       <<02509>>58715000
      amigo'rec'1         = cmd'tab(5)#,                       <<02509>>58720000
      amigo'rec'2         = cmd'tab(6)#,                       <<02509>>58725000
      wcs'rec'before'init = cmd'tab(7)#,                       <<02509>>58730000
      sio'rec'before'init = cmd'tab(8)#,                       <<02509>>58735000
      amigo'rec'before'init = cmd'tab(9)#,                     <<02509>>58740000
      beg'of'stack        = 40#,                               <<02509>>58745000
      rec                 = ctpntr#,                           <<02509>>58750000
      len                 = ctpntr(1)#;                        <<02509>>58755000
   subroutine sioread(size);                                   <<02509>>58760000
      value size;                                              <<02509>>58765000
      logical size;                                            <<03604>>58770000
   begin                                                       <<02509>>58775000
      length := size;                                          <<02509>>58780000
      coreadr1 := sioadr1;   << bank >>                        <<03604>>58785000
      coreadr2 := sioadr2;   <<address>>                       <<03604>>58790000
      @pntr := @pntr(entry'size);                              <<02509>>58795000
      entries := entries+1;                                    <<02509>>58800000
      blockn := blockn+1;                                      <<02509>>58805000
      sioadr := sioadr+double(size);                           <<03604>>58810000
   end;                                                        <<02509>>58815000
  initdump:                                                             58820000
      systape:=fopen(tapefile,%200,%1,                         <<00425>>58825000
                      4096);                                   <<00425>>58830000
  tapeerr:if <> then ferror(tapefnum,tapefile);                         58835000
   fgetinfo(systape,,foptions,aoptions,recsize,devtype,        <<00425>>58840000
            sdiscldev);                                        <<00425>>58845000
          if <> then goto tapeerr;                                      58850000
                                                               <<00425>>58855000
<< first verify that tape parameters are valid>>               <<00425>>58860000
                                                               <<00425>>58865000
   if foptions.(8:8)<>%200 or                                  <<00425>>58870000
      (logical(aoptions) land %177377)<>1 or                   <<00425>>58875000
   devtype.rbite<>magtapetype and                              <<00425>>58880000
        devtype.rbite<>sdisc then                              <<00.sd>>58885000
            begin                                                       58890000
              message(m459);  <<bad tape open parms>>          <<*8393>>58895000
              quit(0);                                                  58900000
      end;                                                     <<00425>>58905000
   magtape := devtype.rbite = magtapetype;                     <<02509>>58910000
                                                               <<02650>>58915000
<< because store cannot handle it, use of a labelled >>        <<02650>>58920000
<< tape on a remote tape drive is not allowed. >>              <<02650>>58925000
                                                               <<02650>>58930000
   if magtape and foptions.(6:1)=1 and  << labelled mag tape >><<02650>>58935000
     sdiscldev.lbite <> 0 then          << and remote device >><<02650>>58940000
      begin                                                    <<02650>>58945000
      message(m459);                                           <<*8393>>58950000
      quit(0);                                                 <<02650>>58955000
      end;                                                     <<02650>>58960000
                                                               <<00425>>58965000
<< now, check out the record size >>                           <<02567>>58970000
                                                               <<02567>>58975000
   if not magtape then                                         <<02567>>58980000
      max'recsize := 4096                                      <<02567>>58985000
   else                                                        <<02567>>58990000
      if not get'tape'info(systape,max'recsize,density)        <<02567>>58995000
         then ferror(systape,tapefile);     << no return !! >> <<02567>>59000000
                                                               <<02567>>59005000
   if not (256 <= recsize <= max'recsize) or                   <<02567>>59010000
      (recsize mod 256) <> 0 then                              <<02567>>59015000
      begin                                                    <<02567>>59020000
      message(m459);                                           <<*8393>>59025000
      quit(0);                                                 <<02567>>59030000
      end;                                                     <<02567>>59035000
                                                               <<02567>>59040000
<< now see if we have to use a second tape to write the   >>   <<00425>>59045000
<< system portion of the sysdump tape.  the criteria are: >>   <<00425>>59050000
<<     1) recsize<1024                                    >>   <<00425>>59055000
<<     2) device type=serial disc and buf i/o specified   >>   <<00425>>59060000
<<                                                        >>   <<00425>>59065000
<< if either of these criteria are met, then the dump     >>   <<00425>>59070000
<< is opened a second time, with the same characteristics >>   <<00425>>59075000
<< as the first open, except the record size is set to    >>   <<00425>>59080000
<< 1024 and if criteria 2) is met, then nobuf i/o is also >>   <<00425>>59085000
<< set.                                                   >>   <<00425>>59090000
                                                               <<00425>>59095000
   if recsize<1024 or devtype.rbite=sdisc and                  <<00425>>59100000
      aoptions.(7:1)=0 then <<got to open again>>              <<00425>>59105000
   begin                                                       <<00425>>59110000
      sndopendev(ascii(sdiscldev,10,sndopendev)):=" ";         <<00425>>59115000
      tapefnum:=fopen(tapefile,%2200,                          <<00425>>59120000
          1+(if devtype.rbite=sdisc then %400 else             <<00520>>59125000
            logical(aoptions) land %400),                      <<00520>>59130000
               1024,sndopendev);                               <<00425>>59135000
      if <> then <<couldn't open 2nd time>>                    <<00425>>59140000
      begin                                                    <<00425>>59145000
         fclose(systape,0,0);                                  <<00425>>59150000
         ferror(tapefnum,tapefile);                            <<00425>>59155000
      end;                                                     <<00425>>59160000
      recsize := 1024;                                         <<04864>>59165000
   end else tapefnum:=systape <<systape = tapefnum >>;         <<00425>>59170000
                                                               <<00425>>59175000
     if magtape then                                           <<03604>>59180000
        begin                                                  <<03604>>59185000
        taperecsize := if recsize > 4096 then 4096 else        <<03604>>59190000
           recsize;                                            <<03604>>59195000
        end                                                    <<03604>>59200000
     else                                                      <<03604>>59205000
        taperecsize := 1024;  << serial disc >>                <<03604>>59210000
     zerobuf(tape'fmt'tab,300);                                <<03604>>59215000
     zerobuf(cmd'tab,149);                                     <<03604>>59220000
     entry'size := if magtape then 3 else 5;                   <<02509>>59225000
     blockn := 0;                                              <<02509>>59230000
     @pntr := @tape'fmt'tab(entry'size);                       <<02509>>59235000
     fnum := fopen(,0,%424);  << open chan pgm file >>         <<02509>>59240000
     if <> then quit(99);                                      <<02509>>59245000
                                                               <<00072>>59250000
          <<--------------------------------------->>          <<00072>>59255000
          <<get actual device type of output device>>          <<00072>>59260000
          <<--------------------------------------->>          <<00072>>59265000
     mfds( ldt, ldtdstn,                << get device type  >> <<*7833>>59270000
              sdiscldev*ldtsize,        <<    of tape file  >> <<06762>>59275000
              4);                       <<    from the ldt  >> <<06762>>59280000
     outdevtype := ldt'device'type;                            <<06762>>59285000
                                                               <<00072>>59290000
          <<----------------------------->>                    <<00072>>59295000
          <<determine type of floppy disc>>                    <<00072>>59300000
          <<----------------------------->>                    <<00072>>59305000
          if floppy then                                       <<00072>>59310000
             begin                                             <<00072>>59315000
             tos:= p'attachio(sdiscldev,0,0,@lbuf,reqstat,     <<07443>>59320000
             2,0,0,1);                                         <<07443>>59325000
             ioerrcheck(*,*);                                  <<00072>>59330000
             flop'sec'cyl:=if doublesided then 60 else 30;     <<00072>>59335000
             end;                                              <<00072>>59340000
                                                                        59345000
          <<------------------------                                    59350000
            set up initial program                                      59355000
          ------------------------>>                                    59360000
          search'sysfile( initfile);                           <<02509>>59365000
          initfnum := fopen(fullname,%(2)10000000011,                   59370000
            %(2)11110100);                                              59375000
  initerr:if <> then ferror(initfnum,initfile);                         59380000
          flock(initfnum,true);                                         59385000
          if <> then goto initerr;                                      59390000
          fread(initfnum,rec0,128);  <<init record 0>>                  59395000
          if <> then goto initerr;                                      59400000
          nseg := rec0(1);   <<# of segments>>                          59405000
          k := 28+(nseg+1)&lsr(1);  <<index to descriptors>>            59410000
          firstcst := 1;    <<first entry used by init>>       <<03604>>59415000
          i := 0;                                                       59420000
          maxinitseg := 0;                                              59425000
          tos := rec0(4);  <<first segment record #>>                   59430000
          do                                                            59435000
            begin    <<scan segment descriptors>>                       59440000
              segadr(i) := s0;   <<segment record #>>                   59445000
              tos := rec0(x:=x+k).(2:14);   <<segment size>>            59450000
              assemble(dup,dup);                                        59455000
              segsize(i) := tos;                                        59460000
              if (tos>maxinitseg) and (i>=nnonswapseg) then    <<03604>>59465000
                maxinitseg := s0;                                       59470000
              tos := (tos+127)&lsr(7);                                  59475000
              assemble(add);                                            59480000
              tos := segsize(x);                                        59485000
              tos := 128;                                               59490000
              assemble(decb,div);                                       59495000
              sttindex := tos+256;  <<index to pl in buffer>>           59500000
              sttrec := tos-2+segadr(i);                                59505000
              freaddir(initfnum,stt,384,double(sttrec));  <<read stt>>  59510000
              if <> then goto initerr;                                  59515000
              countint:=0;      <<init count>>                 <<06092>>59520000
              n := -(stt(sttindex).(8:8));  <<# of entries in stt>>     59525000
              l := 0;                                                   59530000
              while (l:=l-1) >= n do                                    59535000
                begin  <<fix up intra program references>>              59540000
                  tos := stt(sttindex+l);                               59545000
                  if >= then                                   <<06092>>59550000
                     begin           <<internal label>>        <<06092>>59555000
                     countint:=countint+1; <<inc count>>       <<06092>>59560000
                     go to setlab;                             <<06092>>59565000
                     end;                                      <<06092>>59570000
                  oldcst := s0.(8:8);                                   59575000
                  m := 0;                                               59580000
                  do if integer(brec0(56+m))=oldcst then                59585000
                    begin   <<found referenced segment>>                59590000
                      tos.(8:8) := firstcst+m;                          59595000
                      goto setlab;                                      59600000
                    end                                                 59605000
                  until (m:=m+1) = nseg;                                59610000
                  del;                                                  59615000
                  tos := -1;                                            59620000
  setlab:         stt(sttindex+l) := tos;  <<reset label>>              59625000
                end;                                                    59630000
              <<modify stt head to new format>>                <<06092>>59635000
              stt(sttindex).(0:8):=countint; <<insert count>>  <<06092>>59640000
              fwritedir(initfnum,stt,384,double(sttrec));               59645000
              if <> then goto initerr;                                  59650000
            end                                                         59655000
          until (i:=i+1) = nseg;                                        59660000
          i := 0;   <<reset cst remapping array>>                       59665000
          do brec0(56+i) := firstcst+i until (i:=i+1)=nseg;             59670000
          fwritedir(initfnum,rec0,128,0d);                              59675000
          if <> then goto initerr;                                      59680000
          freaddir(initfnum,lbuf,128,d'l(rec0(8)))); <<entry pt list>>  59685000
          if <> then goto initerr;                                      59690000
          index := 0;                                                   59695000
  nextentry:                                                            59700000
          tos := lbuf(index).(4:4);   <<# of characters>>               59705000
          if = then goto entrydone;                                     59710000
          if s0=8 then                                                  59715000
            begin   <<look for entry points>>                           59720000
              if blbuf(index&lsl(1)+1)=tapeentryname,(8) then           59725000
                tapeentry := lbuf(index+5);                             59730000
              if blbuf(index&lsl(1)+1)=discentryname,(8) then           59735000
                discentry := lbuf(index+5);                             59740000
            end;                                                        59745000
          index := tos&lsr(1)+3+index;                                  59750000
          goto nextentry;                                               59755000
  entrydone:                                                            59760000
                                                                        59765000
          comm(dvclsize') := dcth'tdt'base - dcth'dct'base;    <<*7657>>59770000
          comm(ttdtsize') := dcth'segment'size - dcth'tdt'base;<<*7657>>59775000
          comm(tlbufsize) := tlh'table'size;                   <<t8393>>59780000
          comm(tlbufentries) := tlh'num'entries;               <<t8393>>59785000
          i := 1;                                              <<00185>>59790000
          tos := coreend;                                      <<00185>>59795000
          do                                                   <<00185>>59800000
            begin                                              <<00185>>59805000
              tos := logical(tos-segsize(i-1));                <<03604>>59810000
              coreadr(x) := ds0; <<starting segment address>>  <<03604>>59815000
            end                                                <<00185>>59820000
          until (i:=i+1) > nstartseg;                          <<00185>>59825000
          initpb := tos;    <<lowest init core address>>       <<03604>>59830000
          tos := initz;     << end of inital's stack >>        <<03604>>59835000
          tos := logical(tos-rec0(2)-stacksize-markersize)     <<03604>>59840000
                 land %177770;                                 <<03604>>59845000
          initdb := ds0;    <<db area starting address>>       <<03604>>59850000
          tos := csdefsize + csdvrtsize + commsize + ctab0size+<<07039>>59855000
             ctabsize + (mvol + 1)*vtabsize + tlh'table'size + <<t8393>>59860000
            cstab + dcth'segment'size;                         <<*7657>>59865000
          if dumpdate<>-1 then tos:=tos+infosize+(oldvtab.(0:8)+1)*     59870000
            vtabsize;    <<only dumped if files dumped>>       <<00185>>59875000
          tablesize := s0;  <<size of dl area>>                <<00185>>59880000
          assemble(sub);                                       <<00185>>59885000
          comm(cstabsize) := cstab;                            <<07039>>59890000
          initdl:=ds0;                                         <<03604>>59895000
          <<----------------------                                      59900000
            generate sio program                                        59905000
          ---------------------->>                                      59910000
          tos := hldev;                                                 59915000
          assemble(dup,ddup);                                  <<06762>>59920000
          get'ldev'entries(0);                                 <<06762>>59925000
          ldt'num'entries := tos;                              <<06762>>59930000
          ldtx'num'entries := tos;                             <<06762>>59935000
          lpdt'max'entries := tos;                             <<06762>>59940000
          put'ldev'entries(0);                                 <<06762>>59945000
          comm(hldev') := tos;                                 <<07039>>59950000
          comm(hvol') := nvol;                                 <<07039>>59955000
          vtab.(0:8) := mvol;                                  <<rh.pv>>59960000
          zerobuf(lbuf,384);                                   <<03544>>59965000
          sioadr := d'l(icsbase));                             <<03604>>59970000
          sioread(icslen);                                     <<02509>>59975000
          sioadr := 0d;                                        <<03604>>59980000
          sioread(a0size);    <<low core>>                              59985000
          sioadr := d'l(cstbase));                             <<03604>>59990000
          sioread(tcstsize);                                   <<03604>>59995000
          sioadr:=initdl;                                      <<00185>>60000000
          sioread(cstab);  <<cs data segment>>                          60005000
          << dct header, dctab, tdtab all at once !!!>>        <<*7657>>60010000
          << other wise we play russian roulette     >>        <<*7657>>60015000
          sioread(dcth'segment'size);                          <<*7657>>60020000
          sioread(tlh'table'size);  <<table lookup buffer>>    <<t8393>>60025000
          sioread((mvol+1)*vtabsize);  <<volume table>>        <<rh.pv>>60030000
          if dumpdate<>-1 then                                          60035000
            begin                                                       60040000
              tos := (oldvtab.(0:8)+1)*vtabsize;                        60045000
              comm(oldvtabsize) := s0;                         <<07039>>60050000
              sioread(*);  <<old volume table>>                         60055000
              sioread(infosize);  <<cold load information table>>       60060000
              comm(oldinfosize) := infosize;                   <<07039>>60065000
            end                                                         60070000
          else                                                          60075000
            begin  <<these tables not dumped>>                          60080000
              comm(oldvtabsize) := 0;                          <<07039>>60085000
              comm(oldinfosize) := 0;                          <<07039>>60090000
            end;                                                        60095000
          sioread(ctabsize); <<configuration tables>>          <<07039>>60100000
          sioread(ctab0size); <<non-coresize related configuration>>    60105000
          sioread( commsize);                                  <<07039>>60110000
          sioread(csdvrtsize);                                          60115000
          sioread(csdefsize);                                           60120000
             if sioadr <> initdb then                          <<t8393>>60125000
                begin                                          <<t8393>>60130000
                message(m374,,1); quit(0);                     <<t8393>>60135000
                end;                                           <<t8393>>60140000
          sioadr := initdb;                                             60145000
          sioread(rec0(2));  <<initial's db area>>                      60150000
          sioread(markersize);   <<init stack marker>>                  60155000
          svalue := sioadr-1d;                                 <<03604>>60160000
          zvalue := sioadr+double(stacksize)-16d;              <<03604>>60165000
          sioadr := zvalue + double(%15); << extra room  >>    <<06811>>60170000
                                          << before tables >>  <<06811>>60175000
          sioread((hldev+1)*dvrsize);  <<driver table>>        <<06811>>60180000
          sioadr := sioadr + double((maxldev-hldev)*dvrsize);  <<06811>>60185000
          sioread((hldev+1)*lpdtsize);                         <<06811>>60190000
          sioadr := sioadr + double((maxldev-hldev)*lpdtsize); <<06811>>60195000
          sioread((hldev+1)*ldtsize);  <<logical device table>><<06811>>60200000
          sioadr := sioadr + double((maxldev-hldev)*ldtsize);  <<06811>>60205000
          sioread((hldev+1)*ldtxsize); <<ldt extension>>       <<06811>>60210000
          sioadr := sioadr + double((maxldev-hldev)*ldtxsize); <<06811>>60215000
          tcst := 0;                                                    60220000
          move tcst(1) := tcst,(tcstsize-1);                            60225000
          tcst := ncst-1;                                               60230000
          tcst(1) := 4;                                                 60235000
          j := 1;                                                       60240000
          do begin                                             <<03604>>60245000
             i := j-1;                                         <<03604>>60250000
             tos := segsize(i)&lsr(2);                         <<03604>>60255000
             assemble(tsbc 1); << priv mode >>                 <<03604>>60260000
             if j <= nstartseg then                            <<03604>>60265000
                begin << segment starts out in core >>         <<03604>>60270000
                sioadr := coreadr(i);                          <<03604>>60275000
                dtcst(j&lsl(1)+1) := coreadr(i);               <<03604>>60280000
                sioread(segsize(i)); << sio entry >>           <<03604>>60285000
                end                                            <<03604>>60290000
             else                                              <<03604>>60295000
                assemble( tsbc 0 ); << absent >>               <<03604>>60300000
             tcst(j&lsl(2)) := tos; << len of segment >>       <<03604>>60305000
             end until (j:=j+1) > nseg;                        <<03604>>60310000
          if magtape then                                      <<02509>>60315000
             begin <<tape>>                                    <<00072>>60320000
             if cltape'sio then                                <<02509>>60325000
                build'sio(tape'fmt'tab,cmd'tab);               <<02509>>60330000
             if cltape'amigo then                              <<02509>>60335000
                build'amigo(tape'fmt'tab,cmd'tab);             <<02509>>60340000
             rec'before'initial := rec'before'initial+compute'wcs'size; 60345000
             wcs'rec'before'init := rec'before'initial;        <<02509>>60350000
             if cltape'amigo then                              <<02509>>60355000
                build'amigo'skip(tape'fmt'tab,cmd'tab);        <<02509>>60360000
             if cltape'sio then                                <<02509>>60365000
                build'sio'skip(tape'fmt'tab,cmd'tab);          <<02509>>60370000
                                                               <<02509>>60375000
             @ctpntr := @cmd'tab(beg'of'stack                  <<02509>>60380000
                +(nrent'before'wcs+nrent'after'wcs)*2);        <<02509>>60385000
             tos := nrent'before'wcs;                          <<02509>>60390000
             while <> do                                       <<02509>>60395000
                begin                                          <<02509>>60400000
                @ctpntr := @ctpntr(-2);                        <<02509>>60405000
                freaddir(fnum,lbuf,len,double(rec));           <<02509>>60410000
                writetape(lbuf,len,1);                         <<02509>>60415000
                tos:=tos-1;                                    <<02509>>60420000
                end;                                           <<02509>>60425000
             dump'wcs;                                         <<03005>>60430000
             @ctpntr := @cmd'tab(beg'of'stack                  <<02509>>60435000
                +(nrent'after'wcs*2));                         <<02509>>60440000
             tos := nrent'after'wcs;                           <<02509>>60445000
             while <> do                                       <<02509>>60450000
                begin                                          <<02509>>60455000
                @ctpntr := @ctpntr(-2);                        <<02509>>60460000
                freaddir(fnum,lbuf,len,double(rec));           <<02509>>60465000
                writetape(lbuf,len,1);                         <<02509>>60470000
                tos := tos-1;                                  <<02509>>60475000
                end;                                           <<02509>>60480000
             end;  <<tape>>                                    <<02509>>60485000
          <<-------------------------                                   60490000
            set up ics and low core                                     60495000
          ------------------------->>                                   60500000
          zerobuf(lbuf,384);                                   <<03544>>60505000
          tos := initdb;                                       <<03604>>60510000
          lbuf(icsqi+2) := tos;    <<dispatcher db>>           <<03604>>60515000
          lbuf(icsqi+1) := tos;    <<dispatcher bank>>         <<03604>>60520000
          tos := initdb;                                       <<03604>>60525000
          lbuf(icsqi-4) := tos;                   <<stack db>> <<03604>>60530000
          lbuf(icsqi-5) := tos;                   <<s-bank>>   <<03604>>60535000
          lbuf(icsqi-7) := -tablesize;            <<rel dl>>   <<03604>>60540000
          lbuf(icsqi-8) := logical(zvalue-initdb);<<rel z>>    <<03604>>60545000
          lbuf(icsqi-10):= logical(svalue-initdb);<<rel s>>    <<03604>>60550000
          lbuf(icsqi-18) := 1; << pdisabled >>                 <<03604>>60555000
          writetape(lbuf,icslen,1);                            <<02509>>60560000
          zerobuf(lbuf,384);                                   <<03544>>60565000
          lbuf := cstbase;   <<cst pointer>>                   <<03604>>60570000
          tos := icsbase;                                               60575000
          lbuf(5) := s0+icsqi;                                          60580000
          lbuf(6) := tos+icszi;                                <<03604>>60585000
          lbuf(8) := 1;   <<insure drtbank = 1 >>              <<03006>>60590000
          writetape(lbuf,a0size,1);                            <<02509>>60595000
          writetape(tcst,tcstsize,1);                          <<03604>>60600000
                                                                        60605000
          <<-------------                                               60610000
            dump tables                                                 60615000
          ------------->>                                               60620000
          writetape(cstab,cstab,1);  <<cs data segment>>                60625000
                                                               <<06762>>60630000
          writetape(dct'head,dcth'segment'size,1);             <<*7657>>60635000
          writetape(tl'buf, tlh'table'size, 1);                <<t8393>>60640000
          writetape(vtab,(mvol+1)*vtabsize,1);                          60645000
          if dumpdate <> -1 then                                        60650000
            begin                                                       60655000
              writetape(oldvtab,comm(oldvtabsize),1);<<old vtab<<07091>>60660000
              attachio(sysdisc,0,0,@lbuf,0,infosize,           <<03544>>60665000
                       0,infosect,1);                          <<03544>>60670000
              writetape(lbuf,infosize,1);  <<cold load info table>>     60675000
            end;                                                        60680000
          fclose(ctabfnum,0,0);                                         60685000
ctaberr:  if <> then ferror(ctabfnum,ctabfile);                <<07094>>60690000
           if dumpdate <> -1 then                              <<00197>>60695000
             begin                                             <<00197>>60700000
               fmsir:=getsir(fmavtsir);                        <<00197>>60705000
               fsir:=getsir(flabsir);                          <<00197>>60710000
             end;                                              <<00197>>60715000
          dsir := getsir(dirsir);                                       60720000
          tos := setsysdb;                                              60725000
          tos := dbarray(logfilenum);  <<current log file number>>      60730000
          tos:=dbarray(dirdisc1);                              <<00215>>60735000
          tos:=dbarray(dirdisc2);                              <<00215>>60740000
          tos := s3;                                                    60745000
          resetdb(*);                                                   60750000
          dirdiscadr := tos;                                            60755000
          comm(logfilenum') := tos;                            <<07039>>60760000
          del;                                                          60765000
          tos := dirsize(dirsect);  <<get current minimum size>>        60770000
          assemble(dup,dup);                                            60775000
          ldirc := logical ( ctab(dirsect') );                 <<de>>   60780000
          dirsect := tos;  <<minimum size of directory>>                60785000
          if tos > ldirc then                                  <<de>>   60790000
            begin  <<reset size in ctab>>                               60795000
              ctab(dirsect') := tos;                                    60800000
              del;                                                      60805000
            end                                                         60810000
          else ddel;                                                    60815000
          if null'date then                                    <<00072>>60820000
            begin                                                       60825000
              relsir(dirsir,dsir);                                      60830000
              tos := 0;  <<no files dumped>>                            60835000
            end                                                         60840000
          else                                                          60845000
            begin                                                       60850000
              sirs := true;                                             60855000
              tos := 1;  <<files dumped>>                               60860000
            end;                                                        60865000
          comm(filesdumped) := tos;                            <<07039>>60870000
          if ctab(rins')<>rins or ctab(grins')<>grins then              60875000
          if (not rinchange) and dumpdate<>-1 then                      60880000
            begin  <<table size changed due to core size change>>       60885000
              ctab(rins') := rins;                                      60890000
              ctab(grins') := grins;                                    60895000
            end;                                                        60900000
        if default then                                        <<01210>>60905000
          begin                                                <<01210>>60910000
          move ctab := defaults,(22);                          <<07448>>60915000
          move ctab(30) := defaults(22),(5);                   <<07448>>60920000
          move ctab(40) := defaults(27),(9);                   <<07448>>60925000
          end;                                                 <<07448>>60930000
        writetape( ctab, ctabsize, 1);                         <<07448>>60935000
        if default then                                        <<01210>>60940000
          begin                                                <<01210>>60945000
          ctab0(maxspoolf) := 20;                                       60950000
          ctab0(logon) := 120;                                          60955000
          ctab0(cpulim) := 0;                                           60960000
          ctab0(logrecsize) := 2;                                       60965000
          ctab0(logfilesize) := 1023;                                   60970000
          dctab0(kilosects) := 128d;                                    60975000
          ctab0(extssect') := 384;                                      60980000
          ctab0(tslice) := 500;                                         60985000
          ctab0(termpri) := 152;                                        60990000
          ctab0(normpri) := 160;                                        60995000
          ctab0(cpupri) := 200;                                <<01.00>>61000000
          ctab0(sss) := 1200;  <<standard stack size>>         <<01332>>61005000
          comm(mitversion) := version cat %40 (0:8:8);         <<07039>>61010000
          comm(mitupdate) := updatel;                          <<07039>>61015000
          comm(mitfix) := fixlevel;                            <<07039>>61020000
          end;                                                 <<01210>>61025000
                                                               <<07039>>61030000
          comm(expflag') := expflag;                           <<07448>>61035000
          comm(discentry') := discentry;                       <<07039>>61040000
          comm(maxinitseg') := maxinitseg;                     <<07039>>61045000
          comm(id0) := 0;           << clear word  >>          <<07039>>61050000
          comm(id2) := 0;   << so far unused            >>     <<07039>>61055000
          comm(id3) := 0;                                      <<07039>>61060000
          comm(fixlevel') := fixlevel;                         <<07039>>61065000
          comm(coldloadid') := coldloadid;                     <<07039>>61070000
          comm(updatel') := updatel;                           <<07039>>61075000
          comm(version') := version cat %40 (0:8:8);           <<07039>>61080000
          comm(serialdiscload').loadtype:=if                   <<07039>>61085000
          magtape then 0 else 1;                               <<02509>>61090000
          comm(serialdiscload').loaddate:=if                   <<07039>>61095000
          future'date then 1 else 0;                           <<00150>>61100000
          comm(serialdiscload').loadfos := if                  <<i8894>>61105000
          fostape then 1 else 0;                               <<i9075>>61110000
          comm(taperecsize') := taperecsize;                   <<07039>>61115000
          writetape(ctab0,ctab0size,1);                                 61120000
          writetape(comm,commsize,1);                          <<07039>>61125000
          writetape(csdvr,csdvrtsize,1);                                61130000
          writetape(csdef,csdefsize,1);                                 61135000
                                                                        61140000
                                                                        61145000
          <<-------------------                                         61150000
            dump configurator                                           61155000
          ------------------->>                                         61160000
          segtotape(rec0(3),rec0(2),1);  <<write db area to tape>>      61165000
          zerobuf(lbuf,384);                                   <<03544>>61170000
          tos := rec0(9)+firstcst;                                      61175000
          assemble(tsbc 0);                                             61180000
          tos := initdb;                                       <<03604>>61185000
          lbuf(markersize-1) := tos;  <<db>>                   <<03604>>61190000
          lbuf(x:=x-1) := tos;      <<bank>>                   <<03604>>61195000
          lbuf(x:=x-1) := 4;        <<delta q>>                <<03604>>61200000
          lbuf(x:=x-1) := tos; <<status>>                               61205000
          lbuf(x:=x-1) := tapeentry;  <<delta p>>                       61210000
          writetape(lbuf,markersize,1);                        <<02509>>61215000
                                                               <<06811>>61220000
          <<------------------------------->>                  <<06811>>61225000
          <<  dump tables                  >>                  <<06811>>61230000
          <<------------------------------->>                  <<06811>>61235000
                                                               <<06811>>61240000
         writedsegtotape(dvrtab'dst'index,(hldev+1)*dvrsize,1);<<w8927>>61245000
         writedsegtotape(lpdt'dst'index,(hldev+1)*lpdtsize,1); <<w8927>>61250000
         writedsegtotape(ldt'dst'index,(hldev+1)*ldtsize,1);   <<w8927>>61255000
         writedsegtotape(ldtx'dst'index,(hldev+1)*ldtxsize,1); <<w8927>>61260000
          x := 0;                                              <<03604>>61265000
          while x < nstartseg do                               <<03604>>61270000
             begin                                             <<03604>>61275000
             segtotape(segadr(x),segsize(x),1);                <<03604>>61280000
             x:=x+1;                                           <<03604>>61285000
             end;                                              <<03604>>61290000
          if not magtape then                                  <<02509>>61295000
             begin                                             <<02509>>61300000
             i := 1;                                           <<02509>>61305000
             while i <= blockn do                              <<02509>>61310000
                begin                                          <<02509>>61315000
                temp := findsdiscgap(sdiscldev,i,discaddress); <<02509>>61320000
                if temp <> 0 then ferror(tapefnum,tapefile);   <<02509>>61325000
                @pntr := @tape'fmt'tab(i*entry'size);          <<02509>>61330000
                discadr1 := d1;                                <<02509>>61335000
                discadr2 := d2;                                <<02509>>61340000
                i := i+1;                                      <<02509>>61345000
                end;                                           <<02509>>61350000
                                                               <<03544>>61355000
             << build channel program on serial disc.   >>     <<03544>>61360000
             << there are different channel programs    >>     <<03544>>61365000
             << for seriesii'iii, hpib 13037-controlled >>     <<03544>>61370000
             << discs, and cs'80 discs.  we dump out    >>     <<03544>>61375000
             << two channel programs in case the disc   >>     <<03544>>61380000
             << will be used on a series ii/iii over    >>     <<03544>>61385000
             << the hpib interface and over a regular   >>     <<03544>>61390000
             << sio disc.                               >>     <<03544>>61395000
                                                               <<03544>>61400000
             build'sio'sdisc( tape'fmt'tab);                   <<03544>>61405000
             if outdevtype = disc3 then                        <<03702>>61410000
                build'cs80'sdisc( tape'fmt'tab)                <<03544>>61415000
             else                                              <<03544>>61420000
                build'amigo'sdisc( tape'fmt'tab);              <<03544>>61425000
                                                               <<02509>>61430000
             if postseries3 then                               <<03005>>61435000
                begin                                          <<03005>>61440000
                compute'wcs'size;                              <<03005>>61445000
                dump'wcs;                                      <<03005>>61450000
                end;                                           <<03005>>61455000
             end;                                              <<02509>>61460000
                                                               <<00.sd>>61465000
        x := nstartseg; <<write disc res. segs of init>>       <<03604>>61470000
        while x < nseg do                                      <<03604>>61475000
           begin                                               <<03604>>61480000
           segtotape(segadr(x),segsize(x),0);                  <<03604>>61485000
           x:=x+1;                                             <<03604>>61490000
           end;                                                <<03604>>61495000
        fclose(initfnum,0,0);                                  <<00.sd>>61500000
        if <> then goto initerr;                               <<00.sd>>61505000
                                                                        61510000
          <<--------------------------                                  61515000
            alter and dump rin table                                    61520000
          -------------------------->>                                  61525000
          if null'date then goto direof;                       <<00072>>61530000
                                                               <<06814>>61535000
          gllen := grins*12+4;                                 <<06814>>61540000
          nrinlen := (ctab(rins')+1)*3+ctab(grins')*12+4;      <<06814>>61545000
          if rins <> ctab(rins') or grins <> ctab(grins') then <<06814>>61550000
             begin                                             <<06814>>61555000
             if nrinlen > rinlen then                          <<06814>>61560000
                begin                                          <<06814>>61565000
                altdseg( rindseg, nrinlen-rinlen, i);          <<06814>>61570000
                if <> then debug;                              <<06814>>61575000
                end;                                           <<06814>>61580000
             mfds( glarea, rindseg, 1, 1);                     <<06814>>61585000
             nglarea := (ctab(rins')+1)*3;                     <<06814>>61590000
             if nglarea < glarea then                          <<06814>>61595000
                mds( rindseg, nglarea, rindseg, glarea, gllen);<<06814>>61600000
             if nglarea > glarea then                          <<06814>>61605000
                mds( rindseg, nglarea+gllen-1, rindseg,        <<06814>>61610000
                     glarea+gllen-1, -gllen);                  <<06814>>61615000
             k := nglarea-glarea;                              <<06814>>61620000
             mtds( rindseg, 1, nglarea, 1);                    <<06814>>61625000
             << zero new rin area >>                           <<06814>>61630000
             if k > 0 then                                     <<06814>>61635000
                begin                                          <<06814>>61640000
                loc := 0;                                      <<06814>>61645000
                mtds( rindseg, glarea, loc, 1);                <<r8757>>61650000
                mds( rindseg, glarea+1, rindseg,               <<r8757>>61655000
                   glarea, k-1);                               <<r8757>>61660000
                end;                                           <<06814>>61665000
             grins := ctab(grins');                            <<06814>>61670000
             rins := ctab(rins');                              <<06814>>61675000
             end;                                              <<06814>>61680000
          compactrin;                                          <<06814>>61685000
          writedsegtotape( rindseg, nrinlen, 0);               <<06814>>61690000
          freedseg( rindseg, 0);                               <<06814>>61695000
                                                                        61700000
   if dumpdate = -1 then goto direof;                          <<00506>>61705000
   if (newlidtablen:=ctab(nlogprocs) * 33 + 33) >              <<*7833>>61710000
         lidtablen then                                        <<*7833>>61715000
      begin                                                    <<00506>>61720000
      <<table was made larger>>                                <<*7833>>61725000
      lidtabincr := newlidtablen - lidtablen;                  <<*7833>>61730000
      movedltables;                                            <<*7833>>61735000
            message(m2466);                                    <<*8393>>61740000
      i:=1;                                                    <<*7833>>61745000
      do                                                       <<*7833>>61750000
         lidtab(lidtablen+i*33-1):=-1                          <<*7833>>61755000
      until (lidtablen+(i:=i+1)*33) > newlidtablen;            <<*7833>>61760000
      lidtab(1):=ctab(nlogprocs);                              <<*7833>>61765000
      lidtab(2):=lidtab(2)+(newlidtablen-lidtablen)/33;        <<*7833>>61770000
      end;                                                     <<*7833>>61775000
   writetape(lidtab,newlidtablen,0);                           <<00506>>61780000
          <<----------------                                            61785000
            dump directory                                              61790000
          ---------------->>                                            61795000
          dumpdirc (ctab(dirsect'), dirdiscadr, direc);        <<de>>   61800000
  direof: fcontrol(tapefnum,6,i);  <<write file mark>>                  61805000
          if <> then goto tapeerr;                                      61810000
                                                                        61815000
          <<---------------------                                       61820000
            dump system library                                         61825000
          --------------------->>                                       61830000
          @bpnotdump := @notdump;                                       61835000
          tempslopen := true;                                           61840000
          fdump(pslfile);   <<dump system library>>                     61845000
          if tempslsaved then                                           61850000
            begin   <<purge tempsl>>                                    61855000
              tslfnum := fopen(tslfile,%(2)10);                         61860000
              fclose(tslfnum,4,0);                                      61865000
              tempslsaved := false;                                     61870000
            end;                                                        61875000
          segment(8) := " ";                                            61880000
                                                                        61885000
          <<----------------------                                      61890000
            dump system programs                                        61895000
          ---------------------->>                                      61900000
          x := -8;                                                      61905000
          i := 0;                                                       61910000
          do                                                            61915000
            begin    <<dump system programs>>                           61920000
              move segment:=  sysprog(x:=x+8),(8);             <<00598>>61925000
              fdump(segment);                                           61930000
            end                                                         61935000
          until (i:=i+1) = nsysprog;                                    61940000
          if postseries3 then                                  <<01402>>61945000
             begin <<system programs unique to series'33>>     <<00454>>61950000
             x:=-8;                                            <<00150>>61955000
             i:=0;                                             <<00150>>61960000
             do                                                <<00150>>61965000
                begin                                          <<00150>>61970000
                move segment:=sysprog'33(x:=x+8),(8);          <<00454>>61975000
                fdump(segment);                                <<00150>>61980000
                end                                            <<00150>>61985000
             until (i:=i+1)=nsysprog'33;                       <<00454>>61990000
             end;  <<system programs unique to series'33>>     <<00454>>61995000
             if seriesii'iii then                              <<02509>>62000000
                begin <<unique system programs>>               <<00454>>62005000
                x:=-8;                                         <<00454>>62010000
                i:=0;                                          <<00454>>62015000
                do                                             <<00454>>62020000
                   begin                                       <<00454>>62025000
                   move segment:=sysprog'2(x:=x+8),(8);        <<00454>>62030000
                   fdump(segment);                             <<00454>>62035000
                   end                                         <<00454>>62040000
                until (i:=i+1)=nsysprog'2;                     <<00454>>62045000
                end;  <<unique system programs>>               <<00454>>62050000
          if fostape then                                      <<i9075>>62055000
             begin                                             <<i9075>>62060000
             x := -8;                                          <<i9075>>62065000
             i :=  0;                                          <<i9075>>62070000
             do                                                <<i9075>>62075000
               begin                                           <<i9075>>62080000
               move segment :=  fosfiles(x:=x+8),(8);          <<i9075>>62085000
               fdump(segment);                                 <<i9075>>62090000
               end                                             <<i9075>>62095000
             until (i := i+1) = nfosfiles;                     <<i9075>>62100000
             end;     <<unique fos program files>>             <<i9075>>62105000
                                                               <<i9075>>62110000
          i := -1;                                                      62115000
          temp := comm(numadvrs);                              <<07039>>62120000
          x := -8;                                                      62125000
          while(i:=i+1)<temp do                                         62130000
            begin   <<dump cs drivers>>                                 62135000
            move segment:=bcsdvr(x:=x+8),(8);                           62140000
            fdump(segment);                                             62145000
            end;                                                        62150000
          i := 0;                                                       62155000
          tos := @lbuf(3) & lsl(1);                            <<07385>>62160000
          do                                                            62165000
            begin   <<dump non-std. drivers>>                           62170000
              get'ldev'entries(i);                             <<06762>>62175000
              move lbuf := dvrtab,(dvrsize);                   <<06762>>62180000
              if bps0=0 then goto nextdp;                               62185000
              j := 0;                                                   62190000
              x := -8;                                                  62195000
              do                                                        62200000
                begin   <<check for system program>>                    62205000
                  duplicate;                                            62210000
                  if * = sysprog(x:=x+8),(8) then go nextdp;   <<00598>>62215000
                end                                                     62220000
              until (j:=j+1)=nsysprog;                                  62225000
              j:=0;                                            <<00454>>62230000
              x:=-8;                                           <<00454>>62235000
              do                                               <<00454>>62240000
                begin <<check unique system programs>>         <<00454>>62245000
                duplicate;                                     <<00454>>62250000
                if *=sysprog'2(x:=x+8),(8) then                <<00454>>62255000
                  goto nextdp;                                 <<00454>>62260000
                end                                            <<00454>>62265000
              until (j:=j+1)=nsysprog'2;                       <<00454>>62270000
              j:=0;                                            <<00454>>62275000
              x:=-8;                                           <<00454>>62280000
              do                                               <<00454>>62285000
                begin <<check unique system programs>>         <<00454>>62290000
                duplicate;                                     <<00454>>62295000
                if *=sysprog'33(x:=x+8),(8) then               <<00454>>62300000
                  goto nextdp;                                 <<00454>>62305000
                end                                            <<00454>>62310000
              until (j:=j+1)=nsysprog'33;                      <<00454>>62315000
              j := 0;                                          <<02026>>62320000
              do                                                        62325000
                begin   <<check for already dumped>>                    62330000
                  duplicate;                                            62335000
                  get'ldev'entries(j);                         <<07416>>62340000
                  tos := @dvrname & lsl(1);                    <<06762>>62345000
                  if * = *,(8) then goto nextdp;                        62350000
                end                                                     62355000
              until (j:=j+1) = i;                                       62360000
              duplicate;                                                62365000
              move segment := *,(8); << to insure spec terminate char>> 62370000
              fdump(segment);                                           62375000
  nextdp:   end                                                <<06762>>62380000
          until (i:=i+1) > hldev;                                       62385000
          fcontrol(tapefnum,6,i);  <<write file mark>>                  62390000
          if <> then goto tapeerr;                                      62395000
                                                                        62400000
          <<-----------------                                           62405000
            dump user files                                             62410000
          ----------------->>                                           62415000
          setservice(0);                                                62420000
         if sirs then                                          <<00208>>62425000
            begin                                              <<00208>>62430000
            relsir(dirsir,dsir);                               <<00208>>62435000
            relsir(flabsir,fsir);                              <<00208>>62440000
            relsir(fmavtsir,fmsir);                            <<00208>>62445000
            sirs := false;                                     <<00208>>62450000
            end;                                               <<00208>>62455000
                                                               <<02567>>62460000
<< do kludge for 6250 bpi default case >>                      <<02567>>62465000
                                                               <<02567>>62470000
   setup'flags(systape,density,tapefile,fstore'flag,errnum);   <<02567>>62475000
   if errnum <> 0 then                                         <<02567>>62480000
      begin                                                    <<02567>>62485000
      if errnum < 0 then                                       <<02567>>62490000
         ferror(systape,tapefile)  << file error.  exits !! >> <<02567>>62495000
      else                                                     <<02567>>62500000
         evalreturn(0,xretpmaskfail);  << cant find feq >>     <<02567>>62505000
      end;                                                     <<02567>>62510000
                                                               <<02567>>62515000
          if null'date or future'date then                     <<00072>>62520000
            begin                                              <<s7509>>62525000
            fill'(store'files',store'files'len," ");           <<s7509>>62530000
            move store'files':=("NOFILES-NOFILES",cr);         <<s7509>>62535000
            end;                                               <<s7509>>62540000
                                                               <<00072>>62545000
          <<---------------------------------------->>         <<00072>>62550000
          <<start user files on a seperate floppy disc>>       <<00072>>62555000
          <<------------------------------------------>>       <<00072>>62560000
          if floppy then                                       <<00150>>62565000
             begin                                             <<00072>>62570000
             message(m2464); <<end of system section>>         <<*8393>>62575000
             nextreel;                                         <<00072>>62580000
             fcontrol(tapefnum,6,i);                           <<00072>>62585000
             if <> then ferror(tapefnum,tapefile);             <<00072>>62590000
             fcontrol(tapefnum,6,i);                           <<00072>>62595000
             if <> then ferror(tapefnum,tapefile);             <<00072>>62600000
             end;                                              <<00072>>62605000
                                                               <<00072>>62610000
   store'user'files (systape, show,                            <<04933>>62615000
                     false,            <<not syntax only>>     <<04933>>62620000
                     errnum, err'subclass);                    <<04933>>62625000
                                                               <<04933>>62630000
   while errnum = s'err'syntax do                              <<04933>>62635000
      begin                                                    <<04933>>62640000
      get'file'subset;                                         <<04933>>62645000
      show:=yesanswer(m2462);                                  <<*8393>>62650000
      store'user'files (systape, show,                         <<04933>>62655000
                        false,         <<not syntax only>>     <<04933>>62660000
                        errnum, err'subclass);                 <<04933>>62665000
      end;                                                     <<04933>>62670000
                                                               <<04933>>62675000
   fclose (tapefnum, 3, 0);    <<close temp no rewind>>        <<04933>>62680000
   fclose (systape, 3, 0);     <<close with no rewind >><<???>><<04933>>62685000
                                                               <<06762>>62690000
   << release extra data segments  >>                          <<06762>>62695000
                                                               <<06762>>62700000
   freedseg(ldt'dst'index,0);                                  <<06762>>62705000
   freedseg(lpdt'dst'index,0);                                 <<06762>>62710000
   freedseg(ldtx'dst'index,0);                                 <<06762>>62715000
   freedseg(dvrtab'dst'index,0);                               <<06762>>62720000
                                                               <<06762>>62725000
     end;                                                      <<01073>>62730000
$page "             LIST SYSTEM FILES NOT FOUND"               <<01073>>62735000
$control segment=sysdump                                       <<01073>>62740000
     procedure list'sys'files;                                 <<01073>>62745000
     option privileged,uncallable;                             <<01073>>62750000
     begin                                                     <<01073>>62755000
          if @notdump <> @bpnotdump then                                62760000
            begin   <<list programs not dumped>>                        62765000
              message(m2460);                                  <<*8393>>62770000
              tos := @notdump;                                          62775000
  nextnot:    x := bps0-1;                                              62780000
              tos := tos+1;                                             62785000
              move binbuf := *, (x),1;                                  62790000
              assemble(delb,dup);                                       62795000
              print(inbuf,-x,0);                                        62800000
              if tos<>@bpnotdump then goto nextnot;                     62805000
            end;                                                        62810000
       if default then                                         <<01210>>62815000
         begin                                                 <<01210>>62820000
          move binbuf := "TOTAL SYSTEM FILE SPACE ",2;         <<00928>>62825000
          tos := tos+dascii(systemfilespace,10,bps0);          <<00928>>62830000
          x := tos-@binbuf;                                    <<00928>>62835000
          print(inbuf,-x,0);                                   <<00928>>62840000
         end;                                                  <<01210>>62845000
     end;                                                      <<01073>>62850000
$page "STORE/RESTORE INTERFACE"                                <<04659>>62855000
procedure store'user'files (systape, show, syntax'only,        <<04659>>62860000
                            error'code, error'subclass);       <<04659>>62865000
         value   show, systape, syntax'only;                   <<04659>>62870000
         logical show, syntax'only;                            <<04659>>62875000
         integer error'code, error'subclass, systape;          <<04659>>62880000
                                                               <<04659>>62885000
      <<---------------------------------------------------->> <<04659>>62890000
      << this procedure invokes store as a separate process.>> <<04659>>62895000
      << the list of files to store, and the list of store  >> <<04659>>62900000
      << options are passed via the info parameter.         >> <<04659>>62905000
      <<                                                    >> <<04659>>62910000
      << two new keywords are appended to the options list: >> <<04659>>62915000
      <<    density=the tape density                        >> <<04659>>62920000
      << and                                                >> <<04659>>62925000
      <<    recsize=the tape recsize.                       >> <<04659>>62930000
      << these two new options, usable only by sysdump, are >> <<04659>>62935000
      << added to store to properly handle the problem of   >> <<04659>>62940000
      << multi-density devices like the 7976.               >> <<04659>>62945000
      <<                                                    >> <<04659>>62950000
      << if the user answered "YES" to the sysdump question:>> <<04659>>62955000
      <<    list files dumped?                              >> <<04659>>62960000
      << then show=true, and we will append a ";SHOW" to    >> <<04659>>62965000
      << the store options list.                            >> <<04659>>62970000
      <<                                                    >> <<04659>>62975000
      << store communicates its success or failure via the  >> <<04659>>62980000
      << mail intrinsics.  a value of good in the mail slot >> <<04659>>62985000
      << mail'overall indicates a successful store.  if any >> <<04659>>62990000
      << thing went wrong, the slot mail'why tells what     >> <<04659>>62995000
      << state store was in at the time of the error.       >> <<04659>>63000000
      <<---------------------------------------------------->> <<04659>>63005000
                                                               <<04659>>63010000
   begin                                                       <<04659>>63015000
                                                               <<04659>>63020000
   equate                                                      <<04659>>63025000
      info'len    = 301,      <<# chars in info' array>>       <<04659>>63030000
      max'item    = 10;       <<maximum # of items>>           <<04659>>63035000
                                                               <<04659>>63040000
   integer array                                               <<04659>>63045000
      info        (0:info'len/2),   <<holds info string>>      <<04659>>63050000
      itemcodes   (0:max'item),     <<used by createprocess>>  <<04659>>63055000
      items       (0:max'item),     <<used by createprocess>>  <<04659>>63060000
      reply'msg   (0:5);            <<holds mail reply>>       <<04659>>63065000
                                                               <<04659>>63070000
   integer                                                     <<04659>>63075000
      cperr       := 0,       <<createprocess error code>>     <<04659>>63080000
      ldev        := 0,       <<ldev of tape/sdisc>>           <<04659>>63085000
      len,                    <<length scanned/moved>>         <<04659>>63090000
      pin         := 0,       <<pin of store.pub.sys>>         <<04659>>63095000
      status      := 0;       <<mail intrinsic status>>        <<04659>>63100000
                                                               <<04659>>63105000
   byte array                                                  <<04659>>63110000
      info'       (*) = info (0),   <<holds info string>>      <<04659>>63115000
      progname'   (0:8+8+8+2);      <<holds: "STORE.PUB.SYS ">><<04659>>63120000
                                                               <<04659>>63125000
   byte pointer                                                <<04659>>63130000
      poptions,               <<points to options list>>       <<04659>>63135000
      pt;                     <<scratch pointer>>              <<04659>>63140000
                                                               <<04659>>63145000
   define                                                      <<04659>>63150000
      den'option  = 46 #,     <<ffileinfo item# for density>>  <<04659>>63155000
      failed      = false #,                                   <<04659>>63160000
      good        = true #,                                    <<04659>>63165000
      ldev'option = 6 #,      <<ffileinfo item# for ldev>>     <<04659>>63170000
      unknown'prog'file = (cperr = 6) #;                       <<04659>>63175000
                                                               <<04659>>63180000
   equate                                                      <<04659>>63185000
         <<store "states"...>>                                 <<04659>>63190000
      why'good       = 0,     <<no error found>>               <<04659>>63195000
      why'syntax     = 1,     <<parsing syntax>>               <<04659>>63200000
      why'opening'files=2,    <<opening utility files>>        <<04659>>63205000
      why'indirect   = 3,     <<opening indirect file>>        <<04659>>63210000
      why'opening'tape=4,     <<opening tape file>>            <<04659>>63215000
      why'scanning   = 5,     <<scanning files >>              <<04659>>63220000
      why'doing      = 6,     <<doing actual store/restore>>   <<04659>>63225000
                                                               <<04659>>63230000
         <<mail equates...>>                                   <<04659>>63235000
      mail'overall   = 0,     <<overall result= good/failed>>  <<04659>>63240000
      mail'why       = 1,     <<why error code (see below)>>   <<04659>>63245000
      mail'bad       = 2,     <<mail message index>>           <<04659>>63250000
      mail'good      = 3,     <<# of files stored/restored>>   <<04659>>63255000
                                                               <<04659>>63260000
      mail'length    = 4;     <<# of words in mail message>>   <<04659>>63265000
                                                               <<04659>>63270000
   label                                                       <<04659>>63275000
      end'store'user'files;                                    <<04659>>63280000
                                                               <<04659>>63285000
   <<-------->>                                                <<04659>>63290000
   <<  fail  >>                                                <<04659>>63295000
   <<-------->>                                                <<04659>>63300000
                                                               <<04659>>63305000
   subroutine fail (why, sub'why);                             <<04659>>63310000
            value   why, sub'why;                              <<04659>>63315000
            integer why, sub'why;                              <<04659>>63320000
      begin                                                    <<04659>>63325000
                                                               <<04659>>63330000
      error'code:=why;                                         <<04659>>63335000
                                                               <<04659>>63340000
      error'subclass:=sub'why;                                 <<04659>>63345000
                                                               <<04659>>63350000
      go end'store'user'files;                                 <<04659>>63355000
                                                               <<04659>>63360000
      end <<fail sub>>;                                        <<04659>>63365000
                                                               <<04659>>63370000
   <<---------------->>                                        <<04659>>63375000
   <<  prepare'info  >>                                        <<04659>>63380000
   <<---------------->>                                        <<04659>>63385000
                                                               <<04659>>63390000
   subroutine prepare'info;                                    <<04659>>63395000
                                                               <<04659>>63400000
      begin                                                    <<04659>>63405000
                                                               <<04659>>63410000
      fill' (info', info'len, cr);                             <<04659>>63415000
                                                               <<04659>>63420000
      if not syntax'only then                                  <<04659>>63425000
         ffileinfo (systape, den'option,  density,             <<04659>>63430000
                             ldev'option, ldev);               <<04659>>63435000
                                                               <<04659>>63440000
            <<find first semicolon in store'files'...>>        <<04659>>63445000
                                                               <<04659>>63450000
      scan store'files' until cr'semi, 1;       <<leave addr>> <<04659>>63455000
      @poptions:=tos;                                          <<04659>>63460000
      len:=@poptions-@store'files';                            <<04659>>63465000
                                                               <<04659>>63470000
         <<note: len > 0, due to code in get'file'subset and>> <<04659>>63475000
         <<in dumptape.>>                                      <<04659>>63480000
                                                               <<04659>>63485000
      move info':="SYSDUMP ",2;                 <<leave addr>> <<04659>>63490000
      move *:=store'files', (len), 2;           <<leave addr>> <<04659>>63495000
      move *:=";*", 2;        <<append ";*">>                  <<04659>>63500000
      @pt:=tos;               <<points after the ";*">>        <<04659>>63505000
                                                               <<04659>>63510000
      scan tapefile until " ", 1;                              <<04659>>63515000
      len:=tos-@tapefile;     <<length of tape name>>          <<04659>>63520000
      move pt:=tapefile, (len), 2;                             <<04659>>63525000
            <<append semicolon after tape name...>>            <<04659>>63530000
      move *:=";", 2;         <<leave address>>                <<04659>>63535000
      @pt:=tos;                                                <<04659>>63540000
                                                               <<04659>>63545000
      if syntax'only then                                      <<04659>>63550000
         begin                                                 <<04659>>63555000
         move pt:="SYNTAX;", 2;                                <<04659>>63560000
         @pt:=tos;                                             <<04659>>63565000
         end;                                                  <<04659>>63570000
                                                               <<04659>>63575000
      if show then                                             <<04659>>63580000
         begin                                                 <<04659>>63585000
         move pt:="SHOW;", 2; <<leave dest addr>>              <<04659>>63590000
         @pt:=tos;                                             <<04659>>63595000
         end;                                                  <<04659>>63600000
                                                               << 8718>>63605000
      << we will specify progress, so that the user will     >><< 8718>>63610000
      << receive progress message.                           >><< 8718>>63615000
      move pt:="PROGRESS;",2;                                  << 8718>>63620000
      @pt:=tos;                                                << 8718>>63625000
                                                               <<04659>>63630000
            <<append recsize...>>                              <<04659>>63635000
                                                               <<04659>>63640000
      if recsize > 0 then                                      <<04659>>63645000
         begin                                                 <<04659>>63650000
         move pt:="RECSIZE=", 2;                               <<04659>>63655000
         @pt:=tos;                                             <<04659>>63660000
         @pt:=@pt+ascii (recsize, 10, pt);                     <<04659>>63665000
         end;                                                  <<04659>>63670000
                                                               <<04659>>63675000
            <<append density...if non-zero...>>                <<04659>>63680000
                                                               <<04659>>63685000
      if density <> 0 then                                     <<04659>>63690000
         begin                                                 <<04659>>63695000
         move pt:=";DENSITY=", 2;                              <<04659>>63700000
         @pt:=tos;                                             <<04659>>63705000
         @pt:=@pt+ascii (density, 10, pt);                     <<04659>>63710000
         end;                                                  <<04659>>63715000
                                                               <<04659>>63720000
            <<append ldev...if non-zero...>>                   <<04659>>63725000
                                                               <<04659>>63730000
      if ldev <> 0 then                                        <<04659>>63735000
         begin                                                 <<04659>>63740000
         move pt:=";LDEV=", 2;                                 <<04659>>63745000
         @pt:=tos;                                             <<04659>>63750000
         @pt:=@pt+ascii (ldev, 10, pt);                        <<04659>>63755000
         end;                                                  <<04659>>63760000
                                                               <<04659>>63765000
            <<append date...>>                                 <<04106>>63770000
                                                               <<04106>>63775000
      if dump'date'(0)<>" " then                               <<04106>>63780000
         begin                                                 <<04106>>63785000
         move pt:=";DATE>=",2;                                 <<04106>>63790000
         move * :=dump'date',(dump'date'len),2;                <<04106>>63795000
         @pt:=tos;                                             <<04106>>63800000
         end;                                                  <<04106>>63805000
                                                               <<04106>>63810000
            <<append a semicolon...>>                          <<04659>>63815000
                                                               <<04659>>63820000
      pt:=";";                                                 <<04659>>63825000
      @pt:=@pt(1);                                             <<04659>>63830000
                                                               <<04659>>63835000
            <<append user's option list, if any...>>           <<04659>>63840000
                                                               <<04659>>63845000
      if poptions <> cr then                                   <<04659>>63850000
         begin                                                 <<04659>>63855000
         scan poptions until cr, 1;                            <<04659>>63860000
         len:=tos-@poptions;                                   <<04659>>63865000
         move pt:=poptions,(len), 2;                           <<04659>>63870000
         @pt:=tos;                                             <<04659>>63875000
         end;                                                  <<04659>>63880000
                                                               <<04659>>63885000
      pt:=cr;                 <<append trailing return>>       <<04659>>63890000
      len:=@pt-@info';        <<length, without cr>>           <<04659>>63895000
                                                               <<04659>>63900000
      end <<prepare'info sub>>;                                <<04659>>63905000
                                                               <<04659>>63910000
   <<--------------->>                                         <<04659>>63915000
   <<  start'store  >>                                         <<04659>>63920000
   <<--------------->>                                         <<04659>>63925000
                                                               <<04659>>63930000
   subroutine start'store;                                     <<04659>>63935000
                                                               <<04659>>63940000
      begin                                                    <<04659>>63945000
                                                               <<04659>>63950000
            <<now, create the store process...>>               <<04659>>63955000
                                                               <<04659>>63960000
      move progname' := "STORE.PUB.SYS ";                      <<04659>>63965000
                                                               <<04659>>63970000
      move itemcodes := (  3, <<flags              >>          <<04659>>63975000
                          11, <<info string address>>          <<04659>>63980000
                          12, <<info string length >>          <<04659>>63985000
                           2, <<parm>>                         <<04659>>63990000
                           0  <<item terminator    >>  );      <<04659>>63995000
                                                               <<04659>>64000000
      items(0) := 1;          <<flags>>                        <<04659>>64005000
      items(1) := @info';     <<info string address>>          <<04659>>64010000
      items(2) := len;        <<info string length>>           <<04659>>64015000
      items(3) := 4;          <<parm meaning sysdump>>         <<04659>>64020000
      items(4) := 0;          <<item terminator>>              <<04659>>64025000
                                                               <<04659>>64030000
      createprocess (cperr, pin, progname', itemcodes, items); <<04659>>64035000
                                                               <<04659>>64040000
      if < then               <<did it fail?>>                 <<04659>>64045000
         begin                                                 <<04659>>64050000
         scan progname' until ".", 1;                          <<04659>>64055000
         move *:=(0);         <<first period or null>>         <<04659>>64060000
               <<report the error...>>                         <<04659>>64065000
         if unknown'prog'file then                             <<04659>>64070000
            fail (s'err'unknown'program, 0)                    <<04659>>64075000
         else                                                  <<04659>>64080000
            fail (s'err'createprocess, cperr);                 <<04659>>64085000
         end                                                   <<04659>>64090000
                                                               <<04659>>64095000
      else if > then                                           <<04659>>64100000
         fail (s'err'createprocess, cperr);                    <<04659>>64105000
                                                               <<04659>>64110000
      end <<start'store sub>>;                                 <<04659>>64115000
                                                               <<04659>>64120000
   <<------------------>>                                      <<04659>>64125000
   <<  wait'for'store  >>                                      <<04659>>64130000
   <<------------------>>                                      <<04659>>64135000
                                                               <<04659>>64140000
   subroutine wait'for'store;                                  <<04659>>64145000
                                                               <<04659>>64150000
      begin                                                    <<04659>>64155000
                                                               <<04659>>64160000
            <<store.pub.sys created ok...activate it and    >> <<04659>>64165000
            <<wait for it to finish...>>                       <<04659>>64170000
                                                               <<04659>>64175000
      activate (pin, 0);          <<don't wait...keep on>>     <<04659>>64180000
                                                               <<04659>>64185000
      if <> then                                               <<04659>>64190000
         fail (s'err'activate, 0);                             <<04659>>64195000
                                                               <<04659>>64200000
      status:=receivemail (pin, reply'msg, true <<wait>>);     <<04659>>64205000
                                                               <<04659>>64210000
      if status <> 2 then     << 2 = got mail ok >>            <<04659>>64215000
         fail (s'err'mail, status);                            <<04659>>64220000
                                                               <<04659>>64225000
      if reply'msg (mail'overall) <> good then                 <<04659>>64230000
         if reply'msg (mail'why) = why'syntax then             <<04659>>64235000
            fail (s'err'syntax, 0)                             <<04659>>64240000
         else                                                  <<04659>>64245000
            fail (s'err'store'failed, reply'msg(mail'why));    <<04659>>64250000
                                                               <<04659>>64255000
                                                               <<04659>>64260000
            <<if we get here, the store worked fine!>>         <<04659>>64265000
                                                               <<04659>>64270000
            <<note that store has nothing left to do >>        <<04659>>64275000
            <<once it has sent mail to us...so we do >>        <<04659>>64280000
            <<not need to worry if it has gone away  >>        <<04659>>64285000
            <<yet.  if it has, fine; if not, our     >>        <<04659>>64290000
            <<termination will terminate it.         >>        <<04659>>64295000
                                                               <<04659>>64300000
                                                               <<04659>>64305000
      end <<wait'for'store sub>>;                              <<04659>>64310000
   <<---------------------------->>                            <<04659>>64315000
                                                               <<04659>>64320000
   error'code:=0;                                              <<04659>>64325000
   error'subclass:=0;                                          <<04659>>64330000
                                                               <<04659>>64335000
   prepare'info;                                               <<04659>>64340000
                                                               <<04659>>64345000
   start'store;                                                <<04659>>64350000
                                                               <<04659>>64355000
   wait'for'store;                                             <<04659>>64360000
                                                               <<04659>>64365000
end'store'user'files:                                          <<04659>>64370000
                                                               <<04659>>64375000
   end <<store'user'files proc>>;                              <<04659>>64380000
$page "FIGURE AUTO BACKUP OPTIONS"                             <<*8393>>64385000
procedure figure'auto'bkup'options(list,string'len,string);    <<*8393>>64390000
   value list,string'len,string;                               <<*8393>>64395000
   logical list;                                               <<*8393>>64400000
   integer string'len;                                         <<*8393>>64405000
   byte pointer string;                                        <<*8393>>64410000
                                                               <<*8393>>64415000
   << set up store/restore options for auto back up:>>         <<*8393>>64420000
   <<                                               >>         <<*8393>>64425000
   << full back up : store every files.             >>         <<*8393>>64430000
   << part back up : store any files modified       >>         <<*8393>>64435000
   <<                after last full back or after  >>         <<*8393>>64440000
   <<                user specified date.           >>         <<*8393>>64445000
   << list = true indicates that list files option  >>         <<*8393>>64450000
   << is requested.                                 >>         <<*8393>>64455000
   << string'len and string specifies the dump date >>         <<*8393>>64460000
   << user entered as command parameter.            >>         <<*8393>>64465000
   << 0 of string'len indicates no date specified.  >>         <<*8393>>64470000
                                                               <<*8393>>64475000
begin                                                          <<*8393>>64480000
   listfiles := list;                                          <<*8393>>64485000
   move store'files' := ("@.@.@",cr);                          <<*8393>>64490000
   if auto'full'bkup then                                      <<*8393>>64495000
      dumpdate:=0                                              <<*8393>>64500000
   else      <<auto'part'bkup >>                               <<*8393>>64505000
      begin                                                    <<*8393>>64510000
         if string'len <> 0 then                               <<*8393>>64515000
            begin                                              <<*8393>>64520000
               move binbuf := string,(string'len);             <<*8393>>64525000
               move binbuf(string'len) := (cr);                <<*8393>>64530000
               if not getdumpdate' then                        <<*8393>>64535000
                  begin                                        <<*8393>>64540000
                     message(m2470);                           <<*8393>>64545000
                     process'cold'load'info(0,24,dumpdate);    <<*8393>>64550000
                  end;                                         <<*8393>>64555000
            end                                                <<*8393>>64560000
         else                                                  <<*8393>>64565000
            process'cold'load'info(0,24,dumpdate);             <<*8393>>64570000
         if dumpdate <> 0 then                                 <<*8393>>64575000
            format'date(dumpdate);                             <<*8393>>64580000
      end;                                                     <<*8393>>64585000
end;                                                           <<*8393>>64590000
$page "UPDATE COLD LOAD INFO"                                  <<*8393>>64595000
procedure update'cold'load'info;                               <<*8393>>64600000
                                                               <<*8393>>64605000
<< if a full back up was done, update the last full>>          <<*8393>>64610000
<< back up date in cold load info table.           >>          <<*8393>>64615000
                                                               <<*8393>>64620000
begin                                                          <<*8393>>64625000
   logical tempdate;                                           <<*8393>>64630000
   if (dumpdate = 0) and (store'files' = "@.@.@") then         <<*8393>>64635000
      begin                                                    <<*8393>>64640000
         tempdate := logical(calendar);                        <<*8393>>64645000
         process'cold'load'info(1,24,tempdate);                <<*8393>>64650000
      end;                                                     <<*8393>>64655000
end;                                                           <<*8393>>64660000
$page "             SYSDUMP OUTER BLOCK"                       <<04659>>64665000
$control segment=sysdump                                       <<01073>>64670000
          go start;                                            <<*8393>>64675000
                                                               <<*8393>>64680000
<< ----------------------------------------------- >>          <<i9075>>64685000
<< note that there are four major entry points into>>          <<i9075>>64690000
<< sysdump.  the distinction between the fos and   >>          <<i9075>>64695000
<< defaults entry point was added because of the   >>          <<i9075>>64700000
<< customer installability feature released for the>>          <<i9075>>64705000
<< mighty mouse mit.  **we also want default to be >>          <<i9075>>64710000
<< true for the fos entry point **.                >>          <<i9075>>64715000
<< ----------------------------------------------- >>          <<i9075>>64720000
                                                               <<i9075>>64725000
fos     : fostape := true;                                     <<i9075>>64730000
defaults: default := true;                                     <<*8393>>64735000
          go start;                                            <<*8393>>64740000
                                                               <<*8393>>64745000
fullbkup: auto'bkup := full'bkup;                              <<*8393>>64750000
          go start;                                            <<*8393>>64755000
                                                               <<*8393>>64760000
partbkup: auto'bkup := part'bkup;                              <<*8393>>64765000
                                                               <<*8393>>64770000
start:    push(status);                                        <<*8393>>64775000
          tos.(2:1) := 0;  <<disable traps>>                            64780000
          set(status);                                                  64785000
          expflag := parmq4;  <<experimental system pass#>>    <<06070>>64790000
          initialization;                                      <<01073>>64795000
          if auto'bkup then go to dialog'completed;            <<*8393>>64800000
          if yesanswer(m2005) then                             <<*8393>>64805000
           begin      << true if changes requested >>          <<01073>>64810000
            initialize'ch;                                     <<01073>>64815000
            do                                                 <<01073>>64820000
              while yesanswer(m2008) do io'config'ch           <<*8393>>64825000
            until checkdev;                                    <<01073>>64830000
            if yesanswer(m3000) then system'table'ch;          <<*8393>>64835000
            if yesanswer(m2700) then misc'config'ch;           <<*8393>>64840000
            if yesanswer(m2650) then logging'ch;               <<*8393>>64845000
            if yesanswer(m2550) then disk'alloc'ch;            <<*8393>>64850000
            if yesanswer(m2750) then scheduling'ch;            <<*8393>>64855000
            if yesanswer(m2751) then seg'limit'ch;             <<*8393>>64860000
            if yesanswer(m2608) then system'prog'ch;           <<*8393>>64865000
            if yesanswer(m2600) then system'sl'ch;             <<*8393>>64870000
            if default then build'mpecheck;                    <<01210>>64875000
           end;                                                <<01073>>64880000
          if getdumpdate then                                  <<01073>>64885000
           begin      << true if dump date supplied >>         <<01073>>64890000
            get'file'subset;                                   <<01073>>64895000
            if yesanswer(m2462) then <<list files dumped?>>    <<*8393>>64900000
             listfiles := true;                                <<01073>>64905000
            end                                                <<04659>>64910000
          else                                                 <<04659>>64915000
            move store'files':="NOFILES-NOFILES";              <<04659>>64920000
                                                               <<04659>>64925000
dialog'completed:                                              <<*8393>>64930000
          if auto'bkup then                                    <<*8393>>64935000
             figure'auto'bkup'options(true,infolen,            <<*8393>>64940000
                                       info);                  <<*8393>>64945000
                                                               <<*8393>>64950000
          dumptape(listfiles);                                 <<01073>>64955000
          list'sys'files;                                      <<01073>>64960000
          update'cold'load'info;                               <<*8393>>64965000
         end.                                                  <<01073>>64970000
