Subversion Repositories tendra.SVN

Rev

Rev 2 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 7u83 1 
/*
7 7u83 2 
 * Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.
3 
 * All rights reserved.
4 
 *
5 
 * Redistribution and use in source and binary forms, with or without
6 
 * modification, are permitted provided that the following conditions are met:
7 
 *
8 
 * 1. Redistributions of source code must retain the above copyright notice,
9 
 *    this list of conditions and the following disclaimer.
10 
 * 2. Redistributions in binary form must reproduce the above copyright notice,
11 
 *    this list of conditions and the following disclaimer in the documentation
12 
 *    and/or other materials provided with the distribution.
13 
 * 3. Neither the name of The TenDRA Project nor the names of its contributors
14 
 *    may be used to endorse or promote products derived from this software
15 
 *    without specific, prior written permission.
16 
 *
17 
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
18 
 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
19 
 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
20 
 * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
21 
 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
22 
 * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
23 
 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
24 
 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
25 
 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26 
 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
27 
 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
28 
 *
29 
 * $Id$
30 
 */
31 
/*
2 7u83 32 
    		 Crown Copyright (c) 1997
33 
 
34 
    This TenDRA(r) Computer Program is subject to Copyright
35 
    owned by the United Kingdom Secretary of State for Defence
36 
    acting through the Defence Evaluation and Research Agency
37 
    (DERA).  It is made available to Recipients with a
38 
    royalty-free licence for its use, reproduction, transfer
39 
    to other parties and amendment for any purpose not excluding
40 
    product development provided that any such use et cetera
41 
    shall be deemed to be acceptance of the following conditions:-
42 
 
43 
        (1) Its Recipients shall ensure that this Notice is
44 
        reproduced upon any copies or amended versions of it;
45 
 
46 
        (2) Any amended version of it shall be clearly marked to
47 
        show both the nature of and the organisation responsible
48 
        for the relevant amendment or amendments;
49 
 
50 
        (3) Its onward transfer from a recipient to another
51 
        party shall be deemed to be that party's acceptance of
52 
        these conditions;
53 
 
54 
        (4) DERA gives no warranty or assurance as to its
55 
        quality or suitability for any purpose and DERA accepts
56 
        no liability whatsoever in relation to any use to which
57 
        it may be put.
58 
*/
59 
 
60 
 
61 
/**********************************************************************
62 
$Author: release $
63 
$Date: 1998/03/17 16:54:17 $
64 
$Revision: 1.6 $
65 
$Log: dg_aux.c,v $
66 
 * Revision 1.6  1998/03/17  16:54:17  release
67 
 * Couple of minor fixes.
68 
 *
69 
 * Revision 1.5  1998/03/17  16:34:58  pwe
70 
 * correction for non-NEWDIAGS
71 
 *
72 
 * Revision 1.4  1998/03/15  16:00:29  pwe
73 
 * regtrack dwarf dagnostics added
74 
 *
75 
 * Revision 1.3  1998/03/11  11:03:28  pwe
76 
 * DWARF optimisation info
77 
 *
78 
 * Revision 1.2  1998/02/18  11:22:13  pwe
79 
 * test corrections
80 
 *
81 
 * Revision 1.1.1.1  1998/01/17  15:55:46  release
82 
 * First version to be checked into rolling release.
83 
 *
84 
 * Revision 1.8  1998/01/11  18:44:46  pwe
85 
 * consistent new/old diags
86 
 *
87 
 * Revision 1.7  1998/01/09  09:29:40  pwe
88 
 * prep restructure
89 
 *
90 
 * Revision 1.6  1997/12/04  19:36:13  pwe
91 
 * ANDF-DE V1.9
92 
 *
93 
 * Revision 1.5  1997/11/06  09:17:33  pwe
94 
 * ANDF-DE V1.8
95 
 *
96 
 * Revision 1.4  1997/10/28  10:12:26  pwe
97 
 * local location support
98 
 *
99 
 * Revision 1.3  1997/10/23  09:20:57  pwe
100 
 * ANDF-DE V1.7 and extra diags
101 
 *
102 
 * Revision 1.2  1997/10/10  18:16:33  pwe
103 
 * prep ANDF-DE revision
104 
 *
105 
 * Revision 1.1  1997/08/23  13:26:36  pwe
106 
 * initial ANDF-DE
107 
 *
108 
***********************************************************************/
109 
 
110 
 
111 
#include "config.h"
112 
#include "common_types.h"
113 
#include "basicread.h"
114 
#include "xalloc.h"
115 
#include "sortmacs.h"
116 
#include "expmacs.h"
117 
#include "tags.h"
118 
#include "externs.h"
119 
#include "check.h"
120 
#include "exp.h"
121 
#include "me_fns.h"
122 
#include "table_fns.h"
123 
#include "flags.h"
124 
#include "const.h"
125 
#include "dg_aux.h"
126 
#include "dg_globs.h"
127 
 
128 
 
129 
#ifndef NEWDIAGS
130 
#define isdiaginfo(e)	0
131 
#define setisdiaginfo(e)
132 
#define isdiscarded(e)	0
133 
#define setisdiscarded(e)
134 
#else
135 
static int clean_copy = 0;	/* set by copy_dg_separate */
136 
#endif
137 
 
138 
 
139 
int doing_inlining = 0;
140 
 
141 
dg_info current_dg_info = (dg_info)0;	/* needed when coding extra_diags */
142 
exp current_dg_exp = nilexp;		/* needed when coding extra_diags */
143 
 
144 
short_sourcepos no_short_sourcepos;
145 
 
146 
 
147 
 
148 
#define DG_CLUMP_SIZE 50	/* Generate a clump of dg_name etc together */
149 
#define FILE_CLUMP_SIZE 5
150 
 
151 
 
7 7u83 152 
typedef union {			/* These have similar size */
153 
	struct dg_name_t	nam;
154 
	struct dg_type_t	typ;
155 
	struct dg_info_t	inf;
156 
	struct dg_more_t	mor;
2 7u83 157 
} dg_union;
158 
 
159 
static int dg_clump_left = 0;
7 7u83 160 
static dg_union *next_dg;
2 7u83 161 
 
7 7u83 162 
static void
163 
make_dg_clump(void)
2 7u83 164 
{
7 7u83 165 
	next_dg = (dg_union *)xcalloc(DG_CLUMP_SIZE, sizeof(dg_union));
166 
	dg_clump_left = DG_CLUMP_SIZE;
167 
	return;
2 7u83 168 
}
169 
 
7 7u83 170 
 
171 
dg_name
172 
new_dg_name(dg_name_key k)
2 7u83 173 
{
7 7u83 174 
	dg_name ans;
175 
	if (!dg_clump_left) {
176 
		make_dg_clump();
177 
	}
178 
	dg_clump_left--;
179 
	ans = &((next_dg++)->nam);
180 
	ans->key = k;
181 
	ans->mor = (dg_more_name)0;
182 
	ans->next = (dg_name)0;
183 
	return ans;
2 7u83 184 
}
185 
 
7 7u83 186 
 
187 
dg_type
188 
new_dg_type(dg_type_key k)
2 7u83 189 
{
7 7u83 190 
	dg_type ans;
191 
	if (!dg_clump_left) {
192 
		make_dg_clump();
193 
	}
194 
	dg_clump_left--;
195 
	ans = &((next_dg++)->typ);
196 
	ans->key = k;
197 
	ans->outref.k = NO_LAB;
198 
	ans->mor = (dg_more_name)0;
199 
	return ans;
2 7u83 200 
}
201 
 
7 7u83 202 
 
203 
dg_info
204 
new_dg_info(dg_info_key k)
2 7u83 205 
{
7 7u83 206 
	dg_info ans;
207 
	if (!dg_clump_left) {
208 
		make_dg_clump();
209 
	}
210 
	dg_clump_left--;
211 
	ans = &((next_dg++)->inf);
212 
	ans->key = k;
213 
	ans->this_tag = (dg_tag)0;
214 
	ans->more = (dg_info)0;
215 
	return ans;
2 7u83 216 
}
217 
 
7 7u83 218 
 
