Personal tools
You are here: Home Projects SETL SETL Source code DMP: Print formatted storage dump.
Document Actions

DMP: Print formatted storage dump.

by Paul McJones last modified 2021-03-18 20:22

DMP: Print formatted storage dump. stldmp.opl

       1 .=member intro
       2$           ssssssss   eeeeeeeeee  tttttttttt  ll
       3$          ssssssssss  eeeeeeeeee  tttttttttt  ll
       4$          ss      ss  ee              tt      ll
       5$          ss          ee              tt      ll
       6$          sssssssss   eeeeee          tt      ll
       7$           sssssssss  eeeeee          tt      ll
       8$                  ss  ee              tt      ll
       9$          ss      ss  ee              tt      ll
      10$          ssssssssss  eeeeeeeee       tt      llllllllll
      11$           ssssssss   eeeeeeeeee      tt      llllllllll
      12$
      13$
      14$                ddddddddd   mm      mm  ppppppppp
      15$                dddddddddd  mmm    mmm  pppppppppp
      16$                dd      dd  mmmm  mmmm  pp      pp
      17$                dd      dd  mm mmmm mm  pp      pp
      18$                dd      dd  mm  mm  mm  pppppppppp
      19$                dd      dd  mm  mm  mm  ppppppppp
      20$                dd      dd  mm      mm  pp
      21$                dd      dd  mm      mm  pp
      22$                dddddddddd  mm      mm  pp
      23$                ddddddddd   mm      mm  pp
      24$
      25$
      26$       this software is part of the setl programming system
      27$                address queries and comments to
      28$
      29$                          setl project
      30$                 department of computer science
      31$                      new york university
      32$           courant institute of mathematical sciences
      33$                       251 mercer street
      34$                      new york, ny  10012
      35$
       1 .=member mods
       2
       3
       4$ program revision history
       5$ ------------------------
       6
       7$ this section contains a description of each revision to the program.
       8$ these descriptions have the following format:
       9$
      10$ mm-dd-yy      jdate     author(s)
      11$
      12$ 1.............15........25............................................
      13$
      14$ where mm-dd-yy are the month, day, and year, and jdate is the julian
      15$ date.
      16$
      17$ each time a revision is installed, the author should insert a
      18$ description after line 'mods.21', and change the macro 'prog_level'
      19$ to the current julian date.
      20$
      21$ ......................................................................
