Personal tools
You are here: Home Projects SETL LITTLE Source code REF: Cross-reference processor of the LITTLE compiler. By David Shields.
Document Actions

REF: Cross-reference processor of the LITTLE compiler. By David Shields.

by Paul McJones last modified 2021-03-17 19:51

REF: Cross-reference processor of the LITTLE compiler. By David Shields.

       1 .=member intro
       2 .=title 'ltlref - cross-reference lister'
       3 .=title 'macros'
       4 .=list resume,nodir
       5
       6$      !$&'()*+,-./0123456789:;<=>abcdefghijklmnopqrstuvwxyz^_
       7$     the above line contains, in order of ascii codes, the 56
       8$     characters of the little language, starting in column 7.
       9
      10$ $$          $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$          $$$$$$$$$$
      11$ $$          $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$  $$          $$$$$$$$$$
      12$ $$              $$          $$          $$      $$          $$
      13$ $$              $$          $$          $$      $$          $$
      14$ $$              $$          $$          $$      $$          $$$$$$
      15$ $$              $$          $$          $$      $$          $$$$$$
      16$ $$              $$          $$          $$      $$          $$
      17$ $$              $$          $$          $$      $$          $$
      18$ $$$$$$$$$$  $$$$$$$$$$      $$          $$      $$$$$$$$$$  $$$$$$$$$$
      19$ $$$$$$$$$$  $$$$$$$$$$      $$          $$      $$$$$$$$$$  $$$$$$$$$$
      20$
      21$                 $$$$$$$$$   $$$$$$$$$$  $$$$$$$$$$
      22$                 $$$$$$$$$$  $$$$$$$$$$  $$$$$$$$$$
      23$                 $$      $$  $$          $$
      24$                 $$      $$  $$          $$
      25$                 $$$$$$$$$$  $$$$$$      $$$$$$
      26$                 $$$$$$$$$   $$$$$$      $$$$$$
      27$                 $$   $$     $$          $$
      28$                 $$    $$    $$          $$
      29$                 $$     $$   $$$$$$$$$$  $$
      30$                 $$      $$  $$$$$$$$$$  $$
      31$
      32
      33$     this software is part of the little programming system.
      34$              address queries and comments to
      35$
      36$                       little project
      37$               department of computer science
      38$                    new york university
      39$         courant institute of mathematical sciences
      40$                     251 mercer street
      41$                    new york,  ny  10012
      42$
      43$     this is the cross-reference processor of the little compiler,
      44$     and is known as 'ref'.
      45$
      46$     the author of this program is david shields (cims).
      47$
       1 .=member mods
       2 $    all changes are to insert self-description at -- mods.2 --
dsf    1
dsf    2 $    dsf       d. shields          20-jun-83            level 83171
dsf    3 $
dsf    4 $    revise tables to correspond to current version of lex.
dsf    5 $
dsf    6
utsa   1
utsa   2 $    utsa      d. shields          29-nov-81           level 81333
utsa   3 $
utsa   4 $    support s47: amdahl uts (universal timesharing system).
utsa   5 $    this implementation runs on s37 architecture using an operating
utsa   6 $    system very close to unix (v7), and uses the ascii character set.
utsa   7
dse    1
dse    2 $    dse       d. shields          26-sep-80           level 80270
dse    3 $
dse    4 $    1.  correct filename length for s32.
dse    5 $    2.  avoid bringing forward parts of previous lines and
dse    6 $        thus introducing junk characters.
dse    7 $    decks affected - ralist,namlist
dse    8 $
dsd    1
dsd    2 $    dsd       d. shields          15-jan-80           level 80015
dsd    3 $
dsd    4 $    1.  revise to reflect changes in lex (mod dsu) that permit input
dsd    5 $        file to have more than 32767 lines.
dsd    6 $    2.  permit up to 500 procedures.
dsd    7 $    3.  drop obsolete procedure ioexec.
dsd    8 $    decks affected - macros, ioexec (deleted).
dsd    9
vax    1
vax    2 $    vax       d. shields          21 nov 78           level 78325
vax    3 $              r. kenner
vax    4 $
vax    5 $    add configuration values for s32: dec vax-11/780.
vax    6 $    decks affected - macros, start, refini.
vax    7
       3
       4 $    dsc       d. shields          25 sep 78           level 78268
       5 $
       6 $    1.  adapt for s10.
       7 $    2.  remove  =title, =eject  lines.
       8 $    decks affected - all (resequence source).
       9
      10
      11 $    rbkb      r. kenner           28 feb 78           level 78059
      12 $
      13 $    fix miscellaneous bugs detected porting to s37.
      14 $    decks affected - macros (access_read macro only), ltlref, ralist
      15
      16
      17 $    dsc       d. shields          29 jul 77           level 77210.
      18 $
      19 $    1.  allow empty procedure file (file 3).
      20 $    2.  drop reference files using dropsio, since ref is last
      21 $        user of reference files.
      22 $    deck affected - ltlref.
      23
      24
      25
      26 $    dsb       d. shields          20 january 77       level 77020.
      27 $
      28 $    1.  convert to use 'new (level 77.1) library.
      29 $    2.  use -getipp- and -getspp- to retrieve execution parameters.
      30 $    the source has been resequenced.
      31
      32 $    rbka      r. kenner           29 july 76          level 76211
      33 $
      34 $    1.  initialize two uninitialized variables.
      35 $    2.  change 'd' parameter to 'dump' because of s37 conflict.
      36 $    3.  change parameter to -refexit- into global for overlaying.
      37
      38 $    dsa       d. shields          01 july 76          level 76183
      39 $
      40 $    1.  page and title listing.
      41 $    2.  read in page numbers from reference file and, if available,
      42 $        enclose in parentheses and put after procedure name.
      43 $    3.  modify dadims to return amount of available space if desired
      44 $        amount of dynamic storage not available.
      45 $    decks affected - macros, start, dadims, namlist.
      46
       1 .=member macros
       2
       3      $   conditional assembly options.
       4
       5
       6      $   set gf if daget implemented as function.
       7 .+s10.
       8 .+set    gf
       9 ..s10