219 
void
220 
extend_dg_name(dg_name nm)
2 7u83 221 
{
7 7u83 222 
	dg_more_name mor;
223 
	if (!dg_clump_left) {
224 
		make_dg_clump();
225 
	}
226 
	dg_clump_left--;
227 
	nm->mor = mor = &((next_dg++)->mor);
228 
	mor->this_tag = (dg_tag)0;
229 
	mor->inline_ref = (dg_tag)0;
230 
	mor->refspec = (dg_tag)0;
231 
	mor->elabn = (dg_tag)0;
232 
	mor->exptns = no_dg_type_list_option;
233 
	mor->end_pos = no_short_sourcepos;
234 
	mor->en_family = (dg_dim *)0;
235 
	mor->vslot = nilexp;
236 
	mor->repn = nilexp;
237 
	mor->acc = DG_ACC_NONE;
238 
	mor->virt = DG_VIRT_NONE;
239 
	mor->isinline = 0;
240 
	mor->prognm = 0;
241 
	mor->isconst = 0;
242 
	mor->isspec = 0;
243 
	mor->issep = 0;
244 
	mor->isnew = 0;
245 
	mor->aderiv = 0;
246 
	return;
2 7u83 247 
}
248 
 
7 7u83 249 
 
250 
void
251 
extend_dg_type(dg_type tp)
2 7u83 252 
{
7 7u83 253 
	dg_more_name mor;
254 
	if (!dg_clump_left) {
255 
		make_dg_clump();
256 
	}
257 
	dg_clump_left--;
258 
	tp->mor = mor = &((next_dg++)->mor);
259 
	mor->this_tag = (dg_tag)0;
260 
	mor->inline_ref = (dg_tag)0;
261 
	mor->refspec = (dg_tag)0;
262 
	mor->elabn = (dg_tag)0;
263 
	mor->acc = DG_ACC_NONE;
264 
	mor->virt = DG_VIRT_NONE;
265 
	mor->isinline = 0;
266 
	mor->prognm = 0;
267 
	mor->isconst = 0;
268 
	mor->isspec = 0;
269 
	mor->isnew = 0;
270 
	mor->aderiv = 0;
271 
	return;
2 7u83 272 
}
273 
 
7 7u83 274 
 
275 
void
276 
init_dgtag(dg_tag tg)
2 7u83 277 
{
7 7u83 278 
	tg->key = DGK_NONE;
279 
	tg->done = 0;
280 
	tg->needed = 0;
281 
	tg->any_inl = 0;
282 
	tg->outref.k = NO_LAB;
283 
	tg->abstract_lab = (long)0;
284 
	tg->copy = (dg_tag)0;
285 
	return;
2 7u83 286 
}
287 
 
7 7u83 288 
 
289 
dg_tag
290 
gen_tg_tag(void)
2 7u83 291 
{
7 7u83 292 
	dg_tag tg = (dgtag_struct *)xcalloc(1, sizeof(dgtag_struct));
293 
	init_dgtag(tg);
294 
	return tg;
2 7u83 295 
}
296 
 
297 
 
298 
/* The following avoids repetitions of pointers and other qualified types */
299 
 
7 7u83 300 
dg_type
301 
get_qual_dg_type(dg_qual_type_key qual, dg_type typ)
2 7u83 302 
{
7 7u83 303 
	static dg_type qual_type_list[N_DG_QUAL_TYPES] = {(dg_type)0 };
304 
	dg_type ans = qual_type_list[qual];
305 
	while (ans) {
306 
		if (ans->data.t_qual.typ == typ) {
307 
			return ans;
308 
		}
309 
		ans = ans->data.t_qual.another;
310 
	}
311 
	ans = new_dg_type(DGT_QUAL);
312 
	ans->data.t_qual.q_key = qual;
313 
	ans->data.t_qual.typ = typ;
314 
	ans->data.t_qual.another = qual_type_list[qual];
315 
	qual_type_list[qual] = ans;
316 
	return ans;
2 7u83 317 
}
318 
 
7 7u83 319 
 
2 7u83 320 
/* The following avoids repetitions of bitfield types */
321 
 
7 7u83 322 
dg_type
323 
get_dg_bitfield_type(dg_type typ, shape sha, bitfield_variety bv)
2 7u83 324 
{
7 7u83 325 
	static dg_type bf_list = (dg_type)0;
326 
	dg_type ans = bf_list;
327 
	while (ans) {
328 
		if (ans->data.t_bitf.expanded == typ &&
329 
		    ans->data.t_bitf.bv.bits == bv.bits &&
330 
		    ans->data.t_bitf.bv.has_sign == bv.has_sign) {
331 
			return ans;
332 
		}
333 
		ans = ans->data.t_bitf.another;
334 
	}
335 
	ans = new_dg_type(DGT_BITF);
336 
	ans->data.t_bitf.expanded = typ;
337 
	ans->data.t_bitf.sha = sha;
338 
	ans->data.t_bitf.bv = bv;
339 
	ans->data.t_bitf.another = bf_list;
340 
	bf_list = ans;
341 
	return ans;
2 7u83 342 
}
343 
 
344 
/* All other types are either unlikely to be repeated, or are rare */
345 
 
346 
 
347 
/* dg_idname is overkill for many purposes - we just want a string */
348 
 
7 7u83 349 
char *
350 
idname_chars(dg_idname nam)
2 7u83 351 
{
7 7u83 352 
	static char *empty = "";
353 
	switch (nam.id_key) {
354 
	case DG_ID_INST:
355 
		failer("inappropriate dg_instance_idname");
356 
		return empty;
357 
	case DG_ID_NONE:
358 
		return empty;
359 
	default:
360 
		return nam.idd.nam;
361 
	}
2 7u83 362 
}
363 
 
364 
 
365 
/* Avoid repetition of files */
366 
 
7 7u83 367 
dg_filename
368 
get_filename(long dat, char *host, char *path, char *nam)
2 7u83 369 
{
7 7u83 370 
	static dg_filename next_file = (dg_filename)0;
371 
	static int filespace_left = 0;
2 7u83 372 
 
7 7u83 373 
	dg_filename ans = all_files;
374 
	while (ans) {
375 
		if (ans->file_dat == dat &&
376 
		    !strcmp(ans->file_host, host) &&
377 
		    !strcmp(ans->file_path, path) &&
378 
		    !strcmp(ans->file_name, nam)) {
379 
			return ans;
380 
		}
381 
		ans = ans->another;
382 
	}
2 7u83 383 
 
7 7u83 384 
	if (!filespace_left) {
385 
		next_file = (dg_filename)xcalloc(FILE_CLUMP_SIZE,
386 
						 sizeof(struct file_t));
387 
		filespace_left = FILE_CLUMP_SIZE;
388 
	}
389 
	filespace_left--;
390 
	ans = (next_file++);
391 
	ans->file_dat = dat;
392 
	ans->file_host = host;
393 
	ans->file_path = path;
394 
	ans->file_name = nam;
395 
	ans->another = all_files;
396 
	all_files = ans;
397 
	return ans;
2 7u83 398 
}
399 
 
400 
 
7 7u83 401 
short_sourcepos
402 
shorten_sourcepos(dg_sourcepos pos)
2 7u83 403 
{
7 7u83 404 
	short_sourcepos ans;
405 
	switch (pos.sp_key) {
406 
	case SP_SHORT:
407 
	case SP_SPAN:
408 
		ans.file = pos.file;
409 
		ans.line = pos.from_line;
410 
		ans.column = pos.from_column;
411 
		break;
412 
	case SP_FILE:
413 
		ans.file = pos.file;
414 
		ans.line = 0;
415 
		ans.column = 0;
416 
		break;
417 
	default:
418 
		ans.file = (dg_filename)0;
419 
		ans.line = 0;
420 
		ans.column = 0;
421 
	}
422 
	return ans;
2 7u83 423 
}
424 
 
7 7u83 425 
 
426 
short_sourcepos
427 
end_sourcepos(dg_sourcepos pos)
2 7u83 428 
{
7 7u83 429 
	short_sourcepos ans;
430 
	if (pos.sp_key == SP_SPAN) {
431 
		ans.file = pos.to_file;
432 
		ans.line = pos.to_line;
433 
		ans.column = pos.to_column;
434 
	}
435 
	else {
436 
		ans.file = (dg_filename)0;
437 
		ans.line = 0;
438 
		ans.column = 0;
439 
	}
440 
	return ans;
2 7u83 441 
}
442 
 