stra   1
stra   2
stra   3$ 07/24/84     84206     d. shields and s. freudenberger
stra   4$
stra   5$  1. support short character strings.
stra   6$     module affected:  dspec.
asca   1
asca   2
asca   3$ 03/05/84    84065     s. freudenberger
asca   4$
asca   5$  1. for s37, add option ascii=0/1 such that ascii=1 causes the
asca   6$     library to maintain strings within the heap in ascii.  this
asca   7$     feature is needed to support the nyu ada/ed ada compiler.  this
asca   8$     mod is conditioned by ascebc, which should be enabled for s37.
asca   9$     modules affected: stldmp and dumpblk.
suna   1
suna   2
suna   3$ 02/05/84     84065     s. freudenberger
suna   4$
suna   5$  1. support motorola mc68000 microprocessor on sun workstation.
suna   6$     module affected:  stldmp.
smfb   1
smfb   2
smfb   3$ 08/08/83     83220     s. freudenberger
smfb   4$
smfb   5$  1. a bug in the unix envdsl forces the inclusion of an upper limit on
smfb   6$     the heap size.
smfb   7$     module affected:  stldmp.
smfb   8$  2. before dumping a tuple(untyped real) data block, check whether all
smfb   9$     components are zero.
smfb  10$     module affected:  dumpblk.
smfa   1
smfa   2
smfa   3$ 12/16/82     82350     s. freudenberger
smfa   4$
smfa   5$  1. the data words for long character blocks are printed in a more
smfa   6$     compressed format.
smfa   7$     module affected:  dumpblk.
      22
      23
      24$ 08/12/82     82224     s. freudenberger
      25$
      26$  1. the q2 definitions have been moved into a separate subroutine
      27$     stlini, whose definition should correspond to the definition of
      28$     libpl.stlini.  this enables us to link dmp against stlshr on s32.
      29$     variable declarations global to dmp have been placed into the
      30$     nameset nsdmp, and access statements added as needed.
      31$     modules affected: stldmp, dmpds, and dmpblk.
      32$     module added:     stlini.
      33$  2. the form table dump routine has been updated to reflect the form
      34$     table change.
      35$     module affected:  fmdump.
      36$  3. the variable timestr is initialised before it is used to print the
      37$     phase header.
      38$     module affected:  stldmp.
      39
      40
      41$ 06/01/82     82152     s. freudenberger
      42$
      43$  1. the form table dump routine has been modified, to (a) reflect
      44$     the elimination of the ft_nonzero field; and to (b) dump the
      45$     mixed-tuple table.
      46$     module affected:  fmdump. (for simplicity has been replaced)
      47
      48
      49$ 03/16/82     82075     s. freudenberger
      50$
      51$  1. we introduced several new program parameters, to allow us to dump
      52$     portions of the q2 file selectively:
      53$         fdump=1/1     dump the form table (new feature)
      54$         hdump=1/1     dump the heap proper and the stack
      55$         sdump=1/1     dump the symbol table
      56$     modules affected: stldmp and dumpds.
      57$     module added:     fmdump.
      58$  2. we slightly changed the layout of the environment block.
      59$     module affected:  stldmp and dumpds.
      60$  3. use r32 conditional symbol for standard 32-bit fields.  this
      61$     replaces the field definitions for s32, s37, and s47.
      62$     module affected:  stldmp.
      63
      64
      65$ 01/15/82     82015     s. freudenberger
      66$
      67$  1. stldmp has been modified to print the phase header to the terminal
      68$     whenever the new control card parameter 'termh=0/1' is set.
      69$     new control card parameter:
      70$         termh=0/1           print phase header on the terminal file
      71$     module affected:  stldmp.
      72
      73
      74$ 11/29/81    81333     d.shields
      75$
      76$  1. support s47: amdahl uts (universal timesharing system).
      77$     this implementation runs on s37 architecture using an operating
      78$     system very close to unix (v7), and uses the ascii character set.
      79
      80
      81$ 10/27/81     81300     s. freudenberger
      82$
      83$  1. for the dec vax vms version we now allocate the heap dynamically.
      84$     the heap is now read by the setl library routine rdheap.
      85$     module affected:  stldmp.
      86
      87
      88$ 06/04/81     81155     s. freudenberger
      89$
      90$  1. we accounted for the q2 file format change.
      91$  2. we accounted for the new la_form field for long atom data blocks.
      92
      93
      94$ 04/07/91     81090     s. tihor
      95$
      96$  1. changing q2 format
      97
      98
      99$ 12/05/80     80340     s. tihor
     100$
     101$  1. changing q2 file format
     102
     103
     104$ 11/05/80     80310     s. freudenberger
     105$
     106$  1. the dstr routine has been corrected to print the last
     107$     character of the word it dumps.
     108$  2. the delblk routine has been modified to reflect the
     109$     changes to the storage layout in base element blocks.
     110
     111
     112$ 08/16/80     80231     s. freudenberger
     113$
     114$  1. the little do statement requires that a negative increment is
     115$     parsed with a minus sign.  consequently, the dstr routine had
     116$     to be modified to account for the possible negative value of
     117$     chinc.
     118
     119
     120$ 08/01/80    80214     s. freudenberger
     121$
     122$  1. the new conditional assembly member of compl replaces the
     123$     corresponding section in member stldmp.
     124$  2. the code pointer (codep) has been included into the nameset
     125$     nsgparam.  consequently no declaration is needed in member
     126$     stldmp anymore.
     127
     128
     129$ 07/10/80     80192     s. freudenberger
     130$
     131$  1. for the .+gt - version, calls to checkptr have been made
     132$     dependent on the gtrace flag.
     133$  2. the delblk routine has been modified to dump local sets, too.
     134
     135
     136$ 06/20/80     80172     s. freudenberger
     137$
     138$  1. a bug related to the global string specifiers has been corrected.
     139$  2. the page requirements for dumps have been further reduced.
     140
     141
     142$ 05/27/80     80148     s. freudenberger
     143$
     144$  1. the stldmp utility has been revised.  the new version uses
     145$     less paper per dump.  in the authours opinion, it also produces
     146$     more readable dumps.
     147
     148
     149$ 05/09/80     80130     s. freudenberger
     150$
     151$  1. the is_ebfree flag has been eliminated.
     152$  2. the q2_query and q2_isprim opcodes have been eliminated.
     153
     154
     155$ 04/16/80     80107     s. freudenberger
     156$
     157$ provide a dummy snap routine to suppress the load of most of stllib
     158$ when stldmp is linked.
     159
     160
     161$ 04/11/80     80102     d. shields, m. fulk
     162$
     163$ 1. revise to reflect recent change to heap format.
     164$    this requires new code to read in heap image, and also
     165$    slight change to code to name entries in symbol table.
     166
     167
     168$ 04/09/80     80100     s. freudenberger
     169$
     170$ the loop to dump the symbol table has been given the proper
     171$ bounds.
     172
     173
     174$ 02/04/80     80035     s. freudenberger
     175$
     176$ 1. the sizing of 'dump_title' has been corrected.
     177$
     178$ 2. the global 'cdump' has been dropped from the global nameset defined
     179$    in cmnpl.q2macs, and instead hes been defined global to stldmp.
     180
     181
     182$ 01/21/80     80021     s. freudenberger
     183$
     184$ 1. the form table limit has been increased for the s32.
     185$
     186$ 2. blk_size has been renamed blksz.  modules affected:  dumpds and
     187$    dumpblk.
     188
     189
     190$ 01/17/80     80017     s. freudenberger
     191$
     192$ the layout of the heap has been changed:  snames has been integrated
     193$ into the heap at the low core end, and the run-time symbol table has
     194$ been allocated between the run-time names and the constant  part  of
     195$ the heap.
     196
     197
     198$ 11/30/79     79334     s. freudenberger
     199$
     200$ the dump file format has been changed to the q2 file format.
     201
     202
       1 .=member stlini
       2      subr stlini;
       3
       4 .+set part1
       5 .+set part2
       6 .+set part3
       7 .+set part4
       8
       9 .=include cndasm             $ conditional assembly symbols
      10 .=include sysmac             $ machine parameters
      11
      12 .=include formtab            $ form table
      13
      14 .=include q2flds             $ q2 field definitions to access heap
      15 .=include q2opcd             $ q2 opcodes
      16 .=include q2macs             $ (general) q2 macros
      17 .=include q2vars             $ q2 variables
      18
      19      end subr stlini;
       1 .=member stldmp
       2      prog stldmp;
       3
       4$ this program produces a formatted dump of the setl run time
       5$ environment. its input is a file which is written out by the
       6$ run time library whenever it aborts or encounters a
       7$ 'debug rdmp;' statement.
       8
       9      +* prog_level  =
stra   7          'dmp(84206) '
      11          **
      12
      13      nameset nsdmp;          $ nameset with variables for dmp phase
      14
      15          size dumpno(ps);        $ dump number
      16          data dumpno = 0;
      17
      18          +* dump_file  =  3  **  $ number of dump file
      19
      20          size dump_title(.sds. filenamlen);   $ title of dump file
      21
      22          size cur_dim(ws);       $ current heap dimension
      23          size max_dim(ws);       $ maximum heap dimension
smfb  12          size mh_lim(ps);    $ maximum value for h_lim
      24          size timestr(.sds. 30); $ current time
      25          size termh_flag(1);     $ print phase header on the terminal
      26
      27          size cdump(1);          $ code dump request
      28          size fdump(1);          $ form table dump requested
      29          size hdump(1);          $ heap dump requested
      30          size sdump(1);          $ symbol table dump requested
      31          size skipn(ps);         $ skip first n dumps
      32          size dumpn(ps);         $ dump only n'th dump
      33
      34      end nameset nsdmp;
      35
      36
      37      call stlini;            $ initialise the q2 tables.
      38
      39      monitor noentry;
      40
      41
      42 .+s66    call getspp(dump_title, 'dump=dump/dump');
      43 .+s37    call getspp(dump_title, 'dump=dump/dump');
      44 .+s47    call getspp(dump_title, 'dump=dump/dump');
      45 .+s32    call getspp(dump_title, 'dump=dump.dat/');
      46 .+s10    call getspp(dump_title, 'dump=dump/dump');
      47 .+s20    call getspp(dump_title, 'dump=dump/dump');
suna   8 .+s68    call getspp(dump_title, 'dump=dump/');
smfb  13
smfb  14      call getipp(mh_lim,     'max_heap=0/0');   $ maximum heap length
smfb  15      if (0 < mh_lim & mh_lim < 1024) mh_lim = mh_lim * 1024;
      48
      49      call getipp(cdump,      'cdump=0/1');
      50      call getipp(fdump,      'fdump=1/1');
      51      call getipp(hdump,      'hdump=1/1');
      52      call getipp(sdump,      'sdump=1/1');
      53      call getipp(skipn,      'skip=0/0');
      54      call getipp(dumpn,      'dumpn=0/0');
      55 .+gt call getipp(gtrace,     'gtrace=0/1');
      56      call getipp(termh_flag, 'termh=0/1'); $ print phase header