vax    8 .+s32.
vax    9 .+set    gf
vax   10 ..s32
      10 .+s37.
      11 .+set    gf
      12 ..s37
utsa   8 .+s47.
utsa   9 .+set    gf
utsa  10 ..s47
      13
      14      +*  programlevel =  $ julian date of last program change
dsf    7          'ref(83171)'  $ 20-jun-83
      16      **
      17
      18      +*  ws = .ws. **  $ machine word size in bits.
      19
      20      +*  ps = .ps. **  $ machine pointer (address) size in bits.
      21
      22      +*  cs = .cs. **  $ character size in bits.
      23
      24      +*  slen = .len. **  $ length field of self-defining-string (sds).
      25
      26      +*  sorg = .f. .sl.+1, .so., **  $ origin field of sds.
      27
      28      +*  sds(n) = .sds. (n) **  $ size of n-character sds.
      29
      30      +*  cpw = (ws/cs) **  $ no. of characters in machine word
      31
      38      +*  sdstl = (.sds. 20) **
      39 $    file names of '0' indicate that no i/o is to be done on
      40 $    the file.
      41
      42
      43      +*  spplen =  20 ** $ maximum file name length in chars
dse   10 .+s32  +*  spplen = 64 **  $ account for long vax filename
utsa  11 .+s47  +*  spplen = 64 **  $ account for long vax filename
      44
      45      +*  crfile = 3  **  $ use unit 3 for reference files.
      46
      47      $   io access codes.
      48      +*  access_read = 04 **
      49
      50 $        macros for output
      51
      52 $    procedures called by these macros are in little run-time
      53 $    library.
      54 $    macros are to appear where statement may appear; semicolon indicat
      55 $    end of statement supplied by macro expansion.
      56
      57      +*  charl(c) = call charlr(c); **  $ output character
      58      +*  intl(i) = call intlr(i); **  $ output integer (5 digits)
dsd   11      $   refl is used to list reference line numbers.
dsd   12      +*  refl(i) = call intlpr(i, 6); **
      59      +*  intlp(n,c) = call intlpr(n,c); **  $ output integer in c colum
      60      +*  textl(s) = call textlr(s); **  $ output quoted string
      61      +*  tintl(s,i) = call tintlr(s,i); **  $ output text and integer
      62      +*  wordl(w) = call wordlr(w); **  $ output word (quit in 00)
      63      +*  wordlf(w) = call wordlfr(w); **  $ write word (00 to blank)
      64      +*  getlpos(p) = call contlpr(1,p);** $ put current linepos in p
      65      +*  setlpos(p) = call contlpr(2,p);  ** $ set linepos to p
      66      +*  tabl(p) = call contlpr(4,p); **  $ tab to column p
      67      +*  skipl(i) = call contlpr(3, i);  **  $ skip forward i columns
      68      +*  octl(i) = call octlr(i);**  $ output octal word
      69      +*  tokl(i) = call toklr(i); **  $ list token given hash
      70      +*  endl = call endlr;**  $ end line
      71
      72
      73      +*  q3(a,b,c) = a b c **
      74      +*  macdef(text) = q3(+,*text*,*) **
      75      +*  macdrop(mname) = macdef(mname=) **    $  easy way to drop macr
      76
      77          $   these macros for -yes- and-no- aid readability of
      78          $   expressions involving logical variables
      79
      80      +*  yes = 1 **
      81      +*  no = 0 **
      82
      83
      84
      85 $         table top increment macro
      86
      87      +*  countup(index,limit,ermsg) =
      88          index = index+1;
      89      if  (index>limit) call ltoflo(index,limit,ermsg); **
      90      +*  digofchar(c) = $ decimal value of decimal character
      91          (c-1r0)
      92          **
      93      +*  charofdig(d) = $ character for decimal digit
      94          (d+1r0)
      95          **
      96
      97      +*  getsym(sym, hap)  = $ macro to get name as string given hash
      98          size zzza(ps);  zzza=ha_names haget(hap);  $ position word 1 o
      99 .+s10.
     100 $    move characters from names into global buffer
mgfa   1      .f. 5*ws+1, ws, sym = namesget(zzza);
mgfa   2      .f. 4*ws+1, ws, sym = namesget(zzza + 1);
mgfa   3      .f. 3*ws+1, ws, sym = namesget(zzza + 2);
mgfa   4      .f. 2*ws+1, ws, sym = namesget(zzza + 3);
mgfa   5      .f. 1*ws+1, ws, sym = namesget(zzza + 4);
     105 ..s10
vax   13 .+s32.
vax   14 $    move characters from names into global buffer
vax   15      .f. 5*ws+1, ws, sym = namesget(zzza);
vax   16      .f. 4*ws+1, ws, sym = namesget(zzza + 1);
vax   17      .f. 3*ws+1, ws, sym = namesget(zzza + 2);
vax   18      .f. 2*ws+1, ws, sym = namesget(zzza + 3);
vax   19      .f. 1*ws+1, ws, sym = namesget(zzza + 4);
vax   20 ..s32
     106 .+s37.
     107 $    move characters from names into global buffer
     108 $    (technique exploiting system/370 byte-move ops would be helpful)
     109      .f. 5*ws+1, ws, sym = namesget(zzza);
     110      .f. 4*ws+1, ws, sym = namesget(zzza + 1);
     111      .f. 3*ws+1, ws, sym = namesget(zzza + 2);
     112      .f. 2*ws+1, ws, sym = namesget(zzza + 3);
     113      .f. 1*ws+1, ws, sym = namesget(zzza + 4);
     114 ..s37