443 
 
7 7u83 444 
dg_type
445 
find_proc_type(dg_type t)
2 7u83 446 
{
7 7u83 447 
	if (t && t->key == DGT_PROC) {
448 
		return t;
449 
	}
450 
	if (t && t->key == DGT_TAGGED) {
451 
		dg_tag tg = t->data.t_tag;
452 
		if (tg->key == DGK_TYPE) {
453 
			return find_proc_type(tg->p.typ);
454 
		}
455 
		if (tg->key == DGK_NAME) {
456 
			dg_name ref_n = tg->p.nam;
457 
			if (ref_n->key == DGN_TYPE) {
458 
				return find_proc_type(ref_n->data.n_typ.raw);
459 
			}
460 
		}
461 
	}
462 
	failer("proc type details unavailable");
463 
	return f_dg_proc_type(new_dg_param_list(0), f_dg_void_type,
464 
			      no_bool_option, no_nat_option, no_nat_option,
465 
			      no_procprops_option);
2 7u83 466 
}
467 
 
468 
 
7 7u83 469 
static void
470 
scan_diag_names(exp e, exp whole)
2 7u83 471 
{
7 7u83 472 
	if (name(e) == name_tag) {
473 
		exp id = son(e);
474 
		if (!isdiaginfo(e) && !internal_to(whole, id)) {
475 
			setisdiaginfo(e);
476 
			--no(id);
477 
		}
478 
		return;
479 
	}
480 
	if (son(e) != nilexp && name(e) != env_offset_tag) {
481 
		exp t = son(e);
482 
		for (;;) {
483 
			scan_diag_names(t, whole);
484 
			if (last(t)) {
485 
				return;
486 
			}
487 
			t = bro(t);
488 
		}
489 
	}
2 7u83 490 
	return;
491 
}
492 
 
7 7u83 493 
 
494 
exp
495 
diaginfo_exp(exp e)
2 7u83 496 
{
7 7u83 497 
	/* mark external names to avoid influencing optimisations */
498 
	exp ans;
499 
	if (!e) {
500 
		return e;
501 
	}
502 
	scan_diag_names(e, e);
503 
	ans = hold(e);
504 
	setpt(ans, nilexp);
505 
	setbro (ans, nilexp);	/* these fields are used in dwarf generation */
506 
	no(ans) = 0;
507 
	props(ans) = 0;
508 
	clearlast(ans);
509 
	IGNORE check(e, e);
510 
	return ans;
2 7u83 511 
}
512 
 
513 
 
514 
#ifdef NEWDIAGS
515 
 
7 7u83 516 
void
517 
diag_kill_id(exp id)
2 7u83 518 
{
7 7u83 519 
	exp t = pt(id);
520 
	while (t) {
521 
		if (!isdiaginfo(t))
522 
			failer("bad kill ident");
523 
		setdiscarded(t);
524 
		t = pt(t);
525 
	}
526 
	son(id) = nilexp;
527 
	return;
2 7u83 528 
}
529 
 
530 
 
7 7u83 531 
void
532 
set_obj_ref(dg_name nm)
533 
{
534 
	/* nm is defining reference for its obtain value */
535 
	exp e = nm->data.n_obj.obtain_val;
536 
	while (e && (name(e) == hold_tag || name(e) == cont_tag ||
537 
		     name(e) == reff_tag)) {
538 
		e = son(e);
539 
	}
540 
	if (e && name(e) == name_tag && isglob(son(e)) &&
541 
	    !(brog(son(e))->dec_u.dec_val.diag_info)) {
542 
		brog(son(e))->dec_u.dec_val.diag_info = nm;
543 
	}
544 
	return;
2 7u83 545 
}
546 
 
7 7u83 547 
 
548 
static int
549 
matched_obj(exp e, dg_name nm, dg_tag *refans)
550 
{
551 
	/* e is name_tag for required object */
552 
	exp x;
553 
	if (nm->key != DGN_OBJECT) {
554 
		return 0;
555 
	}
556 
	x = nm->data.n_obj.obtain_val;
557 
	while (x && (name(x) == hold_tag || name(x) == cont_tag ||
558 
		     name(x) == reff_tag))
559 
		x = son(x);
560 
	if ((x) && name(x) == name_tag && son(x) == son(e)) {
561 
		if ((no(x) <= no(e)) &&
562 
		    (no(x) + shape_size(sh(x)) >= no(e) + shape_size(sh(e)))) {
563 
			if (!nm->mor || !nm->mor->this_tag) {
564 
				IGNORE f_dg_tag_name(gen_tg_tag(), nm);
565 
			}
566 
			*refans = nm->mor->this_tag;
567 
			return 1;
568 
		}
569 
	}
570 
	return 0;
2 7u83 571 
}
572 
 
7 7u83 573 
 
574 
static int
575 
end_ref_search(exp e, dg_info d, dg_tag *refans)
2 7u83 576 
{
7 7u83 577 
	dg_name pm;
578 
	while (d && d->key != DGA_NAME && d->key != DGA_INL_CALL &&
579 
	       d->key != DGA_PARAMS)
580 
		d = d->more;
581 
	if (!d) {
582 
		return 0;
583 
	}
584 
	if (d->more && end_ref_search(e, d->more, refans)) {
585 
		return 1;
586 
	}
587 
	if (d->key == DGA_NAME) {
588 
		return(matched_obj(e, d->data.i_nam.dnam, refans));
589 
	}
590 
	/* otherwise inlined call or outermost proc */
591 
	if (d->key == DGA_PARAMS) {
592 
		pm = d->data.i_param.args;
593 
	} else {
594 
		pm = d->data.i_inl.args;
595 
	}
596 
	while (pm && !matched_obj(e, pm, refans)) {
597 
		pm = pm->next;
598 
	}
599 
	return 1;	/* we don't search the caller environment */
2 7u83 600 
}
601 
 
7 7u83 602 
 
603 
static dg_tag
604 
find_obj_ref(exp contex, exp e)
605 
{
606 
	/* e is name_tag for required object */
607 
	dg_tag ans = (dg_tag)0;
608 
	while ((name(contex) != ident_tag || !isglob(contex)) &&
609 
	       (!dgf(contex) || !end_ref_search(e, dgf(contex), &ans))) {
610 
		contex = father(contex);
611 
	}
612 
	if (!ans) {
613 
		dg_compilation cl = all_comp_units;
614 
		while (cl) {
615 
			dg_name dl = cl->dn_list;
616 
			while (dl) {
617 
				if (matched_obj(e, dl, &ans)) {
618 
					return ans;
619 
				}
620 
				dl = dl->next;
621 
			}
622 
			cl = cl->another;
623 
		}
624 
	}
625 
	return ans;
2 7u83 626 
}
627 
 
628 
 
7 7u83 629 
static void
630 
check_const_exp(exp e)
2 7u83 631 
{
7 7u83 632 
	if (!e) {
633 
		return;
634 
	}
635 
	if (name(e) != hold_tag || name(son(e)) != val_tag) {
636 
		failer("diag_type may need copying");
637 
	}
2 7u83 638 
	/* copy within type, unless all name_tags are uncopied */
7 7u83 639 
	return;
2 7u83 640 
}
641 
 
7 7u83 642 
 
643 
static void
644 
check_const_type(dg_type t)
2 7u83 645 
{
7 7u83 646 
	int i;
647 
	switch (t->key) {
648 
	case DGT_QUAL:
649 
		check_const_type(t->data.t_qual.typ);
650 
		break;
651 
	case DGT_CONS:
652 
		check_const_type(t->data.t_cons.typ);
653 
		break;
654 
	case DGT_ARRAY:
655 
		check_const_type(t->data.t_arr.elem_type);
656 
		check_const_exp(t->data.t_arr.stride);
657 
		for (i = 0; i < t->data.t_arr.dims.len; i++) {
658 
			dg_dim *dim = &(t->data.t_arr.dims.array[i]);
659 
			if (dim->d_key != DG_DIM_TYPE) {
660 
				if (!dim->low_ref) {
661 
					check_const_exp(dim->lower.x);
662 
				}
663 
				if (!dim->hi_ref) {
664 
					check_const_exp(dim->upper.x);
665 
				}
666 
			}
667 
		}
668 
		break;
669 
	case DGT_SUBR:
670 
		check_const_type(t->data.t_subr.d_typ);
671 
		if (!t->data.t_subr.low_ref) {
672 
			check_const_exp(t->data.t_subr.lower.x);
673 
		}
674 
		if (!t->data.t_subr.hi_ref) {
675 
			check_const_exp(t->data.t_subr.upper.x);
676 
		}
677 
		break;
678 
	case DGT_STRUCT:
679 
		for (i = 0; i < t->data.t_struct.u.fields.len; i++) {
680 
			dg_classmem *f = &(t->data.t_struct.u.fields.array[i]);
681 
			check_const_type(f->d.cm_f.f_typ);
682 
			check_const_exp(f->d.cm_f.f_offset);
683 
		}
684 
		break;
685 
	case DGT_PROC:
686 
		if (t->data.t_proc.res_type) {
687 
			check_const_type(t->data.t_proc.res_type);
688 
		}
689 
		for (i = 0; i < t->data.t_proc.params.len; i++) {
690 
			dg_param *p = &(t->data.t_proc.params.array[i]);
691 
			check_const_type(p->p_typ);
692 
		}
693 
		break;
694 
	case DGT_STRING:
695 
		check_const_exp(t->data.t_string.lb);
696 
		check_const_exp(t->data.t_string.length);
697 
		break;
698 
	case DGT_CLASS:
699 
	case DGT_PMEM:
700 
		failer("uncopyable type");
701 
		break;
702 
	default:
703 
		break;
2 7u83 704 
	}
7 7u83 705 
	return;
2 7u83 706 
}
707 
 
708 
 
709 
static int inner_copy = 0;
710 
 
711 
 
7 7u83 712 
static dg_name
713 
new_copy_name(dg_name d)
2 7u83 714 
{
7 7u83 715 
	dg_name new = new_dg_name(d->key);
716 
	if (d->mor && d->mor->this_tag) {
717 
		IGNORE f_dg_tag_name(gen_tg_tag(), new);
718 
		if (d->mor->this_tag->copy) {
719 
			failer("bad copy_diagname");
720 
		}
721 
		if (inner_copy) {
722 
			d->mor->this_tag->copy = new->mor->this_tag;
723 
		}
724 
	}
725 
	if (doing_inlining) {
726 
		if (!d->mor || (!d->mor->this_tag && !d->mor->inline_ref)) {
727 
			IGNORE f_dg_tag_name(gen_tg_tag(), d);
728 
		}
729 
		if (!d->mor->inline_ref) {
730 
			d->mor->inline_ref = d->mor->this_tag;
731 
		}
732 
	}
733 
	new->idnam = d->idnam;
734 
	new->whence = d->whence;
735 
	if (d->mor && (d->mor->inline_ref || d->mor->refspec || d->mor->acc ||
736 
		       d->mor->isconst)) {
737 
		extend_dg_name(new);
738 
		new->mor->inline_ref = d->mor->inline_ref;
739 
		new->mor->refspec = d->mor->refspec;
740 
		new->mor->acc = d->mor->acc;
741 
		new->mor->isconst = d->mor->isconst;
742 
	}
743 
	return new;
2 7u83 744 
}
745 
 
7 7u83 746 
 
747 
static int
748 
is_copied(exp e)
2 7u83 749 
{
7 7u83 750 
	if (!e) {
751 
		return 0;
752 
	}
753 
	switch (name(e)) {
754 
	case name_tag:
755 
		return(copying(son(e)));
756 
	case hold_tag:
757 
	case cont_tag:
758 
	case contvol_tag:
759 
	case reff_tag:
760 
	case chvar_tag:
761 
	case chfl_tag:
762 
		return is_copied(son(e));
763 
	case val_tag:
764 
	case null_tag:
765 
	case real_tag:
766 
	case string_tag:
767 
		return 0;
768 
	default:
769 
		failer("unexpected copy_diagname obtain_val");
770 
	}
771 
	return 0;
2 7u83 772 
}
773 
 
774 
 
7 7u83 775 
static dg_name
776 
copy_diagname(dg_name d, exp var, exp lab, int need)
2 7u83 777 
{
7 7u83 778 
	/* need (new dg_name) if copying a name_list, or if inlining */
779 
	dg_name new = d;
780 
	switch (d->key) {
781 
	case DGN_OBJECT: {
782 
		int moved = is_copied(d->data.n_obj.obtain_val);
783 
		check_const_type(d->data.n_obj.typ);
784 
		if (need || moved) {
785 
			new = new_copy_name(d);
786 
			new->data.n_obj = d->data.n_obj;
2 7u83 787 
#if 0
7 7u83 788 
			if (moved)
2 7u83 789 
#endif
7 7u83 790 
				new->data.n_obj.obtain_val =
791 
				    copy_res(d->data.n_obj.obtain_val, var,
792 
					     lab);
793 
		}
794 
		break;
795 
	}
796 
	case DGN_TYPE:
797 
		check_const_type(d->data.n_typ.raw);
798 
		break;
799 
	case DGN_IMPORT:
800 
		if (d->data.n_imp.i_typ) {
801 
			check_const_type(d->data.n_imp.i_typ);
802 
		}
803 
		break;
804 
	default:
805 
		failer("unexpected copy_diagname");
806 
	}
807 
	return new;
2 7u83 808 
}
809 
 
810 
 
7 7u83 811 
static void update_detch_copy(detch_info *dl, int update);
812 
 
813 
static void
814 
update_diag_copy(exp e, dg_info d, int update)
2 7u83 815 
{
7 7u83 816 
	if (d) {
817 
		if (update) {
818 
			/* use all dg_tag copies */
819 
			switch (d->key) {
820 
			case DGA_INL_RES: {
821 
				dg_tag ic = d->data.i_res.call;
822 
				if (ic->copy) {
823 
					d->data.i_res.call = ic->copy;
824 
				}
825 
				break;
826 
			}
827 
			case DGA_BEG: {
828 
				dg_tag tg = d->data.i_tg;
829 
				if (tg->copy) {
830 
					d->data.i_tg = tg->copy;
831 
				}
832 
				break;
833 
			}
834 
			case DGA_RVS: {
835 
				dg_tag tg = d->data.i_rvs.u.tg;
836 
				if (tg && tg->copy) {
837 
					d->data.i_rvs.u.tg = tg->copy;
838 
				}
839 
				break;
840 
			}
841 
			case DGA_DETCH:
842 
				update_detch_copy(d->data.i_detch.dl, 1);
843 
				break;
844 
			case DGA_MOVD:
845 
			case DGA_HOIST: {
846 
				dg_tag tg = d->data.i_movd.tg;
847 
				if (tg && tg->copy) {
848 
					d->data.i_movd.tg = tg->copy;
849 
				}
850 
#if 1
851 
				if (d->key == DGA_MOVD && !d->more) {
852 
					failer("lost movd?");
853 
				}
854 
#endif
855 
				break;
856 
			}
857 
			default:
858 
				break;
859 
			}
860 
		} else {
861 
			/* remove all dg_tag copies */
862 
			if (d->this_tag && (doing_inlining || clean_copy)) {
863 
				d->this_tag->copy = (dg_tag)0;
864 
			}
865 
			/* otherwise keep record for code movement */
866 
			switch (d->key) {
867 
			case DGA_NAME: {
868 
				dg_name a = d->data.i_nam.dnam;
869 
				if (a->mor && a->mor->this_tag) {
870 
					a->mor->this_tag->copy = (dg_tag)0;
871 
				}
872 
				break;
873 
			}
874 
			case DGA_INL_CALL: {
875 
				dg_name a = d->data.i_inl.args;
876 
				while (a) {
877 
					if (a->mor && a->mor->this_tag) {
878 
						a->mor->this_tag->copy =
879 
						    (dg_tag)0;
880 
					}
881 
					a = a->next;
882 
				}
883 
				break;
884 
			}
885 
			case DGA_X_CATCH: {
886 
				dg_name a = d->data.i_catch.ex;
887 
				if (a->mor && a->mor->this_tag) {
888 
					a->mor->this_tag->copy = (dg_tag)0;
889 
				}
890 
				break;
891 
			}
892 
			case DGA_DETCH:
893 
				if (doing_inlining || clean_copy) {
894 
					update_detch_copy(d->data.i_detch.dl,
895 
							  0);
896 
				}
897 
				break;
898 
#if 1
899 
			case DGA_MOVD:
900 
				if (!d->more) {
901 
					failer("lost movd?");
902 
				}
903 
				break;
904 
#endif
905 
			default:
906 
				break;
907 
			}
908 
		}
909 
		update_diag_copy(e, d->more, update);
910 
	} else if (e) {
911 
		switch (name(e)) {
912 
		case name_tag:
913 
		case env_offset_tag:
914 
		case general_env_offset_tag:
915 
			break;
916 
		default: {
917 
			exp s = son(e);
918 
			while (s) {
919 
				update_diag_copy(s, dgf(s), update);
920 
				if (last(s)) {
921 
					break;
922 
				}
923 
				s = bro(s);
924 
			}
925 
		}
926 
		}
2 7u83 927 
	}
7 7u83 928 
	return;
929 
}
930 
 
931 
 
932 
static void
933 
update_detch_copy(detch_info *dl, int update)
934 
{
935 
	while (dl) {
936 
		if (dl->info) {
937 
			update_diag_copy(nilexp, dl->info, update);
938 
		}
939 
		if (update && dl->tg && dl->tg->copy) {
940 
			dl->tg = dl->tg->copy;
941 
		}
942 
		if (dl->sub) {
943 
			update_detch_copy(dl->sub, update);
944 
		}
945 
		dl = dl->next;
2 7u83 946 
	}
7 7u83 947 
	return;
948 
}
949 
 
950 
 
951 
static detch_info *copy_detch_tree(detch_info *dl);
952 
 
953 
static dg_info
954 
copy_dg_info(dg_info d, exp var, exp lab, int doing_exp_copy)
955 
{
956 
	dg_info new = new_dg_info(d->key);
957 
	if (d->this_tag) {
958 
		IGNORE f_make_tag_dg(gen_tg_tag(), new);
959 
		if (d->this_tag->copy) {
960 
			failer("bad copy_dg_info");
961 
		}
962 
		if (inner_copy) {
963 
			d->this_tag->copy = new->this_tag;
964 
		}
2 7u83 965 
	}
7 7u83 966 
	switch (new->key) {
967 
	case DGA_PARAMS:
968 
		new->data.i_param = d->data.i_param;
969 
		break;
970 
	case DGA_COMP:
971 
		new->data.i_comp = d->data.i_comp;
972 
		break;
973 
	case DGA_SRC:
974 
		new->data.i_src = d->data.i_src;
975 
		break;
976 
	case DGA_LAB:
977 
	case DGA_EXTRA:
978 
	case DGA_SCOPE:
979 
		new->data.i_scope = d->data.i_scope;
980 
		break;
981 
	case DGA_NAME:
982 
		new->data.i_nam = d->data.i_nam;
983 
		if (doing_exp_copy) {
984 
			/* a named item might be copied */
985 
			new->data.i_nam.dnam =
986 
			    copy_diagname(d->data.i_nam.dnam, var, lab,
987 
					  doing_inlining);
988 
		}
989 
		break;
990 
	case DGA_WITH:
991 
		new->data.i_with = d->data.i_with;
992 
		check_const_type(d->data.i_with.w_typ);
993 
		if (doing_exp_copy) {
994 
			new->data.i_with.w_exp = copy_res(d->data.i_with.w_exp,
995 
							  var, lab);
996 
		}
997 
		break;
998 
	case DGA_CALL:
999 
		new->data.i_call = d->data.i_call;
1000 
		break;
1001 
	case DGA_INL_CALL: {
1002 
		dg_name a = d->data.i_inl.args;
1003 
		dg_name *b = &(new->data.i_inl.args);
1004 
		new->data.i_inl = d->data.i_inl;
1005 
		if (doing_exp_copy) {
1006 
			while (a) {
1007 
				*b = copy_diagname(a, var, lab, 1);
1008 
				a = a->next;
1009 
				b = &((*b)->next);
1010 
			}
1011 
		}
1012 
		d->data.i_inl.proc->any_inl = 1;
1013 
		break;
2 7u83 1014 
	}
7 7u83 1015 
	case DGA_INL_RES:
1016 
		new->data.i_res = d->data.i_res;
1017 
		new->data.i_res.call = d->data.i_res.call;
1018 
		break;
1019 
	case DGA_X_TRY:
1020 
		new->data.i_try = d->data.i_try;
1021 
		break;
1022 
	case DGA_X_CATCH:
1023 
		new->data.i_catch = d->data.i_catch;
1024 
		if (doing_exp_copy) {
1025 
			new->data.i_catch.ex =
1026 
			    copy_diagname(d->data.i_catch.ex, var, lab,
1027 
					  doing_inlining);
1028 
		}
1029 
		break;
1030 
	case DGA_X_RAISE:
1031 
		new->data.i_raise = d->data.i_raise;
1032 
		if (d->data.i_raise.x_typ) {
1033 
			check_const_type(d->data.i_raise.x_typ);
1034 
		}
1035 
		if (d->data.i_raise.x_val && doing_exp_copy) {
1036 
			new->data.i_raise.x_val =
1037 
			    copy_res(d->data.i_raise.x_val, var, lab);
1038 
		}
1039 
		break;
1040 
	case DGA_BRANCH:
1041 
		new->data.i_brn = d->data.i_brn;
1042 
		break;
1043 
	case DGA_TEST:
1044 
	case DGA_JUMP:
1045 
		new->data.i_tst = d->data.i_tst;
1046 
		break;
1047 
	case DGA_LJ:
1048 
		new->data.i_lj = d->data.i_lj;
1049 
		break;
1050 
	case DGA_BEG:
1051 
		new->data.i_tg = d->data.i_tg;
1052 
		break;
1053 
	case DGA_DEST:
1054 
		new->data.i_dest = d->data.i_dest;
1055 
		break;
1056 
	case DGA_RVS:
1057 
		new->data.i_rvs = d->data.i_rvs;
1058 
		break;
1059 
	case DGA_BAR:
1060 
		new->data.i_bar = d->data.i_bar;
1061 
		break;
1062 
	case DGA_DETCH:
1063 
		new->data.i_detch = d->data.i_detch;
1064 
		if (doing_exp_copy) {
1065 
			new->data.i_detch.dl =
1066 
			    copy_detch_tree(new->data.i_detch.dl);
1067 
		}
1068 
		break;
2 7u83 1069 
	case DGA_MOVD:
7 7u83 1070 
	case DGA_HOIST:
1071 
		new->data.i_movd = d->data.i_movd;
2 7u83 1072 
#if 1
7 7u83 1073 
		if (d->key == DGA_MOVD && !d->more) {
1074 
			failer("lost movd?");
1075 
		}
2 7u83 1076 
#endif
7 7u83 1077 
		break;
1078 
	case DGA_OPTIM: {
1079 
		new->data.i_optim = d->data.i_optim;
1080 
		break;
2 7u83 1081 
	}
7 7u83 1082 
	case DGA_REMVAL: {
1083 
		new->data.i_remval = d->data.i_remval;
1084 
		if (copying(son(son(d->data.i_remval.var))))
1085 
			new->data.i_remval.var = copy(d->data.i_remval.var);
1086 
		break;
1087 
	}
2 7u83 1088 
	default:
7 7u83 1089 
		failer("copy_diaginfo incomplete");
2 7u83 1090 
	}
7 7u83 1091 
	return new;
1092 
}
1093 
 
1094 
 
1095 
static detch_info *
1096 
copy_detch_tree(detch_info *dl)
1097 
{
1098 
	detch_info *ans = (detch_info *)xcalloc(1, sizeof(detch_info));
1099 
	*ans = *dl;
1100 
	if (dl->info) {
1101 
		ans->info = copy_dg_info(dl->info, nilexp, nilexp, 1);
2 7u83 1102 
	}
7 7u83 1103 
	if (dl->sub) {
1104 
		ans->sub = copy_detch_tree(dl->sub);
2 7u83 1105 
	}
7 7u83 1106 
	if (dl->next) {
1107 
		ans->next = copy_detch_tree(dl->next);
2 7u83 1108 
	}
7 7u83 1109 
	return ans;
1110 
}
1111 
 
1112 
 
1113 
exp
1114 
copy_res_diag(exp e, dg_info d, exp var, exp lab)
1115 
{
1116 
	int ic = inner_copy;
1117 
	dg_info new;
1118 
	exp ans;
1119 
	if (!d /* ||
1120 
		  (name(e) == name_tag && isdiaginfo(e) && !doing_inlining && !clean-copy) */
1121 
	    /* only one defining name tag */
1122 
	   ) {
1123 
		dg_info all = dgf(e);
1124 
		dgf(e) = nildiag;
1125 
		ans = copy_res(e, var, lab);
1126 
		dgf(e) = all;
1127 
		dgf(ans) = combine_diaginfo(dgf(ans), d);
1128 
		return ans;
2 7u83 1129 
	}
7 7u83 1130 
	if (d->key == DGA_PARAMS) {
1131 
		return copy_res_diag(e, d->more, var, lab);
2 7u83 1132 
	}
7 7u83 1133 
	inner_copy = 1;
1134 
	new = copy_dg_info(d, var, lab, 1);
1135 
	ans = copy_res_diag(e, d->more, var, lab);
1136 
 
1137 
	new->more = dgf(ans);
1138 
	dgf(ans) = new;
1139 
	if (!ic) {
1140 
		inner_copy = 0;
1141 
		update_diag_copy(ans, dgf(ans), 1);
1142 
		update_diag_copy(e, dgf(e), 0);
1143 
	}
1144 
	return ans;
2 7u83 1145 
}
1146 
 
7 7u83 1147 
 
1148 
/* called by copy_res when inlining */
1149 
exp
1150 
diag_hold_check(exp e)
2 7u83 1151 
{
7 7u83 1152 
	int was_inlining = doing_inlining;
1153 
	exp hc;
1154 
	doing_inlining = 0;
1155 
	hc = hold_check(e);
1156 
	doing_inlining = was_inlining;
1157 
	return hc;
2 7u83 1158 
}
1159 
 
1160 
 
7 7u83 1161 
static dg_tag current_inliner = (dg_tag)0;
2 7u83 1162 
 
7 7u83 1163 
static int
1164 
ref_param(exp e)
2 7u83 1165 
{
7 7u83 1166 
	switch (name(e)) {
1167 
	case name_tag:
1168 
	case cont_tag:
1169 
	case chvar_tag:
1170 
	case chfl_tag:
1171 
		return ref_param(son(e));
1172 
	case ident_tag:
1173 
		if (isparam(e)) {
1174 
			return 1;
1175 
		}
1176 
		if (dgf(e) || isglob(e)) {
1177 
			return 0;
1178 
		}
1179 
		return ref_param(son(e));
1180 
	default:
1181 
		return 0;
2 7u83 1182 
	}
1183 
}
1184 
 
7 7u83 1185 
 
1186 
void
1187 
start_diag_inlining(exp e, dg_name dn)
2 7u83 1188 
{
7 7u83 1189 
	exp body = son(e);
1190 
	dg_info di;
1191 
	int any_inl;
1192 
	dg_name_list args = (dg_name)0;
1193 
	if (!dn || dn->key != DGN_PROC) {
1194 
		return;
1195 
	}
1196 
	while (name(body) == ident_tag &&
1197 
	       (isparam(body) || (!dgf(body) && ref_param(son(body))))) {
1198 
		body = bro(son(body));
1199 
	}
1200 
	di = dgf(body);
1201 
	if (di && di->key == DGA_PARAMS) {
1202 
		dn->data.n_proc.params = di;
1203 
		args = di->data.i_param.args;
1204 
	}
1205 
	if (!dn->mor || !dn->mor->this_tag) {
1206 
		IGNORE f_dg_tag_name(gen_tg_tag(), dn);
1207 
	}
1208 
	any_inl = dn->mor->this_tag->any_inl;
1209 
	/* for copying only */
1210 
	di = f_inline_call_dg(dn->mor->this_tag, args, no_nat_option);
1211 
	dn->mor->this_tag->any_inl = any_inl;
1212 
	current_inliner = gen_tg_tag();
1213 
	di = f_make_tag_dg(current_inliner, di);
1214 
	di->more = dgf(body);
1215 
	dgf(body) = di;
1216 
	return;
2 7u83 1217 
}
1218 
 
1219 
 
7 7u83 1220 
void
1221 
end_diag_inlining(exp e, dg_name dn)
2 7u83 1222 
{
7 7u83 1223 
	exp body;
1224 
	if (!dn || dn->key != DGN_PROC) {
1225 
		return;
1226 
	}
1227 
	body = son(e);
1228 
	while (name(body) == ident_tag &&
1229 
	       (isparam(body) || (!dgf(body) && ref_param(son(body))))) {
1230 
		body = bro(son(body));
1231 
	}
1232 
	dgf(body) = dgf(body)->more;
1233 
	current_inliner = 0;
1234 
	return;
2 7u83 1235 
}
1236 
 
7 7u83 1237 
 
1238 
dg_info
1239 
combine_diaginfo(dg_info d1, dg_info d2)
2 7u83 1240 
{
7 7u83 1241 
	dg_info d;
1242 
	if (!d1) {
1243 
		return d2;
1244 
	}
1245 
	if (!d2) {
1246 
		return d1;
1247 
	}
1248 
	d = copy_dg_info(d1, nilexp, nilexp, 0);
1249 
	d->more = combine_diaginfo(d1->more, d2);
1250 
	return d;
2 7u83 1251 
}
1252 
 
1253 
 
7 7u83 1254 
void
1255 
diag_inline_result(exp e)
2 7u83 1256 
{
7 7u83 1257 
	if (current_inliner) {
1258 
		dgf(e) = f_inline_result_dg(current_inliner);
1259 
	}
1260 
	return;
2 7u83 1261 
}
1262 
 
7 7u83 1263 
 
1264 
void
1265 
dg_whole_comp(exp whole, exp comp)
2 7u83 1266 
{
7 7u83 1267 
	/* for use before replace (whole, comp, x) when
1268 
	   whole is replaced by its only remaining component */
1269 
	if (dgf(whole)) {
1270 
		dg_info *next = &(dgf(whole)->more);
1271 
		while (*next) {
1272 
			next = &((*next)->more);
1273 
		}
1274 
		*next = dgf(comp);
1275 
		dgf(comp) = dgf(whole);
1276 
	}
1277 
	return;
2 7u83 1278 
}
1279 
 
7 7u83 1280 
 
1281 
void
1282 
dg_complete_inline(exp whole, exp comp)
2 7u83 1283 
{
7 7u83 1284 
	/* as dg_whole_comp, but remove DGA_CALL */
1285 
	if (dgf(whole)) {
1286 
		int rem = 0;
1287 
		dg_info *next = &(dgf(whole)->more);
1288 
		while (*next) {
1289 
			if ((*next)->key == DGA_CALL) {
1290 
				*next = (*next)->more;
1291 
				rem = 1;
1292 
			} else {
1293 
				next = &((*next)->more);
1294 
			}
1295 
		}
1296 
		if (rem) {
1297 
			/* we must find DGA_INL_CALL to replace the DGA_CALL */
1298 
			while (!dgf(comp)) {
1299 
				if (name(comp) == ident_tag) {
1300 
					comp = bro(son(comp));
1301 
				} else if (name(comp) == cond_tag) {
1302 
					comp = son(comp);
1303 
				} else {
1304 
					break;
1305 
				}
1306 
			}
1307 
			if (!dgf(comp) || dgf(comp)->key != DGA_INL_CALL) {
1308 
				failer("lost inline call movement");
1309 
			}
1310 
		}
1311 
		*next = dgf(comp);
1312 
		dgf(comp) = dgf(whole);
1313 
	}
1314 
	return;
2 7u83 1315 
}
1316 
 
7 7u83 1317 
 
1318 
static detch_info *
1319 
gather_detch(exp e, dg_info *dx, int reason, int descend, int reuse,
1320 
	     dg_tag opt_ref)
2 7u83 1321 
{
7 7u83 1322 
	/* e is exp under consideration.
1323 
	   dx is (ref) dg_info under consideration
1324 
	   part of dgf(e); this info being removed.
1325 
	   reason is enumerated reason for debugger.
1326 
	   descend is nonzero if son(e) to be processed.
1327 
	   reuse is nonzero if simple movement (e remains in use).
1328 
	   opt_ref for reference to complex optimisation info.
1329 
	 */
1330 
	dg_info d = *dx;
1331 
	detch_info *ans;
1332 
	exp s;
1333 
	if (d) {
1334 
		if (d->key == DGA_DETCH) {
1335 
			/* previous detachment */
1336 
			detch_info *more = gather_detch(e, &(d->more), reason,
1337 
							descend, reuse,
1338 
							opt_ref);
1339 
			detch_info **ptr;
1340 
			if (d->data.i_detch.posn < 0) {
1341 
				ans = d->data.i_detch.dl;
1342 
			} else {
1343 
				ans = more;
1344 
				more = d->data.i_detch.dl;
1345 
			}
1346 
			ptr = &ans;
1347 
			while (*ptr) {
1348 
				ptr = &((*ptr)->next);
1349 
			}
1350 
			*ptr = more;
1351 
			return ans;
1352 
		}
1353 
		if (d->key == DGA_MOVD) {
1354 
			/* previous simple movement */
1355 
			if (!d->more) {
1356 
				failer("lost movd?");
1357 
			}
1358 
			if (reason < d->data.i_movd.reason) {
1359 
				d->data.i_movd.reason = reason;
1360 
				d->data.i_movd.tg = opt_ref;
1361 
			}
1362 
			if (reuse) {
1363 
				return(detch_info *)0;
1364 
			}
1365 
			d->data.i_movd.lost = 1;
1366 
			if (d->more->key == DGA_INL_CALL) {
1367 
				/* ignore internals */
1368 
				*dx = (dg_info)0;
1369 
				return(detch_info *)0;
1370 
			}
1371 
			*dx = d->more->more;
1372 
			return gather_detch(e, dx, reason, descend, reuse,
1373 
					    opt_ref);
1374 
		}
1375 
		ans = (detch_info *)xcalloc(1, sizeof(detch_info));
1376 
		ans->next = (detch_info *)0;
1377 
		if (d->key == DGA_INL_CALL) {
1378 
			ans->sub = (detch_info *)0;
1379 
		} else {
1380 
			ans->sub = gather_detch(e, &(d->more), reason, descend,
1381 
						reuse, opt_ref);
1382 
		}
1383 
		ans->why = reason;
1384 
		if (reuse) {
1385 
			d = new_dg_info(DGA_MOVD);
1386 
			d->data.i_movd.reason = reason;
1387 
			d->data.i_movd.lost = 0;
1388 
			d->data.i_movd.tg = opt_ref;
1389 
			d->data.i_movd.lo_pc = 0;
1390 
			d->more = *dx;
1391 
			*dx = d;
1392 
			if (!d->more) {
1393 
				failer("lost movd?");
1394 
			}
1395 
			IGNORE f_make_tag_dg(gen_tg_tag(), d);
1396 
			ans->info = (dg_info)0;
1397 
			ans->tg = d->this_tag;
1398 
		} else {
1399 
			/* original about to be discarded */
1400 
			ans->info = d;
1401 
			d->more = (dg_info)0;
1402 
			ans->tg = opt_ref;
1403 
		}
1404 
		return ans;
1405 
	}
1406 
	if (extra_diags && reuse &&
1407 
	    (name(e) == apply_tag || name(e) == apply_general_tag)) {
1408 
		/* need info to modify in case of subsequent inlining */
1409 
		dg_info x = dgf(e);
1410 
		while (x && x->key != DGA_CALL) {
1411 
			x = x->more;
1412 
		}
1413 
		if (!x) {
1414 
			*dx = d = new_dg_info(DGA_CALL);
1415 
			d->data.i_call.clnam = (char*)0;
1416 
			d->data.i_call.pos = no_short_sourcepos;
1417 
			d->data.i_call.ck = 0;
1418 
			return gather_detch(e, dx, reason, descend, reuse,
1419 
					    opt_ref);
1420 
		}
1421 
	}
1422 
	if (!descend) {
1423 
		return(detch_info *)0;
1424 
	}
1425 
	s = son(e);
1426 
	if (name(e) == name_tag || name(e) == env_size_tag ||
1427 
	    name(e) == env_offset_tag || !s) {
1428 
		return(detch_info *)0;
1429 
	}
1430 
	ans = gather_detch(s, &(dgf(s)), reason, descend, reuse, opt_ref);
1431 
	if (name(e) != case_tag) {
1432 
		detch_info ** ptr = &ans;
1433 
		while (!last(s)) {
1434 
			s = bro(s);
1435 
			while (*ptr) {
1436 
				ptr = &((*ptr)->next);
1437 
			}
1438 
			*ptr = gather_detch(s, &(dgf(s)), reason, descend,
1439 
					    reuse, opt_ref);
1440 
		}
1441 
	}
1442 
	return ans;
2 7u83 1443 
}
1444 
 
7 7u83 1445 
 
1446 
static void
1447 
dg_detach(exp old, exp keep, int position, int reason, int descend, int reuse,
1448 
	  dg_tag opt_ref)
2 7u83 1449 
{
7 7u83 1450 
	detch_info *info = gather_detch(old, &(dgf(old)), reason, descend,
1451 
					reuse, opt_ref);
1452 
	if (info) {
1453 
		dg_info newd = new_dg_info(DGA_DETCH);
1454 
		newd->data.i_detch.posn = position;
1455 
		newd->data.i_detch.dl = info;
1456 
		newd->more = dgf(keep);
1457 
		dgf(keep) = newd;
1458 
	}
1459 
	return;
2 7u83 1460 
}
1461 
 
1462 
 
7 7u83 1463 
void
1464 
dg_dead_code(exp dead, exp prev)
2 7u83 1465 
{
7 7u83 1466 
	/* mark removal of dead code following prev */
1467 
	dg_detach(dead, prev, +1, DGD_DEAD, 1, 0, (dg_tag)0);
1468 
	return;
2 7u83 1469 
}
1470 
 
1471 
 
7 7u83 1472 
void
1473 
dg_rdnd_code(exp rdnd, exp next)
2 7u83 1474 
{
7 7u83 1475 
	/* mark removal of redundant code before next */
1476 
	dg_detach(rdnd, next, -1, DGD_RDND, 1, 0, (dg_tag)0);
1477 
	return;
2 7u83 1478 
}
1479 
 
1480 
 
7 7u83 1481 
void
1482 
dg_detach_const(exp part, exp whole)
2 7u83 1483 
{
7 7u83 1484 
	/* incorporated part in whole evaluated constant*/
1485 
	dg_detach(part, whole, 0, DGD_CNST, 0, 0, (dg_tag)0);
1486 
	return;
2 7u83 1487 
}
1488 
 
1489 
 
7 7u83 1490 
void
1491 
dg_restruct_code(exp outer, exp inner, int posn)
2 7u83 1492 
{
7 7u83 1493 
	/* mark movement of inner into outer */
1494 
	dg_detach(inner, outer, posn, DGD_MOVD, 1, 1, (dg_tag)0);
1495 
	return;
2 7u83 1496 
}
1497 
 
1498 
 
7 7u83 1499 
void
1500 
dg_rem_ass(exp ass)
1501 
{
1502 
	/* mark removal of propagated assignment */
1503 
	exp val = bro(son(ass));
1504 
	if (name(son(ass)) == name_tag &&
1505 
	    (name(val) == val_tag || name(val) == real_tag ||
1506 
	     name(val) == null_tag)) {
1507 
		dg_info h = dgf(val);
1508 
		dg_info *dx = &(dgf(ass));
1509 
		dg_info rem = new_dg_info(DGA_REMVAL);
1510 
		rem->data.i_remval.var = hold(me_obtain(son(son(ass))));
1511 
		setisdiaginfo(son(rem->data.i_remval.var));
1512 
		--no(son(son(rem->data.i_remval.var)));
1513 
		dgf(val) = nildiag;
1514 
		rem->data.i_remval.val = copy(val);
1515 
		dgf(val) = h;
1516 
		rem->data.i_remval.lo_pc = (long)0;
1517 
		rem->more = nildiag;
1518 
		while (*dx) {
1519 
			dx = &((*dx)->more);
1520 
		}
1521 
		*dx = rem;
1522 
	}
1523 
	dg_detach(ass, bro(son(ass)), -1, DGD_REM, 0, 0, (dg_tag)0);
1524 
	return;
2 7u83 1525 
}
1526 
 
1527 
 
7 7u83 1528 
void
1529 
strip_dg_context(exp e)
1530 
{
1531 
	dg_info d = dgf(e);
1532 
	while (d && (d->key == DGA_DETCH || d->key == DGA_NAME)) {
1533 
		d = d->more;
1534 
	}
1535 
	dgf(e) = d;
1536 
	return;
2 7u83 1537 
}
1538 
 
1539 
 
7 7u83 1540 
static dg_info *
1541 
after_dg_context(exp e)
2 7u83 1542 
{
7 7u83 1543 
	dg_info *dx = &(dgf(e));
1544 
	while (*dx && ((*dx)->key == DGA_DETCH || (*dx)->key == DGA_NAME)) {
1545 
		dx = &((*dx)->more);
1546 
	}
1547 
	return dx;
2 7u83 1548 
}
1549 
 
7 7u83 1550 
 
1551 
void
1552 
dg_extracted(exp nm, exp old)
2 7u83 1553 
{
7 7u83 1554 
	/* old replaced by nm */
1555 
	dg_info con_start = dgf(old);
1556 
	dg_info con_end = (strip_dg_context(old), dgf(old));
1557 
	dg_info *dx;
1558 
	if (name(nm) != name_tag ||
1559 
	    (dx = after_dg_context(son(nm)), !(*dx)->this_tag)) {
1560 
		failer("make_optim error");
1561 
	}
1562 
	dg_detach(old, nm, -1, DGD_EXTRACT, 1, 0, (*dx)->this_tag);
1563 
	if (con_start != con_end) {
1564 
		dg_info d = con_start;
1565 
		while (d->more != con_end) {
1566 
			d = d->more;
1567 
		}
1568 
		d->more = dgf(nm);
1569 
		dgf(nm) = con_start;
1570 
	}
1571 
	return;
2 7u83 1572 
}
1573 
 
7 7u83 1574 
 
1575 
static void
1576 
gather_objects(exp e, exp whole, objset **obs, int ass)
1577 
{
1578 
	/* gather into obs, all objects accessed within e that are
1579 
	   external to whole, distinguishing those that may be altered */
1580 
	exp t;
1581 
	switch (name(e)) {
1582 
	case name_tag:
1583 
		if (!intnl_to(whole, son(e))) {
1584 
			dg_tag tg = find_obj_ref(whole, e);
1585 
			if (tg) {
1586 
				objset *x = *obs;
1587 
				while (x && x->tg != tg) {
1588 
					x = x->next;
1589 
				}
1590 
				if (!x) {
1591 
					x = (objset *)xcalloc(1,
1592 
							      sizeof(objset));
1593 
					x->tg = tg;
1594 
					x->ass = ass;
1595 
					x->next = *obs;
1596 
					*obs = x;
1597 
				} else if (ass) {
1598 
					x->ass = 1;
1599 
				}
1600 
			}
1601 
		}
1602 
		return;
1603 
	case ident_tag:
1604 
		/* definition part no_ass */
1605 
		gather_objects(bro(son(e)), whole, obs, ass);
1606 
		break;
1607 
	case seq_tag:
1608 
		/* statements no_ass */
1609 
		gather_objects(bro(son(e)), whole, obs, ass);
1610 
		e = son(e);
1611 
		break;
1612 
	case cond_tag:
1613 
		gather_objects(son(e), whole, obs, ass);
1614 
		gather_objects(bro(son(e)), whole, obs, ass);
1615 
		return;
1616 
	case labst_tag:
1617 
		gather_objects(bro(son(e)), whole, obs, ass);
1618 
		return;
1619 
	case rep_tag:
1620 
		gather_objects(son(e), whole, obs, 0);
1621 
		gather_objects(bro(son(e)), whole, obs, ass);
1622 
		return;
1623 
	case solve_tag:
1624 
		t = son(e);
1625 
		for (;;) {
1626 
			gather_objects(t, whole, obs, ass);
1627 
			if (last(t)) {
1628 
				return;
1629 
			}
1630 
			t = bro(t);
1631 
		}
1632 
	case ass_tag:
1633 
	case assvol_tag:
1634 
		gather_objects(son(e), whole, obs, 1);
1635 
		gather_objects(bro(son(e)), whole, obs, 0);
1636 
		return;
1637 
	case addptr_tag:
1638 
		gather_objects(son(e), whole, obs, ass);
1639 
		gather_objects(bro(son(e)), whole, obs, 0);
1640 
		return;
1641 
	case env_offset_tag:
1642 
		return;
1643 
	default:
1644 
		break;
1645 
	}
1646 
	/* remaining cases all no_ass */
1647 
	t = son(e);
1648 
	while (t) {
1649 
		gather_objects(t, whole, obs, 0);
1650 
		if (last(t)) {
1651 
			return;
1652 
		}
1653 
		t = bro(t);
1654 
	}
1655 
	return;
2 7u83 1656 
}
1657 
 
1658 
 
7 7u83 1659 
void
1660 
make_optim_dg(int reason, exp e)
2 7u83 1661 
{
7 7u83 1662 
	dg_info sub = new_dg_info(DGA_HOIST);
1663 
	exp konst = son(e);
1664 
	exp body = bro(konst);
1665 
	dg_info *dx;
1666 
	dgf(e) = dgf(body);
1667 
	dgf(body) = nildiag;
1668 
	dx = after_dg_context(e);
1669 
	if (!*dx || (*dx)->key != DGA_OPTIM ||
1670 
	    (*dx)->data.i_optim.reason != reason) {
1671 
		dg_info ans = new_dg_info(DGA_OPTIM);
1672 
		ans->data.i_optim.reason = reason;
1673 
		ans->data.i_optim.objs = (objset *)0;
1674 
		ans->data.i_optim.lo_pc = ans->data.i_optim.hi_pc = 0;
1675 
		IGNORE f_make_tag_dg(gen_tg_tag(), ans);
1676 
		ans->more = *dx;
1677 
		*dx = ans;
2 7u83 1678 
	}
7 7u83 1679 
	sub->data.i_movd.reason = reason;
1680 
	sub->data.i_movd.lost = 0;
1681 
	sub->data.i_movd.tg = (*dx)->this_tag;
1682 
	sub->data.i_movd.lo_pc = sub->data.i_movd.hi_pc = 0;
1683 
	sub->more = dgf(konst);
1684 
	dgf(konst) = sub;
1685 
	gather_objects(konst, konst, &((*dx)->data.i_optim.objs), 0);
1686 
	return;
2 7u83 1687 
}
1688 
 
1689 
 
7 7u83 1690 
exp
1691 
copy_dg_separate(exp e)
2 7u83 1692 
{
7 7u83 1693 
	/* Used instead of copy if the original may still be in use. This
1694 
	 * resets tracing of dg_tag copies */
1695 
	exp ans;
1696 
	clean_copy = 1;
1697 
	ans = copy(e);
1698 
	clean_copy = 0;
1699 
	return ans;
2 7u83 1700 
}
1701 
 
1702 
#endif
1703 
 
1704 
 
7 7u83 1705 
exp
1706 
relative_exp(shape s, token t)
2 7u83 1707 
{
7 7u83 1708 
	exp id = me_startid(s, f_make_value(s), 0);
1709 
	tokval tv;
1710 
	tv.tk_exp = me_obtain(id);
1711 
	tv = apply_tok(t, keep_place(), EXP_S, &tv);
1712 
	IGNORE me_complete_id(id, hold_check(tv.tk_exp));
1713 
	return hold(id);
2 7u83 1714 
}