asca  10
asca  11 .+ascebc.
asca  12      call getipp(ascebc_flag,  'ascii=0/1');  $ ebcdic-to-ascii conv
asca  13      if (ascebc_flag) call aeinit;  $ initialise conversion tables
asca  14 ..ascebc
      57
      58      call lstime(timestr);   $ get current time
      59
      60      if termh_flag then
      61          $ the following line is printed on the terminal file only
      62          call contlpr(26, no);   call contlpr(27, yes);
      63          put ,'  cims.setl.' ,prog_level :timestr ,a ,skip;
      64          call contlpr(26, yes);  call contlpr(27, no);
      65      end if;
      66
      67
      68      file dump_file access = read, title = dump_title;
      69
      70 .+s66    rewind dump_file;
      71
      72
suna   9 .+mhl_dynamic.
      75      $ initially allocate a zero-length heap to set up address
      76      $ registers.
      77
      78      $ first inquire how many words can be allocated.
      79      call envmhl(1, cur_dim, max_dim);
      80
smfb  16      if (0 < mh_lim & mh_lim < max_dim) max_dim = mh_lim;
smfb  17
suna  10 .+s32v.
      81      $ since no more files will be opened in this phase, we can
      82      $ allocate the remaining program (p0) region for the heap.
      83      $ this should guarantee that we can read any heap image.
suna  11 ..s32v
      84      call envmhl(2, cur_dim, max_dim);
suna  12 ..mhl_dynamic
      87
      88      runtime_flag = yes;
suna  13      can_collect = no;
      89$
      90$ open the q2 file and check its format
      91$
      92      while 1;
      93          dumpno = dumpno + 1;  $ increment then print title
      94          call dmpttl(dumpno);
      95
      96          read dump_file, check_word; $ is this a q2 file ?
      97          put ,'file check word:  ' :check_word ,i ,skip;
      98
      99          read dump_file, date_stamp; $ q2 format date
     100          put ,'file format date: ' :date_stamp ,i ,skip(3);
     101
     102          call rdheap(dump_file);
     103
     104          $ check for end-of-file
     105          if (filestat(dump_file, end)) quit while 1;
     106
     107          if (dumpno > skipn & dumpn = 0) ! (dumpno = dumpn) then
     108              call dmpds;
     109          end if;
     110      end while;
     111
     112
     113      end prog stldmp;
       1 .=member dmpttl
       2      subr dmpttl(n);
       3
       4$ print title 'dump no. n'
       5
       6      size n(ps);  $ dump number
       7
       8      size nn(ps),  $ copy of n
       9           j(ps),   $ loop index
      10           str(.sds. 5); $ string for n
      11
      12      nn = n;
      13
      14      str = '     ';
      15
      16      do j = 5 to 1 by -1;
      17          .ch. j, str = mod(nn, 10) + 1r0;
      18          nn = nn/10;
      19
      20          if (nn = 0) quit;
      21      end do;
      22
      23      call stltitle(yes, 'dynamic storage dump no. ' .cc. str);
      24
      25
      26      end subr dmpttl;
       1 .=member dumpds
       2      subr dmpds;
       3
       4$ this routine prints a formatted dump of the heap.
       5$ as we scan the heap, we also check all pointers for validity
       6$ and issue appropriate diagnostics.
       7
       8
       9      size j(ps),   $ loop index
      10           len(ps); $ block length
      11
      12      size blksz(ps);         $ function called
      13
      14      access nsdmp;           $ access variables global to dmp
      15
      16
      17 .+tr monitor noentry;        $ disable entry trace
      18
      19
      20$ print main header
      21      put, x(10), 's t o r a g e   d u m p', skip;
      22      put, x(10), '-----------------------', skip(2);
      23
      24$ print basic environment parameters
      25$
      26      put ,'environment parameters:' ,skip
      27          ,skip
      28          ,'sym_org:   ' :sym_org      ,i(8) ,x(4)
      29          ,'sym_end:   ' :sym_end      ,i(8) ,x(4) ,skip
      30          ,'ca_org:    ' :ca_org       ,i(8) ,x(4)
      31          ,'h_org:     ' :h_org        ,i(8) ,x(4)
      32          ,'h:         ' :h            ,i(8) ,x(4) ,skip
      33          ,'t:         ' :t            ,i(8) ,x(4)
      34          ,'savet:     ' :savet        ,i(8) ,x(4)
      35          ,'h_lim:     ' :h_lim        ,i(8) ,x(4) ,skip
      36          ,'codep:     ' :codep        ,i(8) ,x(4) ,skip
      37          ,skip(2);
      38$
      39$ dump the symbol table, if requested
      40$
      41      if sdump then
      42
      43      put, x(14), 's y m b o l   t a b l e', skip;
      44      put, x(14), '-----------------------', skip(2);
      45
      46
      47$ the symbol table dump works in two modes:
      48$
      49$ len = 0:   dump specifiers
      50$ len ^= 0:  dump untyped data
      51$
      52$ when we encounter a skip word we set len to the number of untyped
      53$ data words; when we dump an untyped word we decrement len.
      54
      55      len = 0;
      56
      57      do j = sym_org to sym_end;
      58          if len = 0 then  $ dump specifier
      59              call dloc(j);   call dspec(j);
      60              if (type(j) = t_skip) len = value(j) - 1;
      61
      62          else
      63              call dloc(j);   call dword(j);
      64              len = len - 1;
      65          end if;
      66      end do;
      67
      68      put, skip(3);
      69
      70      end if;
      71
      72      if (fdump) call fmdump;
      73
      74      if hdump then
      75
      76 $ next dump stack
      77      put, x(19), 's t a c k', skip;
      78      put, x(19), '---------', skip(2);
      79
      80      do j = t to h_lim;
      81          call dloc(j);   call dspec(j);
      82      end do;
      83
      84      put, skip(3);
      85
      86 $ dump heap
      87      put, x(19), 'h e a p', skip;
      88      put, x(19), '-------', skip(2);
      89
      90      j = ca_org;
      91      while j < h;
      92          call dumpblk(j);
      93
      94          len = blksz(j);
      95          if (len > h_lim) quit;
      96
      97          j = j + len;
      98      end while;
      99
     100      end if;
     101
     102
     103      end subr dmpds;
       1 .=member fmdump
       2      subr fmdump;
       3$
       4$ this routine dumps the form table.
       5$
       6      size fm(ps);            $ loop index
       7      size lines(ps);         $ number of lines since last heading
       8      size mc(.sds. 5);       $ map code name
       9      size j1(ps), j2(ps);    $ loop indices
      10
      11      +*  lines_max  =  20  **  $ number of lines between headings
      12
      13      +*  ftname(tp)  =  a_ftname(tp+1)  **  $ array of form type names
      14
      15      size a_ftname(.sds. 7);
      16      dims a_ftname(f_max+1);
      17
      18      data ftname(f_gen)      =  'gen':
      19           ftname(f_sint)     =  'sint':
      20           ftname(f_sstring)  =  'sstring':
      21           ftname(f_atom)     =  'atom':
      22           ftname(f_latom)    =  'latom':
      23           ftname(f_elmt)     =  'elmt':
      24           ftname(f_int)      =  'int':
      25           ftname(f_string)   =  'string':
      26           ftname(f_real)     =  'real':
      27           ftname(f_uint)     =  'uint':
      28           ftname(f_ureal)    =  'ureal':
      29           ftname(f_ituple)   =  'ituple':
      30           ftname(f_rtuple)   =  'rtuple':
      31           ftname(f_mtuple)   =  'mtuple':
      32           ftname(f_ptuple)   =  'ptuple':
      33           ftname(f_tuple)    =  'tuple':
      34           ftname(f_uset)     =  'uset':
      35           ftname(f_lset)     =  'lset':
      36           ftname(f_rset)     =  'rset':
      37           ftname(f_umap)     =  'umap':
      38           ftname(f_lmap)     =  'lmap':
      39           ftname(f_rmap)     =  'rmap':
      40           ftname(f_lpmap)    =  'lpmap':
      41           ftname(f_limap)    =  'limap':
      42           ftname(f_lrmap)    =  'lrmap':
      43           ftname(f_rpmap)    =  'rpmap':
      44           ftname(f_rimap)    =  'rimap':
      45           ftname(f_rrmap)    =  'rrmap':
      46           ftname(f_base)     =  'base':
      47           ftname(f_pbase)    =  'pbase':
      48           ftname(f_uimap)    =  'uimap':
      49           ftname(f_urmap)    =  'urmap':
      50           ftname(f_error)    =  'error':
      51           ftname(f_proc)     =  'proc':
      52           ftname(f_memb)     =  'memb':
      53           ftname(f_lab)      =  'lab';
      54
      55      size mname(.sds. 4);    $ array of ft_mapc names
      56      dims mname(ft_max);
      57
      58      data mname(ft_map)      =  'map':
      59           mname(ft_smap)     =  'smap':
      60           mname(ft_mmap)     =  'mmap';
      61
      62
      63      put ,x(10) ,'f o r m   t a b l e' ,skip
      64          ,x(10) ,'-------------------' ,skip(2);
      65
      66      lines = lines_max;      $ set to force new heading
      67
      68      do fm = 0 to formtabp;
      69
      70          lines = lines + 1;
      71
      72          if lines > lines_max then  $ print heading
      73              put ,skip(2)
      74                      ,'index type    mapc elmt  dom   im    imset '
      75                      ,'base  deref low   lim   hsh nlt samp'
      76                  ,skip
      77                      ,'-------------------------------------------'
      78                      ,'-------------------------------------'
      79                  ,skip;
      80
      81              lines = 1;
      82          end if;
      83
      84          put ,column(01) :fm                  ,i
      85              ,column(07) :ftname(ft_type(fm)) ,a;
      86
      87          if (is_fmap(fm)) put ,column(15) :mname(ft_mapc(fm)) ,a;
      88
      89          put ,column(20) :ft_elmt(fm)  ,i
      90              ,column(26) :ft_dom(fm)   ,i
      91              ,column(32) :ft_im(fm)    ,i
      92              ,column(38) :ft_imset(fm) ,i
      93              ,column(44) :ft_base(fm)  ,i
      94              ,column(50) :ft_deref(fm) ,i;
      95
      96          put ,column(56);
      97          if (ft_type(fm) = f_sint)        put :ft_low(fm)    ,i;
      98          if (is_floc(fm) ! is_fbase(fm))  put :ft_bit(fm)    ,i;
      99
     100          put ,column(62);
     101          if (ft_type(fm) = f_sint)        put :ft_lim(fm)    ,i;
     102          if (ft_type(fm) = f_proc)        put :ft_lim(fm)    ,i;
     103          if (is_ftup(fm) ! is_fbase(fm))  put :ft_lim(fm)    ,i;
     104          if (is_floc(fm))                 put :ft_pos(fm)    ,i;
     105          if (is_frem(fm) & is_fmap(fm))   put :ft_tup(fm)    ,i;
     106
     107          put ,column(68);
     108          if (is_ftup(fm) ! is_fset(fm))   put :ft_hashok(fm) ,i;
     109
     110          put ,column(72);
     111          if (is_ftup(fm) ! is_fset(fm))   put :ft_neltok(fm) ,i;
     112
     113          put ,column(76) :ft_samp(fm)  ,i;
     114
     115          if is_fbase(fm) then
     116              put ,column(86);
     117              do j1 = f_lset to f_lpmap; if ( ^ is_floc(j1)) cont do j1;
     118                  put :ft_num(fm, j1) ,i(5);
     119              end do;
     120          end if;
     121
     122          put ,skip;
     123      end do;
     124
     125      put ,skip;
     126
     127      lines = lines_max;      $ set to force new heading
     128
     129      do j1 = 0 to (mttabp+9)/10;
     130          lines = lines + 1;
     131          if lines > lines_max then
     132              put ,skip(2)
     133                      ,'index      ...0   ...1   ...2   ...3   ...4'
     134                      ,'   ...5   ...6   ...7   ...8   ...9'
     135                  ,skip
     136                      ,'-------------------------------------------'
     137                      ,'-----------------------------------'
     138                  ,skip;
     139               lines = 1;
     140          end if;
     141
     142          put :j1 ,i(5) ,'.   ';
     143
     144          do j2 = 0 to 9; if (j1*10+j2 > mttabp) quit do j1;
     145              if j1*10+j2 = 0 then put ,x(7); cont do j2; end if;
     146              put :mttab(j1*10+j2) ,i(6) ,x;
     147          end do;
     148
     149          put ,skip;
     150
     151      end do;
     152
     153      put ,skip(3);
     154
     155
     156      end subr fmdump;
       1 .=member dloc
       2      subr dloc(p);
       3
       4$ this routine prints a standard header for dumping a heap word.
       5$ we print the address of the word followed by a period and a
       6$ space. if the word is in the symbol table we also print its name.
       7
       8$ if 'p' is in the symbol table, the final cursor position is
       9$ column 30; otherwise it is column 16.
      10
      11
      12      size p(ps);  $ heap pointer
      13
      14      size var_id(sds_sz);
      15
      16
      17      if sym_org <= p & p <= sym_end then
      18          put, column(07): p, i,
      19               column(16): var_id(p, 10), a(10),
      20               column(30);
      21      elseif t <= p & p <= h_lim then
      22          put, column(07): p, i,
      23               column(16);
      24      else
      25          put: p, i;
      26      end if;
      27
      28
      29      end subr dloc;
       1 .=member dspec
       2      subr dspec(p);
       3
       4 $ print symbolic dump of specifier at heap location -p-
       5
       6$ if p is a long type we not only dump it, but check its
       7$ pointer for validity.
       8
       9
      10      size p(ps);   $ pointer to specifier to be dumped
      11
      12      size j(ps);  $ loop index
      13
      14$ tnames maps type codes ti their names.
      15      defzero(tnames, a_tnames);
      16
      17      size a_tnames(.sds. 8);
      18      dims a_tnames(t_max+1);
      19
      20      data tnames(t_int)     =  'int':  $ short int
      21           tnames(t_string)  =  'string':  $ short chars
      22           tnames(t_atom)    =  'atom':  $ short atom
      23           tnames(t_error)   =  'error': $ error
      24           tnames(t_proc)   =  'proc':  $ proc
      25           tnames(t_lab)    =  'lab':   $ label
      26           tnames(t_latom)   =  'latom':  $ 'long' atom
      27           tnames(t_elmt)    =  'elmt':  $ compressed element
      28           tnames(t_lint)    =  'lint':  $ long integer
      29           tnames(t_istring) =  'istring':  $ long chars
      30           tnames(t_real)    =  'real':  $ real
      31           tnames(t_tuple)   =  'tuple':  $ standard tuple
      32           tnames(t_stuple)  =  'stuple':  $ packed or untyped tuple
      33           tnames(t_set)     =  'set':  $ set
      34           tnames(t_map)     =  'map':  $ map
      35           tnames(t_skip)    =  'skip':  $ skip word
      36           tnames(t_oint)    =  'oint':  $ om short int
      37           tnames(t_ostring) =  'ostring':  $ om short chars
      38           tnames(t_oatom)   =  'oatom':  $ om short atom
      39           tnames(t_oerror)  =  'oerror': $ om error
      40           tnames(t_oproc)   =  'oproc':  $ om procedure
      41           tnames(t_olab)    =  'olab':  $ om label
      42           tnames(t_olatom)  =  'olatom':  $ om 'long' atom
      43           tnames(t_oelmt)   =  'oelmt':  $ om compressed element
      44           tnames(t_olint)   =  'olint':  $ om long integer
      45           tnames(t_oistring)=  'oistring':  $ om long chars
      46           tnames(t_oreal)   =  'oreal':  $ om real
      47           tnames(t_otuple)  =  'otuple':  $ om standard tuple
      48           tnames(t_ostuple) =  'ostuple':  $ om packed or untyped tu
      49           tnames(t_oset)    =  'oset':  $ om set
      50           tnames(t_omap)    =  'omap':  $ om map
      51           tnames(t_oskip)   =  'oskip';  $ skip word
      52
      53
      54      if otype(p) > t_max then  $ junk in jeap
      55          put: heap(p), bl, skip;
      56          return;
      57      end if;
      58
      59
      60      put: tnames(otype(p)), a(8),    x(2):
      61           is_shared(p),     b(1, 1), x(2):
      62           is_multi(p),      b(1, 1), x(2);
      63
      64      go to case(type(p)) in t_min to t_lmax;
      65
      66 /case(t_int)/
      67
      68 /case(t_atom)/
      69
      70/case(t_error)/
      71
      72      put: value(p), i, skip;
      73      return;
      74
      75 /case(t_string)/
      76
      77      do j = 1 to sc_nchars(p);