utsa  12 .+s47.
utsa  13 $    move characters from names into global buffer
utsa  14 $    (technique exploiting system/370 byte-move ops would be helpful)
utsa  15      .f. 5*ws+1, ws, sym = namesget(zzza);
utsa  16      .f. 4*ws+1, ws, sym = namesget(zzza + 1);
utsa  17      .f. 3*ws+1, ws, sym = namesget(zzza + 2);
utsa  18      .f. 2*ws+1, ws, sym = namesget(zzza + 3);
utsa  19      .f. 1*ws+1, ws, sym = namesget(zzza + 4);
utsa  20 ..s47
     115      size zzzl(ps);  $ for length of token
     116      zzzl = ha_chars haget(hap); if  (zzzl>20) zzzl=20;
     117 .+s66.     $ macro is machine dependent
     118      .f. 121, 60, sym = namesget(zzza);   $ first part of token
     119      .f. 61, 60, sym = namesget(zzza+1);  $ next ten chars
     120 ..s66
     121      slen sym = zzzl; sorg sym = sdstl+1;
     122          **
     123
     124
       1 .=member start
       2      prog start;
       3      $   lcs_opt is on to list statistics, lcp_opt for parameters.
       4      size  lcs_opt(1);  data lcs_opt = yes;
       5      size  lcp_opt(1);  data lcp_opt = yes;
       6
       7      $   dump_opt requests symbolic table dumps.
       8      size  dump_opt(1);  data dump_opt = no;
       9
      10      $   the input reference files are named using the 'rf' parameter.
      11      $   if rf not given, a default name, 'crfileparmdef' is used.
      12      $   the library procedure crfnam converts a name and number into
      13      $   a file name which is kept in crfilename.  crfile is the system
      14      $   defined value returned by -deftape-.
      15      size  crfilename(sds(spplen));  $ name of cr file.
      16      size  crfileparm(sds(spplen));  $ cr file parameter.
      17
      18 $    crbuff is the working buffer for the reference file.
      19 $    all reference files use the same working buffer (record)
      20 $    length, given by the macro crbuffmax.
      21 $    macro crefget is used to get the next word from a reference file.
      22      +*  crbuffmax = 256 **
      23      size  crbuffptr(ps);  data crbuffptr = crbuffmax+1;
      24      size  crbuff(ws);  dims crbuff(crbuffmax);
      25
      26      +*  crefget(w) =  $ read entry from reference file.
      27          if  crbuffptr >= crbuffmax  then  $ if buffer empty
      28              call crfread;  end if;
      29          crbuffptr = crbuffptr +1;
      30          w = crbuff(crbuffptr);
      31          **
      32
      33 $    da (d-ynamic a-rray) is the basic working space.  on systems
      34 $    which support a dynamic array, a more efficient storage use
      35 $    is possible.  the macros -daget- and -daput- are used to
      36 $    access da elements.  the procedure dadims is used to establish
      37 $    the dynamic array.  dapos is the index of the last used element
      38 $    in da, and daptr is the length of da.
      39
      40 .+s66.
      41      $    place da in blank common.  dadims will use resetfl
      42      $   to extend field length to increase length of da.
      43      nameset blank;
      44      size  da(ws);  dims da(2);  $ dynamic array.
      45      end nameset blank;
      46 ..s66
      47      size  daptr(ps);      $  maximum length of da needed.
      48
      49      size  dapos(ps);  $ current position in da.
      50
      51 .+s10.
      52      +*  daget(i) = dagetf(i) **  $ implement as function
      53      +*  daput(i, v) = call daputr(i, v); **
      54 ..s10
vax   21 .+s32.
vax   22      +*  daget(i) = dagetf(i) **  $ implement as function
vax   23      +*  daput(i, v) = call daputr(i, v); **
vax   24 ..s32
      55 .+s37.
      56      +*  daget(i) = dagetf(i) **  $ implement as function
      57      +*  daput(i, v) = call daputr(i, v); **
      58 ..s37
utsa  21 .+s47.
utsa  22      +*  daget(i) = dagetf(i) **  $ implement as function
utsa  23      +*  daput(i, v) = call daputr(i, v); **
utsa  24 ..s47
      59 .+s66.
      60      +*  daget(i) = da(i) **
      61      +*  daput(i, v) = da(i) = v; **
      62 ..s66
      63
      64      size  exitcode(1); data exitcode = 1;  $ return code to -refexit-
      65
      66      $   ha is the symbol table, defined by file 2.
      67      size  halast(ps); data halast = 0;  $ ha index of last entry
      68      size  haused(ps); data haused = 0;  $ ha entries used.
      69      +*  haget(i) = daget(haorg+(i)) **
      70      +*  haput(i, v) = daput(haorg+(i), v); **
dsf    8      +*  ha_chars = .f. 01, 05, **
dsf    9      +*  ha_names = .f. 06, 14, **
dsf   10      +*  ha_order = .f. 20, 13, **
      74      size  halength(ps);  $ length of ha.
      75      size  haorg(ps);  $ origin in da of ha.
      76
      77      $   linestot is the largest line number referenced and is
      78      $   an input parameter obtained from file 2.
      79      size  linestot(ps);  $ total number of lines.
      80
      81      $   names contains the symbols, packed cpw character per entry.
      82      $   the ha field ha_names gives start of name for ha entry.
      83      $   nameslength is the input parameter from file 2 giving number
      84      $   of words needed to store names.
      85      size  namesorg(ps);  $ origin in da of names for ha.
      86
      87      size  nameslength(ps);  $ number of words of names.
      88      size  namescount(ps);   $
      89      +*  namesget(i) = daget(namesorg+(i)) **
      90      +*  namesput(i, v) = daput(namesorg+(i), v); **
      91
      92      size  shaorg(ps);  $ origin in da of ha sort vector.
      93
      94      +*  shaget(i) = daget(shaorg+(i)) **
      95      +*  shaput(i, v) = daput(shaorg+(i), v); **
      96
dsd   13      +*  ra_line = .f. 01, 16, **
dsf   11      +*  ra_ha = .f. 17,13, **
dsf   12      +*  ra_macro = .f. 30, 1, **
     100      size  raorg(ps);
     101
     102      +*  raget(i) = daget(raorg+(i)) **
     103      +*  raput(i, v) = daput(raorg+(i), v); **
     104      size  raptr(ps);
     105
     106      size  reftot(ps);  $ total number of references.
     107
     108      size  procorg(ps);      $  origin in da of procedure list.
     109
     110      +*  procget(i) = daget(procorg+(i)) **
     111      +*  procput(i, v) = daput(procorg+(i), v); **
     112
dsd   16      +*  procmax = 500 **  $ maximum number of procedures.
     114
     115      size  procptr(ps);  $ last used entry in subr list.
     116      size  procent(ws);  $ for building subr entry.
     117      size  procname(ws);  dims procname(20);
     118      size  procpages(ps);  dims procpages(procmax);  $ page numbers.
     119
dsd   17      +*  proc_line = .f. 01, 16, **  $ line no. of first line in routin
dsf   13      +*  proc_ha = .f. 17, 13, **
     122
     123      call refini;
     124      call ltlref;
     125      exitcode = 0; call refexit;
     126      end prog start;
       1 .=member refini
       2      subr refini;  $ intialize
       3      size  i(ps);
       4      size  inval(ws);  $ reados numeric result.
       5      call ltitlr(programlevel);  $ page listing.
       6      call stitlr(0, 'cross reference listing.');
       7      endl  endl
       8
       9
      10      call getipp(lcs_opt, 'lcs=1/0');  $ on to list statistics.
      11      call getipp(lcp_opt, 'lcp=1/0');  $ on to list parameters.
      12      call getipp(dump_opt, 'dump=0/1');  $ on to dump tables.
      13 .+s10  call getspp(crfileparm, 'rf=*.rf0/');
vax   25 .+s32  call getspp(crfileparm, 'rf=little.rf0/');
      14 .+s37  call getspp(crfileparm, 'rf=sysref(ref0)/');
utsa  25 .+s47  call getspp(crfileparm, 'rf=sysref(ref0)/');
      15 .+s66  call getspp(crfileparm, 'rf=ref0/');
      16
      17      if  lcp_opt  then  $ if want options listed.
      18          textl('parameters for reference processing.')  endl
      19          textl('table dumps: dump =') intlp(dump_opt, 2)
      20          textl('.  list statistics: lcs =') intlp(lcs_opt,2)
      21          textl('.  file: rf = ')  textl(crfileparm)  textl('.')
      22          endl  endl
      23          end if;
      24
      25      return;
      26      end subr refini;
       1 .=member ltlref
       2      subr ltlref;  $ little cross reference list.
       3      $   process little cross reference list.
       4
       5      $  algorithm:
       6      $   1.  allocate and read ha and names.
       7      $   2.  allocate sha and sort sha, use sort result to
       8      $       set ha order field ha_order.
       9      $       release sha.
      10      $   3.  allocate procedure list.
      11      $   4.  read proc. description.
      12      $   5.  if necessary, allocate linesubr to speed up map
      13      $       from line numbers to procedures.
      14      $   6.  allocate reference array ra, and read in reference list.
      15      $   7.  sort references.
      16      $   8.  generate listing.
      17
      18 .+gf size  dagetf(ws);  $ function to read da.
      19      size  nw(ps);            $  number of words for name.
      20      size  i(ps), j(ps);     $  loop indexes.
      21      size  ent(ws);          $  entry read from reference file.
      22      size  nc(ws);           $  number of characters in name.
      23      size  namesptr(ps);
      24      size  hai(ps);          $ ha index during proc. name search.
      25      size  entprev(ws);
      26      size  ranew(ws);
      27      size  nptr(ps);
      28      size  davail(ps);       $ available space in da.
      29      size  pagethis(ps);     $ page number for procedure.
      30      size  iorc(ps);         $ io return code.
      31      size  lnsret(ps);       $ returned line size.
      32
      33      dapos = 0;
      34      call crfnam(crfilename, crfileparm, 2);
      35      call opensio(crfile, iorc, access_read, crfilename,
      36          0, lnsret, 0, 0);
      37      call dropsio(crfile, iorc);  $ drop, since last use.
      38      call rewisio(crfile, iorc, 0);
      39      crbuffptr = crbuffmax + 1;
      40
      41      $   allocate ha and names.
      42
      43      crefget(reftot);  $ total number of references.
      44      raptr = 0;
      45      procptr = 0;
      46          namesptr = 0;
      47      crefget(linestot);  $ total number of lines.
      48      crefget(halength);  $ dimension of ha.
      49      crefget(nameslength);  $ words needed for names.
      50      if dump_opt  then  $ if dump requested.
      51        endl tintl('reftot',reftot) tintl('halength',halength)
      52        tintl(' lines',linestot) tintl(' names', nameslength)  endl
      53      end if;
      54      haorg = dapos;  $ origin for ha.
      55      $   da requires space for ha, names, subr list, sha and ra.
      56      daptr = halength + nameslength + procmax;
      57      if  reftot > halength
      58          then  daptr = daptr + reftot;
      59          else  daptr = daptr + halength;
      60          end if;
      61
      62      $   call dadims to get dynamic storage.  daptr is desired length.
      63      $   if daptr length cannot be achieved, davail is set to number
      64      $   of entries available; else davail is set to daptr.
      65
      66      call dadims(daptr, davail);
      67
      68      if  davail < daptr  then  $ if request failed, abort.
      69          endl
      70          textl('insufficient dynamic storage. require ')
      71          intlp(daptr-davail, 8)
      72          textl(' more words of dynamic storage.')  endl
      73          call refexit;
      74          end if;
      75
      76      dapos = dapos + halength;
      77      namesorg = dapos;
      78      dapos = dapos + nameslength;
      79      procorg = dapos;
      80     dapos = dapos + procmax;
      81      $   read in ha and names.
      82      $   halast is ha index of last ha entry.  ha_order is initially
      83      $   set for each entry to give index of previous entry, to aid
      84      $   search for procedure names when proc list read in.
      85      do  i = 1 to halength; haput(i, 0);  end do;
      86      while  1;
      87          crefget(hai);
      88          if  (hai = 0)  quit while;
      89          crefget(nc);  $ read next entry;
      90          namescount = namescount + 1;
      91          nw = (nc + (cpw-1))/cpw;  $ words for name.
      92          do  j = 1 to nw;
      93              crefget(ent);
      94              namesput(j+namesptr, ent);
      95              end do;
      96          ent =0;
      97          ha_names ent = namesptr+1;
dsf   14          if (nc>31) nc = 31; $ truncate long names.
      98          ha_chars  ent = nc;
      99          ha_order ent = halast;  halast = hai;
     100          haput(hai, ent);
     101          haused = haused + 1;
     102          namesptr = namesptr + nw;
     103          end while;
     104
     105      $   read procedure list, locating name in ha.
     106
     107      if  dump_opt  then  $ if initial dump requested.
     108          call dadump('initial');
     109          end if;
     110      $    establish cref file as file 3.
     111
     112      call clossio(crfile, iorc);
     113      call crfnam(crfilename, crfileparm, 3);
     114      call opensio(crfile, iorc, access_read, crfilename,
     115          0, lnsret, 0, 0);
     116      call dropsio(crfile, iorc);  $ drop, since last use.
     117      call rewisio(crfile, iorc, 0);
     118      $   do initial read to see if file empty.  if not empty, read
     119      $   procedure list.
     120
     121      call rdrwsio(crfile, iorc, crbuff, 1, crbuffmax);
     122      crbuffptr = 0;
     123
     124      if  iorc = 0  then  $ if procedure file not empty.
     125
     126
     127      while 1;
     128          crefget(ent);
     129          if  (ent=0)  quit while;
     130          procent = 0;
     131          proc_line procent = ent;
     132          crefget(pagethis);       $ get page number.
     133          crefget(nc);  $ characters in name.
     134          nw = (nc + (cpw-1)) / cpw;
     135          do  i = 1 to nw;
     136              crefget(ent);
     137              procname(i) = ent;
     138              end do;
     139      $   now find ha entry for procedure name.
     140          hai = halast;
     141          while  hai;
     142              ent = haget(hai);
     143              if  ha_chars ent = nc  then  $ if lengths agree.
     144                  nptr = ha_names ent - 1;
     145                  do  j = 1 to nw;
     146                      if  (procname(j) ^= namesget(nptr+j))
     147                          go to nexthai;
     148                      end do;
     149                  quit while;
     150                  end if;
     151           /nexthai/
     152              hai = ha_order ent;
     153              end while;
     154
     155          if  hai = 0  then  $ if name not found, fatal error.
     156              textl('fatal error - cannot locate procedure.') endl
     157              call refexit;
     158              end if;
     159          proc_ha procent = hai;
     160          countup(procptr, procmax, 'add proc');
     161          procpages(procptr) = pagethis;
     162          procput(procptr, procent);
     163          end while;
     164
     165      end if iorc;
     166      call shasrt;
     167      $   close reference file 3 and open file 1 with reference list.
     168      call clossio(crfile, iorc);
     169      call crfnam(crfilename, crfileparm, 1);
     170      call opensio(crfile, iorc, access_read, crfilename, 0,
     171           lnsret, 0, 0);
     172      call dropsio(crfile, iorc);  $ drop, since last use.
     173      call rewisio(crfile, iorc, 0);
     174      crbuffptr = crbuffmax + 1;
     175
     176      $   allocate and read in reference list.
     177
     178      raorg = dapos;  dapos = dapos + raptr;
     179      do  i = 1 to reftot;
     180          raptr = raptr + 1;
     181          crefget(ent);
     182          raput(i, ent);
     183          end do;
     184
     185      $   sort references.
     186
     187      call rasrt;
     188
     189      $   eliminate duplicate references.
     190      if  (raptr<=1)  return;
     191      ranew = 0;
     192      entprev = raget(1);
     193      do  i = 2 to raptr;
     194          ent = raget(i);
     195          if  (ent = entprev)  cont do;
     196          ranew = ranew + 1;
     197          raput(ranew, entprev);
     198          entprev = ent;
     199          end do;
     200      ranew = ranew + 1;
     201      raput(ranew, entprev);
     202      raptr = ranew;
     203
     204      call ralist(1, raptr);
     205      return;
     206      end subr ltlref;
     207
       1 .=member shasrt
       2      subr shasrt;  $ sort ha.
       3      $   allocate sha to sort ha.
       4 .+gf size  dagetf(ws);  $ function to read da.
       5      size  temp(ws);  $ temporary for swapping
       6      size  i(ps);            $ loop index.
       7      size  m(ps), top(ps), targ(ps);  $ indices.
       8      size  shabigr(1);         $ compares symbols.
       9      size  shaptr(ps);         $  position in sha.
      10      size  j(ps);  $ index.
      11      size  ent(ws);
      12      shaptr = 0;  shaorg = dapos;
      13      i = halast;
      14      while  i;
      15          shaptr = shaptr + 1;
      16          shaput(shaptr, i);
      17          i = ha_order haget(i);
      18          end while;
      19      $   sort sha.
      20
      21
      22      +*  swap(a,b) = $ macro for swapping, common sort operation
      23          temp = shaget(a);
      24          shaput(a, shaget(b));
      25          shaput(b, temp);
      26          **
      27
      28      do  i = 2 to shaptr; $ make into heap, i is parent.
      29          m = i;
      30          while  m>1;  $ examine parents in turn
      31              if  shabigr(m/2, m)  quit while; $ if parent no smaller,
      32              swap(m,m/2); $ promote large child
      33              m = m/2;
      34              end while;
      35          end do i;
      36
      37      do  top = shaptr to 2 by -1; $ sort subtrees in turn
      38          swap(1,top);  $ extract largest element
      39          m = 1;  $$ force remaining subtree to be heap
      40          while  m*2 < top;
      41              if  shabigr(m*2+1, m*2) & (m*2+1 < top)
      42                  then  targ = m*2+1;
      43                  else  targ = m*2;  end if;
      44              if  shabigr(targ,m)  then
      45                  swap(m, targ); $ child too big, so exchange
      46              else  quit while;  end if;
      47              m = targ;  $ move to subtree of largest child
      48              end while m;
      49          end do top;
      50
      51      macdrop(swap)
      52      $   use sha order to set ha ordering.
      53
      54      do  i = 1 to shaptr;
      55          j = shaget(i);
      56          ent = haget(j);
      57          ha_order ent = i;
      58          haput(j, ent);
      59          end do;
      60
      61      return;
      62      end subr shasrt;
       1 .=member rasrt
       2      subr rasrt;  $ sort reference list.
       3 .+gf size  dagetf(ws);  $ function to read da.
       4      size  temp(ws);  $ temporary for swapping
       5      size  i(ps);            $ loop index.
       6      size  m(ps), top(ps), targ(ps);  $ indices.
       7      size  rabigr(1);         $ compares symbols.
       8
       9
      10      +*  swap(a,b) = $ macro for swapping, common sort operation
      11          temp = raget(a);
      12          raput(a, raget(b));
      13      raput(b, temp);
      14          **
      15
      16      do  i = 2 to raptr; $ make into heap, i is parentprev.
      17          m = i;
      18          while  m>1;  $ examine parents in turn
      19                  if  (raget(m/2) = raget(m)) quit while;
      20              if  rabigr(m/2, m)  quit while; $ if parent no smaller,
      21              swap(m,m/2); $ promote large child
      22              m = m/2;
      23              end while;
      24          end do i;
      25
      26      do  top = raptr to 2 by -1; $ sort subtrees in turn
      27          swap(1,top);  $ extract largest element
      28          m = 1;  $$ force remaining subtree to be heap
      29          while  m*2 < top;
      30              if  rabigr(m*2+1, m*2) & (m*2+1 < top)
      31                  then  targ = m*2+1;
      32                  else  targ = m*2;  end if;
      33              if  rabigr(targ,m)  then
      34                  swap(m, targ); $ child too big, so exchange
      35              else  quit while;  end if;
      36              m = targ;  $ move to subtree of largest child
      37              end while m;
      38          end do top;
      39
      40      macdrop(swap)
      41      return;
      42      end subr rasrt;
       1 .=member shabigr
       2      fnct shabigr(jarg, karg);  $ compare two ha items.
       3 .+gf size  dagetf(ws);  $ function to read da.
       4      size  shabigr(1);
       5      size  jha(ws), kha(ws);  $ word for cross ha check
       6      size  jarg(ws), karg(ws);  $ word for cross ha check
       7      size  jsym(sdstl), ksym(sdstl);  $ symbol strings to compare
       8      size  jlen(ps), klen(ps); size minlen(ps);
       9      size  jch(cs), kch(cs);  $  characters.
      10      size  i(ps);            $ loop index.
      11      size  jptr(ps),  kptr(ps);  $ ha_names values.
      12
      13      jha = shaget(jarg);  kha = shaget(karg);
      14      jptr = ha_names haget(jha);
      15      kptr = ha_names haget(kha);
      16      if  jptr = kptr  then  $ if same symbol, compare line numbers.
      17          shabigr = 0;
      18          return;
      19          end if;
      20      jch = .f. cpw*cs + 1 - cs, cs, namesget(jptr);
      21      kch = .f. cpw*cs + 1 - cs, cs, namesget(kptr);
      22      if  jch ^= kch  then  $ if initial characters differ,
      23          shabigr = (jch > kch);  $ compare to get result.
      24          return;
      25          end if;
      26      $   must examine rest of symbols, retrieve as sds and compare.
      27      getsym(jsym, jha);  getsym(ksym, kha);
      28      jlen = slen jsym; klen = slen ksym;
      29      minlen = jlen; if  (klen < minlen) then minlen = klen; end if;
      30      shabigr=1;  $ assume j bigger
      31      do  i = 1 to minlen;
      32      jch = .ch. i, jsym;  kch = .ch. i, ksym;
      33      if  jch ^= kch  then
      34          shabigr = (jch > kch);
      35          return;
      36          end if;
      37      end do;
      38      shabigr = (jlen > klen);  $
      39      return;
      40
      41      end fnct shabigr;
       1 .=member dadump
       2      subr dadump(title);  $ list dynamic array
       3 .+gf size  dagetf(ws);  $ function to read da.
       4      size  title(sdstl);
       5      size  daent(ws);  $ da entry
       6      size  sym(sdstl);
       7      size  daprev(ws);       $ previous da entry.
       8      size  dalo(ps), dahi(ps);  $ indices of da elements with same valu
       9      size  i(ps);      $ loop index.
      10
      11      endl  textl('da dump ') textl(title) endl
      12 .+dadump.  $ use if low level dump needed.
      13      if  (dapos < 1)  return;
      14
      15      endl  textl(' da contents')  endl
      16
      17      dalo = 1;  daprev = daget(dalo);
      18
      19      do  i = 1 to dapos;
      20          if  (daent = daprev)  cont do;
      21          daent = daget(i);
      22          dahi = i - 1;
      23          intl(dalo)
      24          if  dalo = dahi  then
      25              skipl(8)
      26          else
      27              textl('-') intl(dahi) skipl(2)
      28              end if;
      29          octl(daprev) skipl(3)  wordl(daprev)  endl
      30          daprev = daent;  dalo = i;
      31          end do;
      32
      33      dahi = dapos;
      34      intl(dalo)
      35      if  dalo = dahi  then
      36          skipl(8)
      37      else
      38          textl('-') intl(dahi) skipl(2)
      39          end if;
      40      octl(daprev) skipl(3)  wordl(daprev)  endl
      41      endl
      42
      43      return;
      44 .-dadump.  $ standard dump (ha, subr, ra)
      45      size  ent(ws);  $ entry being listed.
      46      size  nc(ps);  $ number of characters.
      47      size  hap(ps);  $ ha index.
      48      size  haent(ws);  $ ha entry.
      49
      50 $    list ha.
      51      textl('ha dump')  endl
      52      textl('    i  ord char  name')  endl
      53      do  i = 1 to halength;
      54          haent = haget(i);
      55          nc = ha_chars haent;
      56          if  (nc = 0)  cont do;
      57          intl(i)  intlp(ha_order haent, 6)  intl(nc)
      58          getsym(sym, i); skipl(2)  textl(sym)  endl
      59          end do;
      60      endl
      61 $    list subr info.
      62      textl('proc dump')  endl  textl('  org  name')  endl
      63      do  i = 1 to procptr;
      64          ent = procget(i);
      65          intl(i)  intl(proc_line ent)  intl(proc_ha ent);
      66          skipl(2)  getsym(sym, proc_ha ent);  textl(sym)  endl
      67          end do;
      68      endl
      69 $    list ra.
      70      textl('ra dump')  endl  textl(' line  symbol')  endl
      71      do  i = 1 to raptr;
      72          ent = raget(i);
      73          intl(i)  intl(ra_line ent)  intl(ra_ha ent)
      74          skipl(2)  getsym(sym, ra_ha ent) textl(sym)  endl
      75          end do;
      76      endl
      77      return;
      78 ..dadump
      79      end subr dadump;
       1 .=member rabigr
       2      fnct rabigr(jra, kra);  $ compare two references
       3 .+gf size  dagetf(ws);  $ function to read da.
       4      size  rabigr(1);
       5      size  jra(ws), kra(ws);  $ word for cross ref check
       6      size  jha(ps), kha(ps);   $ ha indexes for args.
       7      size  jord(ps), kord(ps);  $ orders.
       8      size  i(ps);            $ loop index.
       9      size  jent(ws),  kent(ws);  $ ha values.
      10
      11      jent = raget(jra);  kent = raget(kra);
      12      jha = ra_ha jent;  kha = ra_ha kent;
      13      jord = ha_order haget(jha);  kord = ha_order haget(kha);
      14      if  jord = kord  then
      15          rabigr = ra_line jent >= ra_line kent;
      16      else
      17          rabigr = jord > kord;
      18          end if;
      19      return;
      20
      21      end fnct rabigr;
       1 .=member dadims
       2 .+s66.
       3      subr dadims(lwant, lavail);  $ set length of dynamic array.
       4      $   set length of dynamic array to lwant.
       5      $   if can get length lwant, set lavail to lwant; else set
       6      $   lavail to available length.
       7 .+gf size  dagetf(ws);  $ function to read da.
       8      size  lwant(ps);        $ desired length.
       9      size  lavail(ps);       $ available space.
      10      size  7nmptr$li(ws);       $ returns address of start of blank nam
      11      size  blankorg(ws);     $ address of start of blank nameset.
      12      blankorg = 7nmptr$li(da);
      13      call resetfl(blankorg + lwant + 2);
      14      lavail = lwant;
      15      return;
      16      end subr dadims;
      17 ..s66
       1 .=member crfread
       2      subr crfread;  $  read buffer from cross reference file.
       3      size  iov(ws);
       4      call rdrwsio(crfile, iov, crbuff, 1, crbuffmax);
       5      if  iov  then
       6          textl('error - premature end of reference file.');
       7          call refexit(1);
       8          end if;
       9      crbuffptr = 0;
      10      return;
      11      end subr crfread;
       1 .=member ralist
       2      subr ralist(listlo, listhi);  $  writes cross reference output
       3 .+gf size  dagetf(ws);  $ function to read da.
       4      size  listlo(ws);
       5      size  listhi(ws);
       6      size  lo(ws);
       7      size  ralo(ws);         $ ra(lo)
       8      size  linelo(ps);       $ line number of lo ref.
       9      size  sp(ps);           $ if nonzero is subr number.
      10      size  ranow(ws);        $ ra(l)
      11      size  sline(ps);
      12      size  l(ws);
      13      size  hi (ws) ;
      14      size  now(ws);  $ cross reference temporary
      15      size  lastline(ps);
      16      size  sym(sdstl);
      17      size  halo(ps);  $ ha index for lo.
      18      size  haprev(ps);   $ ha index of last symbol listed.
      19
      20      if  (listlo > listhi) return;
      21      lo = listlo; $ note that n must be globally defined and set
      22 $    now handle global listing for all procedures
      23
      24      endl
      25      textl('''.prelude'' marks reference before first procedure.') endl
      26      textl('''+'' indicates use as macro.')  endl
      27      textl('number in parentheses is page number for procedure.') endl
      28      endl
dse   11      tabl(20); $ avoid writing part of header
dse   12      setlpos(2)
      29
      30      haprev = 0;
      31
      32      while  lo <= listhi;
      33          ralo = raget(lo);
      34          halo = ra_ha ralo;
      35          linelo = ra_line ralo;
      36          sp = procptr;
      37          if  sp  then  $ if subrs, find subr containing ref.
      38              while  sp;
      39                  sline = proc_line procget(sp);
      40                  if  sline <= linelo  then
      41                      quit while;
      42                      end if;
      43                      sp = sp - 1;
      44                  end while;
      45              end if;
      46          if  sp = 0  then
      47              if  procptr
      48              then  lastline = proc_line procget(1);
      49              else  lastline = linestot + 1;  end if;
      50          elseif sp < procptr  then
      51              lastline = proc_line procget(sp+1);
      52          else  lastline = linestot + 1;
      53              end if;
      54          lastline = lastline - 1;
      55          if  (lastline < linelo)  lastline = linelo;
      56          do  l = lo to listhi;
      57              hi = l;
      58              ranow = raget(l);
      59              if  (ra_ha ranow ^= halo)
      60                  ! (ra_line ranow > lastline)  then
      61                  hi = hi-1;  quit do;  end if;
      62              end do;
      63          if  halo ^= haprev  then $ if new symbol
      64              haprev = halo;
      65              getsym(sym, halo);
      66              textl(sym)  endl
      67              end if;
      68          call namlist(sp, lo, hi);
      69          lo = hi + 1;
      70          end while;
      71      return;
      72      end subr ralist;
       1 .=member namlist
       2      subr namlist(sub, lo, hi);  $  outputs cross-refs
       3 $        namlist generates cross-reference output, either for
       4 $    individual procedure, or final map for all procedures.
       5 $    line numbers are put out 15 to a line.
       6 $        namlist uses only the first 20 characters of symbols and
       7 $    assumes 5 digits will suffice for line numbers.  the code
       8 $    is straightforward, and is largely concerned with
       9 $    collecting the line numbers for a single reference variable.
      10
      11 .+gf size  dagetf(ws);  $ function to read da.
      12      size  sub(ps);          $ proc. number of procedure with ref.
      13      size  lo(ws);  $ list begins here
      14      size  hi(ws);  $ and ends here
      15      size  la(ws);  $ array of lines containing ref to symbol
      16      dims la(15);
      17      size  j(ws);  $ do loop index
      18      size  ksym(sdstl);  $  string for ksym
      19      size  laptr(ws); $ position in -la-
      20      size  origin(ws);  $ amount to subtract from line numbers.
      21      size  temp(ws) ;
      22      size  k(ws);
      23      size  subsym(sdstl);  $ string for reference
      24      size  maclabel(cs); $ set to '+* ' if listing macro name
      25      size  refmarg(ps);  $ left margin during line list.
      26      size  pagethis(ps);     $ if not zero, is page number for proc.
      27      size  pc(ps);           $ number of cols. for page number.
      28
      29
      30
      31 $ determine if name used as macro and set maclabel accordingly.
      32      maclabel = 1r ;
      33      do  j = lo to hi;
      34          if  ra_macro raget(j)  then maclabel= 1r+;
      35              quit do; end if;
      36          end do;
      37
      38 $    now handle final listing, include procedure in which sized
      39
      40      laptr = 0; $ reset line no pointer
      41      pagethis = 0;           $ page number if proc listed.
      42      if  sub  then
      43          getsym(subsym, (proc_ha procget(sub)));
      44          pagethis = procpages(sub);
      45          origin = proc_line procget(sub) - 1;
      46      else
      47          subsym = '.prelude';  origin = 0;
      48          end if;
      49
      50      textl('  ')
      51      charl(maclabel)  textl(subsym)
      52      $   if page number available, print enclosed in parentheses.
      53      if  pagethis  then
      54          pc = 1 + (pagethis > 9) + (pagethis > 99); $ number of cols.
      55          charl(1r()  intlp(pagethis,pc) charl(1r))
      56          end if;
      57
      58      getlpos(refmarg);  $ get current line position.
      59      refmarg = 5 * ((refmarg + 4) / 5);  $ advance to next pos.
      60      textl('     ')
dse   13      if  refmarg=10  then  $ don't put too far left
dse   14          textl(''.pad.5);
dse   15          refmarg=15;
dse   16          end if;
      62      setlpos(refmarg)
      63      do  j =  lo to  hi;  $ list each instance
      64          laptr = laptr+1;
      65          if  (laptr>15)  then  $ flush line numbers
dsd   19                  do  k =  1 to  15; refl(la(k))  end do;
      67              endl  tabl(15)
      68              laptr = 1;
      69              end if;
      70          la(laptr) = ra_line raget(j) - origin; $ get line no
      71          end do;
      72          $ now print last line (has at least one reference)
dsd   20      do  k =  1 to  laptr;  refl(la(k))  end do;
      74      endl
      75      return;
      76      end subr namlist;
       1 .=member ltoflo
       2
       3      subr ltoflo(pt, lim, msg);  $  called if scanner array overflow
       4      size  pt(ws);  $ var to increment
       5      size  lim(ws);  $  maximum allowed value for -pt-
       6      size  msg(ws);  $  diagnostic test passed if overflow occurs
       7      textl('countup-overflow of compiler array') textl(msg)
       8      tintl(' ptr',pt) tintl('limit',lim) endl
       9      call refexit(1);
      10      end subr ltoflo;
       1 .=member refexit
       2      subr refexit;  $ list statistics, terminate execution.
       3
       4      endl  textl('end of reference list.') endl
       5
       6      if  lcs_opt  then $ if statistics desired.
       7          textl('processed ') intlp(reftot,8)
       8          textl(' references to') intl(haused) textl(' symbols using ')
       9          intlp(daptr,8) textl(' dynamic storage entries.')
      10          endl
      11          end if;
      12
      13      if  dump_opt  then  $ if terminal dump requested.
      14          call ltlxtr;  $ list trace back chain.
      15          call dadump('terminal');
      16          end if;
      17
      18      call ltlfin(exitcode, 0);
      19      end subr refexit;

« May 2022 »
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: