Forgot your password?
Document Actions
REF: Cross-reference processor of the LITTLE compiler. By David Shields.
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;