stra   8          put :scchar(heap(p), j),r;  $ print character value
      79      end do;
      80
stra   9      put ,skip;
      82
      83      return;
      84
      85/case(t_proc)/  $ procs
      86
      87/case(t_lab)/  $ labels
      88
      89      put: value(p), i, skip;
      90      return;
      91
      92
      93 /case(t_istring)/
      94
      95 .+ssi.
      96
      97      put: value(p), i, skip;
      98
      99 .-gt if (heap_valid)          call checkptr(p, h_istring);
     100 .+gt if (heap_valid & gtrace) call checkptr(p, h_istring);
     101
     102      return;
     103
     104 ..ssi
     105
     106 .-ssi.
     107      put: ic_ptr(p), i, x(1):
     108           ic_ofs(p), i, x(1):
     109           ic_len(p), i, skip;
     110
     111 .-gt if (heap_valid)          call checkptr(p, h_lstring);
     112 .+gt if (heap_valid & gtrace) call checkptr(p, h_lstring);
     113
     114      return;
     115
     116 ..ssi
     117
     118 /case(t_latom)/
     119
     120/case(t_elmt)/
     121
     122/case(t_lint)/
     123
     124/case(t_real)/
     125
     126/case(t_tuple)/
     127
     128/case(t_stuple)/
     129
     130/case(t_set)/
     131
     132/case(t_map)/
     133
     134$ check that the value is a valid pointer
     135 .-gt if (heap_valid)          call checkptr(p+off_value, 0);
     136 .+gt if (heap_valid & gtrace) call checkptr(p+off_value, 0);
     137
     138      put: value(p), i, skip;
     139
     140      return;
     141
     142
     143/case(t_skip)/
     144
     145      put: value(p), i, skip;
     146      return;
     147
     148      end subr dspec;
       1 .=member dword
       2      subr dword(p);
       3
       4$ this routine dumps untyped data at heap(p) in the same format as
       5$ dspec.
       6
       7
       8      size p(ps);   $ pointer to untyped data
       9
      10
      11      put: heap(p), bl, skip;
      12
      13
      14      end subr dword;
       1 .=member dstr
       2      subr dstr(p);
       3
       4$ this routine dumps a word of a long string data block.
       5$ this would be trivial except that we must cope with
       6$ the so-called 64 character set on the cdc 6600. this
       7$ requires changing the word from zero to blank fill.
       8
       9
      10      size p(ps); $ heap pointer
      11
      12      size j(ps),  $ loop index
      13           ch(chsiz);   $ character from string
      14
      15
      16      j = chorg;
      17      until j > chlst;
      18          ch = .f. j, chsiz, heap(p);
      19 .+s66    if (ch = 0) quit;
      20          put: ch, r(1);
      21
      22          j = j + chinc;
      23      end until;
      24
      25      put, skip;
      26
      27      end subr dstr;
       1 .=member dreal
       2      subr dreal(p);
       3
       4$ dump real data word
       5
       6
       7      size p(ps);   $ pointer to data word
       8
       9
      10      if heap(p) = om_real then
      11          put: heap(p),    bl, skip;
      12      else
      13          put: heap(p),     e, skip;
      14      end if;
      15
      16
      17      end subr dreal;
       1 .=member dumpblk
       2      subr dumpblk(p);
       3
       4$ this routine dumps the heap block pointed to by p.
       5$ we assume that p is a valid pointer, but check all
       6$ pointers in the block it points to.
       7
       8
       9      size p(ps);   $ pointer to block to be dumped
      10
      11      size j(ps),  $ loop index
      12           ht(ps),  $ hedrtype of block
      13           bform(ps),  $ base form
      14           p1(ps), $ extra pointer
      15           n(ps);  $ number of typed local maps
smfa   9      size word(ps);          $ word offset into long character block
smfa  10      size offs(ps);          $ character origin in current word
smfa  11      size ch(chsiz);         $ current character
smfb  18      size flag(1);           $ boolean used in quantifier
      16
smfa  12$ hnames maps headrtypes to their names.
      18      size hnames(.sds. 7);
      19      dims hnames(h_max);
      20
      21      data hnames(h_latom)    =  'latom':  $ long atom
      22           hnames(h_real)     =  'real':  $ real
      23           hnames(h_lint)     =  'lint':  $ long integer
      24           hnames(h_istring)  =  'istring':  $ long chars
      25           hnames(h_lstring)  =  'lstring':  $ long chars
      26           hnames(h_tuple)    =  'tuple':  $ standard tuple
      27           hnames(h_ptuple)   =  'ptuple':  $ packed tuple
      28           hnames(h_ituple)   =  'ituple':  $ integer tuple
      29           hnames(h_rtuple)   =  'rtuple':  $ real tuple
      30           hnames(h_uset)     =  'uset':  $ standard set
      31           hnames(h_lset)     =  'lset':  $ local set
      32           hnames(h_rset)     =  'rset':  $ remote set
      33           hnames(h_rmap)     =  'rmap':  $ remote map
      34           hnames(h_rpmap)    =  'rpmap':  $ remote packed map
      35           hnames(h_rimap)    =  'rimap':  $ remote integer map
      36           hnames(h_rrmap)    =  'rrmap':  $ remote real map
      37           hnames(h_umap)     =  'umap':  $ unbased map
      38           hnames(h_lmap)     =  'lmap':  $ local map
      39           hnames(h_lpmap)    =  'lpmap':  $ local packed map
      40           hnames(h_limap)    =  'limap':  $ local integer map
      41           hnames(h_lrmap)    =  'lrmap':  $ local real map
      42           hnames(h_base)     =  'base':  $ base
      43           hnames(h_ebs)      =  'ebs':  $ set element block
      44           hnames(h_ebm)      =  'ebm':  $ map element block
      45           hnames(h_ebb)      =  'ebb':  $ base element block
      46           hnames(h_ht)       =  'ht':  $ hash table header
      47           hnames(h_htb)      =  'htb':  $ hash table block
      48           hnames(h_code)     =  'code';  $ code
      49
      50      size blksz(ps);         $ returns size of block
asca  15 .+ascebc size ebchar(cs);    $ ascii-to-ebcdic conversion function
      51
      52      access nsdmp;           $ access variables global to dmp
      53
      54
      55 /begin/    $ begin execution
      56
      57      call dloc(p);
      58
      59      ht = htype(p);
      60      if ( ^ (h_min <= ht & ht <= h_max)) go to fail;
      61
      62$ print standard heading then jump on type.
      63      put, column(11):                hnames(ht),    a,
      64           column(20), 'hlink:     ': hlink(p),      i;
      65
      66
      67      go to case(ht) in h_min to h_max;
      68
      69
      70 /case(h_latom)/
      71
      72      put, column(40), 'la_value:  ': la_value(p),  i,
      73           column(60), 'la_form:   ': la_form(p),   i, skip,
      74           column(20), 'la_nlmaps: ': la_nlmaps(p), i,
      75           column(40), 'la_nwords: ': la_nwords(p), i, skip;
      76
      77      if la_nlmaps(p) ^= 0 then  $ dump typed maps
      78          put, column(20), 'typed local maps:', skip;
      79
      80          do j = 1 to la_nlmaps(p);
      81              put, column(24): j, i, ':', column(31);
      82              call dspec(p + atomoffs(j));
      83          end do;
      84      end if;
      85
      86      if la_nwords(p) > hl_latom + la_nlmaps(p) then  $ dump untyped map
      87          put, column(20), 'untyped local maps:', skip;
      88
      89          do j = atomoffs(la_nlmaps(p))+1 to la_nwords(p)-1;
      90              put, column(24): j, i, ':', column(31);
      91              call dword(p+j);
      92          end do;
      93      end if;
      94
      95      go to esac;
      96
      97
      98/case(h_real)/    $ reals
      99
     100      put, column(40), 'rval:      ': rval(p),      e, skip;
     101
     102      go to esac;
     103
     104
     105/case(h_lint)/    $ long int
     106
     107      put, column(40), 'li_nwords: ': li_nwords(p), i, skip;
     108
     109      put, column(20), 'data words:', skip;
     110
     111      do j = hl_lint to li_nwords(p)-1;
     112          put, column(24): j-hl_lint+1, i, ':', column(31);
     113          call dword(p+j);
     114      end do;
     115
     116      go to esac;
     117
     118
     119 /case(h_istring)/
     120
     121 .-ssi  go to fail;
     122
     123 .+ssi.
     124      put, column(40), 'ic_ofs:    ': ic_ofs(p),    i,
     125           column(60), 'ic_len:    ': ic_len(p),    i,
     126           column(80), 'ic_ptr:    ': ic_ptr(p),    i, skip;
     127 ..ssi
     128
     129 .-gt if (heap_valid)          call checkptr(p+off_ic_ptr, h_lstring);
     130 .+gt if (heap_valid & gtrace) call checkptr(p+off_ic_ptr, h_lstring);
     131
     132      go to esac;
     133
     134 /case(h_lstring)/
     135
     136      put, column(40), 'lc_nwords: ': lc_nwords(p), i, skip;
     137
     138      if lc_nwords(p) > hl_lchars then
     139          put, column(20), 'data words:', skip;
     140
smfa  13          word = hl_lchars; offs = chorg;
smfa  14          while word < lc_nwords(p);
smfa  15              put ,column(24) :word-hl_lchars+1,i ,':' ,column(31);
smfa  16              n = 0;
smfa  17              while n < 40 & word < lc_nwords(p);
smfa  18                  do j = 1 to chpw;
smfa  19                      ch = .f. offs, chsiz, heap(p+word);
smfa  20 .+s66                if (ch = 0) quit do;
asca  16 .+ascebc             if (ascebc_flag) ch = ebchar(ch);
smfa  21                      put :ch,r(1); n = n + 1;
smfa  22                      offs = offs + chinc;
smfa  23                  end do;
smfa  24                  put ,' '; word = word + 1; offs = chorg;
smfa  25             end while;
smfa  26             put ,skip;
smfa  27         end while;
     145      end if;
     146
     147      go to esac;
     148
     149 /case(h_tuple)/
     150
     151      call dtup(p);  $ dump header
     152
     153      put, column(20), 'template:  '; call dspec(p + compoffs(0));
     154
     155      if maxindx(p) > 0 then
     156          put, column(20), 'components:', skip;
     157
     158          do j = 1 to maxindx(p);
     159              put, column(24): j, i, ':', column(31);
     160              call dspec(p + compoffs(j));
     161          end do;
     162      end if;
     163
     164      go to esac;
     165
     166 /case(h_ptuple)/
     167
     168      call dtup(p);   $ dump header
     169
     170      if ptuplen(p) > hl_ptuple then
     171          put, column(20), 'data words:', skip;
     172
     173          do j = hl_ptuple to ptuplen(p)-1;
     174              put, column(24): j-hl_ptuple+1, i, ':', column(31);
     175              call dword(p+j);
     176          end do;
     177      end if;
     178
     179      go to esac;
     180
     181
     182 /case(h_ituple)/
     183
     184      call dtup(p);   $ dump header
     185
     186      put, column(20), 'template:  '; call dword(p + compoffs(0));
     187
     188      if maxindx(p) > 0 then
     189          put, column(20), 'components:', skip;
     190
     191          do j = 1 to maxindx(p);
     192              put, column(24): j, i, ':', column(31);
     193              call dword(p + compoffs(j));
     194          end do;
     195      end if;
     196
     197      go to esac;
     198
     199
     200 /case(h_rtuple)/
     201
     202$ there is one special case where we would like to avoid dumping
     203$ an untyped real tuple:
     204
     205$ the compiler usually winds up with a block of unused space at the
     206$ base of the heap. it formats this block into a giant untyped
     207$ real tuple so that it can be processed by the garbage collector.
     208$ after the first garbage collection this block disappears, and the
     209$ first heap block is always the sample value for tuple(untyped int).
     210
     211$ this means that if there is an untyped real tuple at heap(h_org)
     212$ if must be the giant tuple created by the compiler. in this case
     213$ we do not dump its components.
     214
     215      call dtup(p);   $ dump header
     216
smfb  19      flag = yes;  $ assume that all components are zero
smfb  20      do j = 1 to maxindx(p);
smfb  21          if heap(p + compoffs(j)) ^= 0 then flag = no; quit; end;
smfb  22      end do;
smfb  23
smfb  24      if flag then
     218          put, skip, column(20), 'all components zero', skip(2);
     219          return;
     220      end if;
     221
     222      put, column(20), 'template:  '; call dreal(p + compoffs(0));
     223
     224      if maxindx(p) > 0 then
     225          put, column(20), 'components:', skip;
     226
     227          do j = 1 to maxindx(p);
     228              put, column(24): j, i, ':', column(31);
     229              call dreal(p + compoffs(j));
     230          end do;
     231      end if;
     232
     233
     234      go to esac;
     235
     236
     237 /case(h_uset)/
     238
     239 /case(h_umap)/
     240
     241 /case(h_base)/
     242
     243 /case(h_lset)/
     244
     245 /case(h_lmap)/
     246
     247 /case(h_limap)/
     248
     249 /case(h_lrmap)/
     250
     251 /case(h_lpmap)/
     252
     253      call dset(p);   $ print header fields
     254
     255      go to esac;
     256
     257
     258 /case(h_rset)/   $remote set
     259
     260      call dset(p);
     261
     262      if rswords(p) > 0 then
     263          put, column(20), 'data words:', skip;
     264
     265          do j = 0 to rswords(p)-1;
     266              put, column(24): j, i, ':', column(31);
     267              call dword(p + hl_rset + j);
     268          end do;
     269      end if;
     270
     271      go to esac;
     272
     273
     274 /case(h_rmap)/
     275
     276 /case(h_rimap)/
     277
     278 /case(h_rrmap)/
     279
     280 /case(h_rpmap)/
     281
     282      call dset(p);
     283
     284      p = p + hl_rmap;
     285      go to begin;
     286
     287
     288 /case(h_ebs)/    $ element heap blocks
     289
     290 /case(h_ebm)/
     291
     292 /case(h_ebb)/
     293
     294
     295      call delblk(p);
     296
     297      go to esac;
     298
     299 /case(h_ht)/
     300
     301      put, column(40), 'neb:       ': neb(p),       i,
     302           column(60), 'lognhedrs: ': lognhedrs(p), i, skip;
     303
     304      go to esac;
     305
     306
     307/case(h_htb)/                 $ hash table header block
     308
     309      put, column(40), 'is_ebhedr: ': is_ebhedr(p), i,
     310           column(60), 'is_ebtemp: ': is_ebtemp(p), i,
     311           column(80), 'eblink:    ': eblink(p),    i, skip;
     312
     313      go to esac;
     314
     315 /case(h_code)/
     316
     317      put, column(40), 'codenw:    ': codenw(p),    i, skip;
     318
     319$ only dump the code block if requested
     320      if cdump then
     321          put, skip;
     322
     323          p1 = p + hl_code;
     324
     325          while p1 < p + codenw(p);
     326              call dinst(p1);
     327              p1 = p1 + inst_nw;
     328          end while;
     329      end if;
     330
     331      go to esac;
     332
     333/fail/    $ ill-formed block
     334
     335      put, column(11),                '*******',
     336           column(20);                call dword(p);
     337
     338      go to esac;
     339
     340/esac/
     341
     342      put, skip;
     343
     344      end subr dumpblk;
       1 .=member dtup
       2      subr dtup(p);
       3
       4$ dump tuple header at heap(p).
       5
       6      size p(ps);   $ pointer to header block
       7
       8      put, column(40), 'hform:     ': hform(p),     i,
       9           column(60), 'maxindx:   ': maxindx(p),   i,
      10           column(80), 'is_range:  ': is_range(p),  i, skip;
      11
      12      put, column(20), 'is_neltok: ': is_neltok(p), i,
      13           column(40), 'nelt:      ': nelt(p),      i,
      14           column(60), 'is_hashok: ': is_hashok(p), i,
      15           column(80), 'hash:      ': hash(p),      i, skip;
      16
      17      if htype(p) = h_ptuple then
      18          put, column(20), 'ptvals:    ': ptvals(p),    i,
      19               column(40), 'ptbits:    ': ptbits(p),    i,
      20               column(60), 'ptkey:     '; call dspec(p + off_ptkey);
      21      end if;
      22
      23
      24      end subr dtup;
       1 .=member dset
       2      subr dset(p);
       3
       4$ this routine dumps the set header at heap(p).
       5
       6
       7      size p(ps);   $ pointer to set
       8
       9
      10      put, column(40), 'hform:     ': hform(p),     i,
      11           column(60), 'is_elset:  ': is_elset(p),  i,
      12           column(80), 'is_based:  ': is_based(p),  i, skip;
      13
      14      put, column(20), 'is_neltok: ': is_neltok(p), i,
      15           column(40), 'nelt:      ': nelt(p),      i,
      16           column(60), 'is_hashok: ': is_hashok(p), i,
      17           column(80), 'hash:      ': hash(p),      i, skip;
      18
      19      put, column(20), 'is_map:    ': is_map(p),    i,
      20           column(40), 'is_smap:   ': is_smap(p),   i,
      21           column(60), 'is_mmap:   ': is_mmap(p),   i,
      22           column(80), 'hashtb:    ': hashtb(p),    i, skip;
      23
      24      go to case(htype(p)) in h_uset to h_base;
      25
      26
      27 /case(h_uset)/
      28
      29      go to esac;
      30
      31
      32 /case(h_rset)/
      33
      34      put, column(20), 'rs_maxi:   ': rs_maxi(p),   i, skip;
      35
      36      go to esac;
      37
      38
      39 /case(h_rmap)/
      40
      41 /case(h_rpmap)/
      42
      43 /case(h_rimap)/
      44
      45 /case(h_rrmap)/
      46
      47 /case(h_umap)/
      48
      49      go to esac;
      50
      51
      52 /case(h_lset)/
      53
      54 /case(h_lmap)/
      55
      56 /case(h_lpmap)/
      57
      58 /case(h_limap)/
      59
      60 /case(h_lrmap)/
      61
      62      put, column(20), 'ls_word:   ': ls_word(p),   i,
      63           column(40), 'ls_bit:    ': ls_bit(p),    i;
      64
      65      if htype(p) = h_lpmap then
      66          put, column(60), 'ls_bits:   ': ls_bits(p),   i,
      67               column(80), 'ls_key:    '; call dspec(p + off_ls_key);
      68      end if;
      69
      70      put, skip;
      71
      72      go to esac;
      73
      74
      75 /case(h_base)/
      76
      77      put, column(20), 'nlmaps:    ': nlmaps(p),    i, skip;
      78
      79      go to esac;
      80
      81
      82/esac/
      83
      84 .-gt if (heap_valid)          call checkptr(p+off_hashtb, h_ht);
      85 .+gt if (heap_valid & gtrace) call checkptr(p+off_hashtb, h_ht);
      86
      87
      88      end subr dset;
       1 .=member delblk
       2      subr delblk(p);
       3$
       4$ this routine dumps the element data block at p.
       5$
       6      size p(ps);             $ pointer to element block
       7
       8      size bform(ps);         $ base form
       9      size m(ps);             $ number of untyped local maps on base
      10      size n(ps);             $ number of typed local maps on base
      11      size j(ps);             $ loop index
      12
      13      size blksz(ps);         $ returns the size of block p
      14
      15
      16      put, skip;
      17
      18      put, column(20), 'is_ebhedr: ': is_ebhedr(p), i,
      19           column(40), 'is_ebtemp: ': is_ebtemp(p), i,
      20           column(60), 'ebsize:    ': ebsize(p),    i,
      21           column(80), 'eblink:    ': eblink(p),    i, skip;
      22
      23      if htype(p) = h_ebb then
      24          bform = ebform(p);
      25
      26          put, column(20), 'ebform:    ': bform,        i,
      27               column(40), 'ebhash:    ': ebhash(p),    i,
      28               column(60), 'ebindx:    ': ebindx(p),    i,
      29               column(80), 'is_eblive: ': is_eblive(p), i, skip;
      30
      31          put, column(20), 'base:      ': value(ft_samp(bform)), i,
      32               skip;
      33      end if;
      34
      35      put, column(20), 'ebspec:    '; call dspec(p + off_ebspec);
      36
      37      if htype(p) = h_ebm then
      38          put, column(20), 'ebimag:    '; call dspec(p + off_ebimag);
      39      end if;
      40
      41      if htype(p) ^= h_ebb then return; end if;
      42
      43      n = ft_num(bform, f_lmap);
      44
      45      if n > 0 then
      46          put, column(20), 'typed local maps:', skip;
      47
      48          do j = 1 to n;
      49              put, column(24): j, i, ':', column(31);
      50              call dspec(p + localoffs(j));
      51          end do;
      52      end if;
      53
      54      m = 0;
      55
      56      do j = f_limap to f_lrmap;
      57          m = m + ft_num(bform, j);
      58      end do;
      59
      60      if m > 0 then
      61          put, column(20), 'untyped local maps:', skip;
      62
      63          do j = 1 to m;
      64              put, column(24): j, i, ':', column(31);
      65              call dword(p+localoffs(n+j));
      66          end do;
      67      end if;
      68
      69      if localoffs(n+m)+1 < blksz(p) then
      70          put, column(20), 'local sets and packed local maps:', skip;
      71
      72          do j = 1 to blksz(p)-(localoffs(m+n)+1);
      73              put, column(24): j, i, ':', column(31);
      74              call dword(p+localoffs(m+n+j));
      75          end do;
      76      end if;
      77
      78
      79      end subr delblk;
       1 .=member snap
       2      subr snap;
       3$
       4$ this is a dummy routine to suppress the load of the normal snap
       5$ routine found in stllib.
       6$
       7      end subr snap;

« December 2024 »
Su Mo Tu We Th Fr Sa
1 2 3 4 5 6 7
8 9 10 11 12 13 14
15 16 17 18 19 20 21
22 23 24 25 26 27 28
29 30 31
 

Powered by Plone CMS, the Open Source Content Management System

This site conforms to the following standards: