WebSVN – tendra.SVN – Blame – //branches/tendra5/src/installers/common/construct/install_fns.c

Rev	Author	Line No.	Line
2	7u83	1	`/*`
		2	`Crown Copyright (c) 1997`
		3
		4	`This TenDRA(r) Computer Program is subject to Copyright`
		5	`owned by the United Kingdom Secretary of State for Defence`
		6	`acting through the Defence Evaluation and Research Agency`
		7	`(DERA). It is made available to Recipients with a`
		8	`royalty-free licence for its use, reproduction, transfer`
		9	`to other parties and amendment for any purpose not excluding`
		10	`product development provided that any such use et cetera`
		11	`shall be deemed to be acceptance of the following conditions:-`
		12
		13	`(1) Its Recipients shall ensure that this Notice is`
		14	`reproduced upon any copies or amended versions of it;`
		15
		16	`(2) Any amended version of it shall be clearly marked to`
		17	`show both the nature of and the organisation responsible`
		18	`for the relevant amendment or amendments;`
		19
		20	`(3) Its onward transfer from a recipient to another`
		21	`party shall be deemed to be that party's acceptance of`
		22	`these conditions;`
		23
		24	`(4) DERA gives no warranty or assurance as to its`
		25	`quality or suitability for any purpose and DERA accepts`
		26	`no liability whatsoever in relation to any use to which`
		27	`it may be put.`
		28	`*/`
		29
		30
		31	`/**********************************************************************`
		32	$Author: pwe $
		33	$Date: 1998/03/17 16:34:56 $
		34	$Revision: 1.3 $
		35	$Log: install_fns.c,v $
		36	`* Revision 1.3 1998/03/17 16:34:56 pwe`
		37	`* correction for non-NEWDIAGS`
		38	`*`
		39	`* Revision 1.2 1998/03/11 11:03:26 pwe`
		40	`* DWARF optimisation info`
		41	`*`
		42	`* Revision 1.1.1.1 1998/01/17 15:55:47 release`
		43	`* First version to be checked into rolling release.`
		44	`*`
		45	`* Revision 1.89 1998/01/09 09:28:51 pwe`
		46	`* prep restructure`
		47	`*`
		48	`* Revision 1.88 1997/12/04 19:39:04 pwe`
		49	`* ANDF-DE V1.9`
		50	`*`
		51	`* Revision 1.87 1997/11/04 18:23:50 pwe`
		52	`* split install_fns with new flpt_fns`
		53	`*`
		54	`* Revision 1.86 1997/10/23 09:24:32 pwe`
		55	`* extra diags`
		56	`*`
		57	`* Revision 1.85 1997/10/10 18:15:34 pwe`
		58	`* prep ANDF-DE revision`
		59	`*`
		60	`* Revision 1.84 1997/08/23 13:24:16 pwe`
		61	`* no invert order, and NEWDIAGS inlining`
		62	`*`
		63	`* Revision 1.83 1997/08/06 10:58:25 currie`
		64	`* Catch overflowed constants, PlumHall requirement`
		65	`*`
		66	`* Revision 1.82 1997/02/18 12:56:28 currie`
		67	`* NEW DIAG STRUCTURE`
		68	`*`
		69	`* Revision 1.81 1996/11/18 14:36:51 currie`
		70	`* case_opt fixes`
		71	`*`
		72	`* Revision 1.80 1996/11/12 10:42:20 currie`
		73	`* unsigned cases`
		74	`*`
		75	`* Revision 1.78 1996/11/11 10:05:39 currie`
		76	`* current_env on hppa`
		77	`*`
		78	`Revision 1.77 1996/10/29 10:10:46 currie`
		79	`512 bit alignment for hppa`
		80
		81	`* Revision 1.76 1996/10/21 08:53:55 currie`
		82	`* long_jump_access`
		83	`*`
		84	`Revision 1.75 1996/10/01 08:59:22 currie`
		85	`correct chvar exceptions ADA`
		86
		87	`Revision 1.74 1996/09/04 14:44:40 currie`
		88	`mis-spelling`
		89
		90	`Revision 1.73 1996/09/04 14:19:55 currie`
		91	`mis-spelling`
		92
		93	`Revision 1.71 1996/07/05 15:45:09 currie`
		94	`initial values`
		95
		96	`Revision 1.70 1996/06/19 11:50:36 currie`
		97	`Parameter alignments in make_coumpound`
		98
		99	`Revision 1.69 1996/06/18 09:20:55 currie`
		100	`C torture long nats`
		101
		102	`Revision 1.68 1996/06/05 15:29:54 currie`
		103	`parameter alignment in make_cmpd`
		104
		105	`Revision 1.67 1996/05/14 10:39:14 currie`
		106	`Long unsigned div2`
		107
		108	`Revision 1.66 1996/05/02 09:34:44 currie`
		109	`Empty caselim list`
		110
		111	`Revision 1.65 1996/04/02 10:34:16 currie`
		112	`volatile & trap_on_nil`
		113
		114	`* Revision 1.63 1996/03/28 11:33:48 currie`
		115	`* Hppa struct params + outpar+init names`
		116	`*`
		117	`* Revision 1.62 1996/03/12 09:45:20 currie`
		118	`* promote pars`
		119	`*`
		120	`* Revision 1.60 1996/02/28 11:36:20 currie`
		121	`* assign to promoted pars`
		122	`*`
		123	`* Revision 1.59 1996/02/26 11:54:22 currie`
		124	`* Various odds and ends`
		125	`*`
		126	`* Revision 1.58 1996/02/21 09:39:02 currie`
		127	`* hppa var_callers + inlined bug`
		128	`*`
		129	`* Revision 1.57 1996/01/25 17:02:53 currie`
		130	`* Struct params in sparc + postludes`
		131	`*`
		132	`* Revision 1.56 1996/01/22 14:25:33 currie`
		133	`* char parameters on bigendian`
		134	`*`
		135	`* Revision 1.55 1996/01/19 14:49:54 currie`
		136	`* sparc parameter alignments`
		137	`*`
		138	`* Revision 1.54 1996/01/17 10:28:07 currie`
		139	`* param alignment + case bigval`
		140	`*`
		141	`* Revision 1.53 1996/01/12 10:10:03 currie`
		142	`* AVS - promote pars with struct result`
		143	`*`
		144	`* Revision 1.51 1996/01/08 09:36:05 currie`
		145	`* trap_on_nil + hppa change`
		146	`*`
		147	`* Revision 1.49 1995/12/15 15:32:46 currie`
		148	`* Char par + string concat`
		149	`*`
		150	`* Revision 1.48 1995/12/12 09:00:43 currie`
		151	`* Non-var out_pars`
		152	`*`
		153	`* Revision 1.47 1995/12/07 11:43:26 currie`
		154	`* Identity dyn initialisation + mod for hppa error treatments`
		155	`*`
		156	`* Revision 1.46 1995/12/04 13:48:23 currie`
		157	`* postlude with struct result`
		158	`*`
		159	`* Revision 1.45 1995/12/04 10:11:54 currie`
		160	`* power wrap`
		161	`*`
		162	`* Revision 1.44 1995/11/29 15:30:11 currie`
		163	`* computed signed nat`
		164	`*`
		165	`* Revision 1.43 1995/11/23 11:31:06 currie`
		166	`* MIN_PAR_ALIGNMENT + odd & ends`
		167	`*`
		168	`* Revision 1.42 1995/10/31 12:00:15 currie`
		169	`* frame alignments & power`
		170	`*`
		171	`* Revision 1.42 1995/10/31 12:00:15 currie`
		172	`* frame alignments & power`
		173	`*`
		174	`* Revision 1.41 1995/10/24 14:33:40 currie`
		175	`* variety not shape`
		176	`*`
		177	`* Revision 1.40 1995/10/17 12:59:33 currie`
		178	`* Power tests + case + diags`
		179	`*`
		180	`* Revision 1.39 1995/10/13 15:15:07 currie`
		181	`* case + long ints on alpha`
		182	`*`
		183	`* Revision 1.38 1995/10/12 15:52:52 currie`
		184	`* inlining bug`
		185	`*`
		186	`* Revision 1.37 1995/10/11 17:10:03 currie`
		187	`* avs errors`
		188	`*`
		189	`* Revision 1.36 1995/10/10 14:46:15 currie`
		190	`* 223 - non-ansi call`
		191	`*`
		192	`* Revision 1.35 1995/10/06 14:41:57 currie`
		193	`* Env-offset alignments + new div with ET`
		194	`*`
		195	`* Revision 1.34 1995/10/02 10:55:56 currie`
		196	`* Alpha varpars + errhandle`
		197	`*`
		198	`* Revision 1.33 1995/09/27 12:39:25 currie`
		199	`* Peters PIC code`
		200	`*`
		201	`* Revision 1.32 1995/09/25 09:17:56 currie`
		202	`* assign with mode`
		203	`*`
		204	`* Revision 1.31 1995/09/22 15:47:10 currie`
		205	`* added setoutpar; tidied some non-strict ansi`
		206	`*`
		207	`* Revision 1.30 1995/09/20 12:10:18 currie`
		208	`* 64-bit shl arg2 widened`
		209	`*`
		210	`* Revision 1.29 1995/09/19 16:06:46 currie`
		211	`* isAlpha!!`
		212	`*`
		213	`* Revision 1.28 1995/09/19 11:51:46 currie`
		214	`* Changed name of init fn +gcc static bug`
		215	`*`
		216	`* Revision 1.27 1995/09/15 13:29:03 currie`
		217	`* hppa + add_prefix + r_w_m complex`
		218	`*`
		219	`* Revision 1.26 1995/09/11 15:35:34 currie`
		220	`* caller params -ve`
		221	`*`
		222	`* Revision 1.24 1995/08/31 14:18:59 currie`
		223	`* mjg mods`
		224	`*`
		225	`* Revision 1.23 1995/08/21 09:38:35 currie`
		226	`* no_trap_on_nill_contents`
		227	`*`
		228	`* Revision 1.23 1995/08/21 09:38:35 currie`
		229	`* no_trap_on_nill_contents`
		230	`*`
		231	`* Revision 1.22 1995/08/18 09:03:28 currie`
		232	`* Float variety adjusted`
		233	`*`
		234	`* Revision 1.21 1995/08/15 08:25:31 currie`
		235	`* Shift left + trap_tag`
		236	`*`
		237	`* Revision 1.20 1995/08/09 10:33:06 currie`
		238	`* otagexp list reorganised`
		239	`*`
		240	`* Revision 1.19 1995/08/09 08:59:58 currie`
		241	`* round bug`
		242	`*`
		243	`* Revision 1.18 1995/08/02 13:18:00 currie`
		244	`* Various bugs reported`
		245	`*`
		246	`* Revision 1.17 1995/07/04 10:41:22 currie`
		247	`* round with mode shape`
		248	`*`
		249	`* Revision 1.16 1995/07/03 13:42:41 currie`
		250	`* Tail call needs fp`
		251	`*`
		252	`* Revision 1.15 1995/07/03 09:15:10 currie`
		253	`* Round again`
		254	`*`
		255	`* Revision 1.14 1995/06/30 13:47:24 currie`
		256	`* shift_left unsigned`
		257	`*`
		258	`* Revision 1.13 1995/06/29 13:49:37 currie`
		259	`* place -> plce`
		260	`*`
		261	`* Revision 1.12 1995/06/28 12:12:16 currie`
		262	`* offset subtract alignments`
		263	`*`
		264	`* Revision 1.11 1995/06/28 11:53:38 currie`
		265	`* Stack limits etc`
		266	`*`
		267	`* Revision 1.10 1995/06/26 13:04:37 currie`
		268	`* make_stack_limit, env_size etc`
		269	`*`
		270	`* Revision 1.9 1995/06/22 09:19:30 currie`
		271	`* Complex power improvement`
		272	`*`
		273	`* Revision 1.7 1995/06/15 09:00:25 currie`
		274	`* No protos in sunos!`
		275	`*`
		276	`* Revision 1.6 1995/06/15 08:42:09 currie`
		277	`* make_label + check repbtseq`
		278	`*`
		279	`* Revision 1.4 1995/06/14 08:35:36 currie`
		280	`* 64 bit int<->bits`
		281	`*`
		282	`* Revision 1.3 1995/06/08 14:49:16 currie`
		283	`* changes derived from ver 3`
		284	`*`
		285	`* Revision 1.2 1995/05/05 08:10:50 currie`
		286	`* initial_value + signtures`
		287	`*`
		288	`* Revision 1.1 1995/04/06 10:44:05 currie`
		289	`* Initial revision`
		290	`*`
		291	`***********************************************************************/`
		292
		293
		294
		295	`/* This file defines procedures called from decoder which make up`
		296	`the internal representations of the various sorts of value.`
		297	`In most cases the construction of these is evident from the`
		298	`specification and the document describing the in-store`
		299	`representation: the function merely creates the corresponding value.`
		300	`In some cases processing is performed: it is only these which are`
		301	`commented.`
		302	`Many constructions have the shape of their arguments checked by`
		303	`check_shape. These checks are implied by the specification and are`
		304	`not commented.`
		305	`*/`
		306
		307
		308	`#include "config.h"`
		309	`#include <ctype.h>`
		310	`#include <time.h>`
		311	`#include "common_types.h"`
		312	`#include "basicread.h"`
		313	`#include "exp.h"`
		314	`#include "expmacs.h"`
		315	`#include "main_reads.h"`
		316	`#include "tags.h"`
		317	`#include "flags.h"`
		318	`#include "me_fns.h"`
		319	`#include "installglob.h"`
		320	`#include "readglob.h"`
		321	`#include "table_fns.h"`
		322	`#include "flpttypes.h"`
		323	`#include "flpt.h"`
		324	`#include "xalloc.h"`
		325	`#include "shapemacs.h"`
		326	`#include "read_fns.h"`
		327	`#include "sortmacs.h"`
		328	`#include "machine.h"`
		329	`#include "spec.h"`
		330	`#include "check_id.h"`
		331	`#include "check.h"`
		332	`#include "szs_als.h"`
		333	`#include "messages_c.h"`
		334	`#include "natmacs.h"`
		335	`#include "f64.h"`
		336	`#include "readglob.h"`
		337	`#include "case_opt.h"`
		338	`#include "install_fns.h"`
		339	`#include "externs.h"`
		340
		341	`#ifdef NEWDIAGS`
		342	`#include "dg_fns.h"`
		343	`#include "mark_scope.h"`
		344	`#endif`
		345
		346	`#define NOTYETDONE(x) failer(x)`
		347
		348
		349	`#define MAX_ST_LENGTH 25`
		350
		351	`/* All variables initialised */`
		352
		353	`shape f_ptr1;`
		354	`shape f_ptr8;`
		355	`shape f_ptr16;`
		356	`shape f_ptr32;`
		357	`shape f_ptr64;`
		358	`shape f_off0_0;`
		359	`shape f_off1_1;`
		360	`shape f_off8_8;`
		361	`shape f_off8_1;`
		362	`shape f_off16_16;`
		363	`shape f_off16_8;`
		364	`shape f_off16_1;`
		365	`shape f_off32_32;`
		366	`shape f_off32_16;`
		367	`shape f_off32_8;`
		368	`shape f_off32_1;`
		369	`shape f_off64_64;`
		370	`shape f_off64_32;`
		371	`shape f_off64_16;`
		372	`shape f_off64_8;`
		373	`shape f_off64_1;`
		374	`shape f_off512_512;`
		375	`shape f_off512_64;`
		376	`shape f_off512_32;`
		377	`shape f_off512_16;`
		378	`shape f_off512_8;`
		379	`shape f_off512_1;`
		380
		381	`shape ucharsh;`
		382	`shape scharsh;`
		383	`shape uwordsh;`
		384	`shape swordsh;`
		385	`shape ulongsh;`
		386	`shape slongsh;`
		387	`shape u64sh;`
		388	`shape s64sh;`
		389	`shape shrealsh;`
		390	`shape realsh;`
		391	`shape doublesh;`
		392	`shape shcomplexsh;`
		393	`shape complexsh;`
		394	`shape complexdoublesh;`
		395
		396	`shape f_bottom;`
		397	`shape f_top;`
		398	`shape f_local_label_value;`
		399
		400	`procprops f_dummy_procprops;`
		401	`procprops f_var_callers = 1;`
		402	`procprops f_var_callees = 2;`
		403	`procprops f_untidy = 4;`
		404	`procprops f_check_stack = 8;`
		405	`procprops f_no_long_jump_dest = 16;`
		406	`procprops f_inline = 32;`
		407
		408	`static proc_props initial_value_pp;`
		409
		410	`procprops f_add_procprops`
		411	`PROTO_N ( (t,e) )`
		412	`PROTO_T ( procprops t X procprops e )`
		413	`{`
		414	`return (t\|e);`
		415	`}`
		416
		417	`procprops no_procprops_option = 0;`
		418
		419	`procprops yes_procprops_option`
		420	`PROTO_N ( (p) )`
		421	`PROTO_T ( procprops p )`
		422	`{`
		423	`return p;`
		424	`}`
		425
		426	`void init_procprops_option`
		427	`PROTO_Z ()`
		428	`{`
		429	`return;`
		430	`}`
		431
		432	`error_code f_overflow = 7;`
		433	`error_code f_nil_access = 19;`
		434	`error_code f_stack_overflow = 35;`
		435
		436	`error_code_list add_error_code_list`
		437	`PROTO_N ( (t, e, i) )`
		438	`PROTO_T ( error_code_list t X error_code e X int i )`
		439	`{`
		440	`UNUSED (i);`
		441	`return(t \| e);`
		442	`}`
		443
		444	`error_code_list new_error_code_list`
		445	`PROTO_N ( (n) )`
		446	`PROTO_T ( int n )`
		447	`{`
		448	`UNUSED (n);`
		449	`return 0;`
		450	`}`
		451
		452	`transfer_mode f_trap_on_nil = 8;`
		453
		454	`shape containedshape`
		455	`PROTO_N ( (a, s) )`
		456	`PROTO_T ( int a X int s )`
		457	`{`
		458	`switch((a+7)&~7) {`
		459	`case 8: case 0: return ((s)?scharsh:ucharsh);`
		460	`case 16: return ((s)?swordsh:uwordsh);`
		461	`case 32: case 24: return ((s)?slongsh:ulongsh);`
		462	`case 64: case 40: case 48: case 56: return ((s)?s64sh:u64sh);`
		463	`default: failer("Illegal pointer for bitfield operations");`
		464	`return scharsh;`
		465	`}`
		466	`}`
		467
		468	`dec * make_extra_dec`
		469	`PROTO_N ( (nme, v, g, init, s) )`
		470	`PROTO_T ( char * nme X int v X int g X exp init X shape s )`
		471	`{`
		472	`dec * extra_dec = (dec *)calloc(1, sizeof(dec));`
		473	`exp e = getexp(s, nilexp, 0, init, nilexp, 0, 0, ident_tag);`
		474	`setglob(e);`
		475	`if (v) setvar(e);`
		476	`brog(e) = extra_dec;`
		477	`extra_dec -> def_next = (dec *)0;`
		478	`*deflist_end = extra_dec;`
		479	`deflist_end = &((*deflist_end) -> def_next);`
		480	`extra_dec -> dec_u.dec_val.dec_id = nme;`
		481	`extra_dec -> dec_u.dec_val.dec_shape = s;`
		482	`extra_dec -> dec_u.dec_val.dec_exp = e;`
		483	`extra_dec -> dec_u.dec_val.unit_number = crt_tagdef_unit_no;`
		484	`extra_dec -> dec_u.dec_val.diag_info = (diag_global *)0;`
		485	`extra_dec -> dec_u.dec_val.extnamed = (unsigned int) g;`
		486	`extra_dec -> dec_u.dec_val.dec_var = (unsigned int) v;`
		487	`extra_dec -> dec_u.dec_val.dec_outermost = 0;`
		488	`extra_dec -> dec_u.dec_val.have_def = init != nilexp;`
		489	`extra_dec -> dec_u.dec_val.processed = 0;`
		490	`extra_dec -> dec_u.dec_val.isweak = 0;`
		491	`extra_dec -> dec_u.dec_val.is_common = 0;`
		492	`if (init != nilexp) { setfather(e, init); }`
		493	`return extra_dec;`
		494	`}`
		495
		496	`dec * find_named_dec`
		497	`PROTO_N ( (n) )`
		498	`PROTO_T ( char * n )`
		499	`{`
		500	`/* find a global with name n */`
		501	`dec * my_def = top_def;`
		502
		503	`while (my_def != (dec *) 0){`
		504	`char *id = my_def -> dec_u.dec_val.dec_id;`
		505	`if (strcmp(id+strlen(name_prefix), n) == 0) return my_def;`
		506	`my_def = my_def->def_next;`
		507	`}`
		508	`return (dec*)0;`
		509	`}`
		510
		511	`exp find_named_tg`
		512	`PROTO_N ( (n, s) )`
		513	`PROTO_T ( char * n X shape s )`
		514	`{`
		515	`/* find a global with name n */`
		516	`dec * my_def = find_named_dec(n);`
		517	`if (my_def != (dec*)0) {`
		518	`return my_def -> dec_u.dec_val.dec_exp;`
		519	`}`
		520	`my_def = make_extra_dec(add_prefix(n), 0, 1, nilexp, s);`
		521	`return my_def -> dec_u.dec_val.dec_exp;`
		522	`}`
		523
		524
		525	`#if !has64bits`
		526
		527
		528
		529	`char * fn_of_op`
		530	`PROTO_N ( (nm, sngd) )`
		531	`PROTO_T ( int nm X int sngd )`
		532	`{`
		533	`/* Find a run-time library fn corresponding to nm */`
		534
		535	`#define CSU(x,y) return (sngd)?x:y`
		536	`switch (nm) {`
		537	`case plus_tag: CSU("__TDFUs_plus","__TDFUu_plus");`
		538	`case minus_tag: CSU("__TDFUs_minus","__TDFUu_minus");`
		539	`case mult_tag: CSU("__TDFUs_mult","__TDFUu_mult");`
		540	`case div0_tag:case div2_tag: CSU("__TDFUs_div2","__TDFUu_div2");`
		541	`case div1_tag: CSU("__TDFUs_div1","__TDFUu_div2");`
		542	`case rem0_tag:case rem2_tag: CSU("__TDFUs_rem2","__TDFUu_rem2");`
		543	`case mod_tag: CSU("__TDFUs_rem1","__TDFUu_rem2");`
		544	`case shl_tag: CSU("__TDFUs_shl","__TDFUu_shl");`
		545	`case shr_tag: CSU("__TDFUs_shr","__TDFUu_shr");`
		546	`case neg_tag: return "__TDFUneg";`
		547	`case abs_tag: return "__TDFUabs";`
		548	`case chvar_tag:CSU("__TDFUs_chvar","__TDFUu_chvar");`
		549	`case max_tag: CSU("__TDFUs_max","__TDFUu_max");`
		550	`case min_tag: CSU("__TDFUs_min","__TDFUu_min");`
		551	`case test_tag:CSU("__TDFUs_test","__TDFUu_test");`
		552	`case float_tag: CSU("__TDFUs_float","__TDFUu_float");`
		553	`case and_tag: return "__TDFUand";`
		554	`case or_tag: return "__TDFUor";`
		555	`case xor_tag: return "__TDFUxor";`
		556	`case not_tag: return "__TDFUnot";`
		557	`default: failer("No fn for long op");`
		558	`}`
		559	`return "__TDFerror";`
		560	`}`
		561
		562	`exp TDFcallop3`
		563	`PROTO_N ( (arg1, arg2, n) )`
		564	`PROTO_T ( exp arg1 X exp arg2 X int n )`
		565	`{`
		566	`/* construct proc call for binary op corresponding to n */`
		567	`char * nm = fn_of_op(n, is_signed(sh(arg1)));`
		568	`exp dc;`
		569	`exp ob;`
		570	`exp_list pars;`
		571	`exp_option novar;`
		572	`exp res;`
		573	`novar.present = 0;`
		574	`dc = find_named_tg(nm, f_proc);`
		575	`ob = me_obtain(dc);`
		576	`pars.number = 2;`
		577	`pars.start = arg1;`
		578	`pars.end = arg2;`
		579	`bro(arg1) = arg2; clearlast(arg1);`
		580
		581	`res = f_apply_proc(sh(arg1), ob, pars, novar);`
		582	`res = hold_check(res);`
		583	`return res;`
		584	`}`
		585
		586	`exp TDFwithet`
		587	`PROTO_N ( (ov_err, e) )`
		588	`PROTO_T ( error_treatment ov_err X exp e )`
		589	`{`
		590	`exp id;`
		591	`exp c;`
		592	`exp_list el;`
		593	`exp Te;`
		594	`if (ov_err.err_code <= 2) return e;`
		595	`Te = find_named_tg("__TDFerror",slongsh);`
		596	`brog(Te) -> dec_u.dec_val.dec_var = 1;`
		597	`#if keep_PIC_vars`
		598	`setvar(Te);`
		599	`#else`
		600	`if (PIC_code)`
		601	`sh(Te) = f_pointer(f_alignment(slongsh));`
		602	`else`
		603	`setvar(Te);`
		604	`#endif`
		605	`id = me_startid(sh(e), e, 0);`
		606	`c = f_contents(slongsh, me_obtain(Te));`
		607	`el = new_exp_list(1);`
		608	`el = add_exp_list(el, f_plus(ov_err,`
		609	`me_shint(slongsh, (int)0x80000000), c), 0);`
		610	`return me_complete_id(id, f_sequence(el, me_obtain(id)));`
		611	`}`
		612
		613
		614	`exp TDFcallop2`
		615	`PROTO_N ( (ov_err,arg1, arg2, n) )`
		616	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 X int n )`
		617	`{`
		618	`/* construct proc call for binary op corresponding to n */`
		619	`/* ignore error treatment for the moment */`
		620	`char * nm = fn_of_op(n, is_signed(sh(arg1)));`
		621	`exp dc;`
		622	`exp ob;`
		623	`exp_list pars;`
		624	`exp_option novar;`
		625	`exp res;`
		626	`novar.present = 0;`
		627	`dc = find_named_tg(nm, f_proc);`
		628	`ob = me_obtain(dc);`
		629	`pars.number = 2;`
		630	`pars.start = arg1;`
		631	`pars.end = arg2;`
		632	`bro(arg1) = arg2; clearlast(arg1);`
		633
		634	`res = f_apply_proc((n==test_tag)?slongsh:sh(arg1), ob, pars, novar);`
		635
		636	`return TDFwithet(ov_err,res);`
		637	`}`
		638
		639
		640	`exp TDFcallaux`
		641	`PROTO_N ( (ov_err,arg1, nm, s) )`
		642	`PROTO_T ( error_treatment ov_err X exp arg1 X char * nm X shape s )`
		643	`{`
		644	`exp dc;`
		645	`exp ob;`
		646	`exp_list pars;`
		647	`exp_option novar;`
		648	`exp res;`
		649	`novar.present = 0;`
		650	`dc = find_named_tg(nm, f_proc);`
		651	`ob = me_obtain(dc);`
		652	`pars.number = 1;`
		653	`pars.start = arg1;`
		654	`pars.end = arg1;`
		655
		656	`res = f_apply_proc(s, ob, pars, novar);`
		657	`res = hold_check(res);`
		658	`return TDFwithet(ov_err,res);`
		659	`}`
		660
		661
		662	`exp TDFcallop1`
		663	`PROTO_N ( (ov_err,arg1, n) )`
		664	`PROTO_T ( error_treatment ov_err X exp arg1 X int n )`
		665	`{`
		666	`/* construct proc call for unary op corresponding to n */`
		667	`/* ignore error treatment for the moment */`
		668	`char * nm = fn_of_op(n, is_signed(sh(arg1)));`
		669	`return TDFcallaux(ov_err,arg1,nm, sh(arg1));`
		670	`}`
		671
		672	`exp TDFcallop4`
		673	`PROTO_N ( (arg1, n) )`
		674	`PROTO_T ( exp arg1 X int n )`
		675	`{`
		676	`/* construct proc call for unary op corresponding to n */`
		677
		678	`char * nm = fn_of_op(n, is_signed(sh(arg1)));`
		679	`exp dc;`
		680	`exp ob;`
		681	`exp_list pars;`
		682	`exp_option novar;`
		683	`exp res;`
		684	`novar.present = 0;`
		685	`dc = find_named_tg(nm, f_proc);`
		686	`ob = me_obtain(dc);`
		687	`pars.number = 1;`
		688	`pars.start = arg1;`
		689	`pars.end = arg1;`
		690
		691	`res = f_apply_proc(sh(arg1), ob, pars, novar);`
		692
		693	`return res;`
		694	`}`
		695
		696	`#endif`
		697
		698
		699
		700
		701	`error_treatment f_wrap;`
		702	`error_treatment f_impossible;`
		703	`error_treatment f_continue;`
		704
		705
		706	`#ifdef promote_pars`
		707	`static void promote_actuals`
		708	`PROTO_N ( (par) )`
		709	`PROTO_T ( exp par )`
		710	`{`
		711	`for(;;) {`
		712	`shape s = sh(par);`
		713	`if (name(s)>=scharhd && name(s)<=uwordhd) {`
		714	`shape ns = (is_signed(s))? slongsh:ulongsh;`
		715	`exp w = hold_check(f_change_variety(f_wrap,ns, copy(par)));`
		716	`replace(par, w, nilexp);`
		717	`kill_exp(par, nilexp);`
		718	`par = w;`
		719	`}`
		720	`if (last(par)) break;`
		721	`par = bro(par);`
		722	`}`
		723	`}`
		724
		725	`static void promote_formals`
		726	`PROTO_N ( (bdy) )`
		727	`PROTO_T ( exp bdy )`
		728	`{`
		729	`while ((name(bdy) == ident_tag && isparam(bdy))`
		730	`#ifndef NEWDIAGS`
		731	`\|\| name(bdy) == diagnose_tag`
		732	`#endif`
		733	`) {`
		734	`shape spar = sh(son(bdy));`
		735	`if (name(bdy)!=ident_tag) { bdy = son(bdy); continue; }`
		736	`if (name(spar)>=scharhd && name(spar)<= uwordhd) {`
		737	`shape ns = (is_signed(spar))? slongsh: ulongsh;`
		738	`exp u = pt(bdy);`
		739	`exp w;`
		740	`sh(son(bdy)) = ns;`
		741	`if (!isvar(bdy)) {`
		742	`while (u != nilexp) {`
		743	`exp nextu = pt(u);`
		744	`sh(u) = ns;`
		745	`w = f_change_variety(f_wrap, spar, copy(u));`
		746	`replace(u, w, nilexp);`
		747	`kill_exp(u, nilexp);`
		748	`u = nextu;`
		749	`}`
		750	`}`
		751	`else {`
		752	`shape ps = f_pointer(f_alignment(ns));`
		753	`while (u != nilexp) {`
		754	`exp nextu = pt(u);`
		755	`if (last(u) && name(bro(u)) == cont_tag) {`
		756	`if (little_end) {`
		757	`exp con = bro(u);`
		758	`sh(u) = ps;`
		759	`sh(con) = ns;`
		760	`w = f_change_variety(f_wrap, spar, copy(con));`
		761	`replace(con, w, nilexp);`
		762	`kill_exp(con,nilexp);`
		763	`}`
		764	`}`
		765	`else {`
		766	`setvis(bdy);`
		767	`if (!little_end) {`
		768	`sh(u) = ps;`
		769	`no(u) = shape_size(ns)-shape_size(spar);`
		770	`}`
		771	`}`
		772	`u = nextu;`
		773	`}`
		774	`}`
		775	`}`
		776	`bdy = bro(son(bdy));`
		777	`}`
		778
		779
		780
		781	`}`
		782
		783	`#endif`
		784
		785
		786	`aldef frame_als[32];`
		787
		788	`alignment f_locals_alignment = &frame_als[0];`
		789	`alignment nv_callers_alignment = &frame_als[1];`
		790	`alignment var_callers_alignment = &frame_als[3];`
		791	`alignment nv_callees_alignment = &frame_als[7];`
		792	`alignment var_callees_alignment = &frame_als[15];`
		793
		794	`void init_frame_als`
		795	`PROTO_Z ()`
		796	`{`
		797	`int i;`
		798	`for(i=0; i<32; i++) {`
		799	`frame_als[i].al.sh_hd = 0;`
		800	`frame_als[i].al.al_n = 1;`
		801	`frame_als[i].al.al_val.al = 64;`
		802	`frame_als[i].al.al_val.al_frame = i+1;`
		803	`}`
		804	`}`
		805
		806	`error_treatment f_trap`
		807	`PROTO_N ( (ec) )`
		808	`PROTO_T ( error_code_list ec )`
		809	`{`
		810	`error_treatment res;`
		811	`res.err_code = ec;`
		812	`return res;`
		813	`}`
		814
		815	`alignment f_callers_alignment`
		816	`PROTO_N ( (var) )`
		817	`PROTO_T ( bool var )`
		818	`{`
		819	`return ((var)?var_callers_alignment:nv_callers_alignment);`
		820	`}`
		821
		822	`alignment f_callees_alignment`
		823	`PROTO_N ( (var) )`
		824	`PROTO_T ( bool var )`
		825	`{`
		826	`return ((var)?var_callees_alignment:nv_callees_alignment);`
		827	`}`
		828
		829
		830	`otagexp f_make_otagexp`
		831	`PROTO_N ( (tagopt, e) )`
		832	`PROTO_T ( tag_option tagopt X exp e )`
		833	`{`
		834	`exp init;`
		835	`if (!tagopt.present) return e;`
		836	`e = getexp(sh(e), nilexp, 0, e, nilexp, 0, 0, caller_tag);`
		837	`init = getexp(sh(e), nilexp, 0, nilexp , nilexp, 0, 0, caller_name_tag);`
		838	`pt(e) = getexp(f_top, nilexp, 0, init, nilexp, 0, 0, ident_tag);`
		839	`/* setvar(pt(e)); - NOT ACCORDING TO SPEC */`
		840	`setfather(e,son(e));`
		841	`set_tag(tagopt.val, pt(e));`
		842	`return e;`
		843	`}`
		844
		845	`otagexp_list new_otagexp_list`
		846	`PROTO_N ( (n) )`
		847	`PROTO_T ( int n )`
		848	`{`
		849	`otagexp_list res;`
		850	`res.number =0;`
		851	`res.start = nilexp;`
		852	`res.end = nilexp;`
		853	`res.id = nilexp;`
		854	`UNUSED (n);`
		855	`return res;`
		856	`}`
		857
		858	`otagexp_list add_otagexp_list`
		859	`PROTO_N ( (list, ote, n) )`
		860	`PROTO_T ( otagexp_list list X otagexp ote X int n )`
		861	`{`
		862	`if (list.number++ == 0) {`
		863	`list.start = list.end = ote;`
		864	`}`
		865	`else {`
		866	`bro(list.end) = ote;`
		867	`clearlast(list.end);`
		868	`list.end = ote;`
		869	`}`
		870	`setlast(ote);`
		871	`if (name(ote)== caller_tag) {`
		872	`exp id = pt(ote);`
		873	`exp lid = list.id;`
		874	`bro(son(id)) = lid;`
		875	`if (lid != nilexp) {`
		876	`bro(lid) = id; setlast(lid);`
		877	`}`
		878	`no(son(id)) = n;`
		879	`list.id = id;`
		880	`pt(ote) = nilexp; /* this pt is a temp link */`
		881	`}`
		882	`return list;`
		883	`}`
		884
		885	`callees f_make_callee_list`
		886	`PROTO_N ( (args) )`
		887	`PROTO_T ( exp_list args )`
		888	`{`
		889	`exp e = getexp(f_top, nilexp, 0, args.start, nilexp, 0,`
		890	`args.number, make_callee_list_tag);`
		891	`if(args.number!=0) {`
		892	`setfather(e,args.end);`
		893	`#ifdef promote_pars`
		894	`promote_actuals(args.start);`
		895	`#endif`
		896	`}`
		897	`return e;`
		898	`}`
		899
		900	`callees f_make_dynamic_callees`
		901	`PROTO_N ( (ptr,sze) )`
		902	`PROTO_T ( exp ptr X exp sze )`
		903	`{`
		904	`exp e = getexp(f_top, nilexp, 0, ptr, nilexp, 0, 0,`
		905	`make_dynamic_callee_tag);`
		906	`bro(ptr) = sze; clearlast(ptr);`
		907	`setfather(e, sze);`
		908	`return e;`
		909	`}`
		910
		911
		912
		913
		914
		915	`/* exps waiting to be used have the parked flag set in props,`
		916	`so that used_in need not look at their context.`
		917	`This procedure removes the parked flag from each member of an`
		918	`exp list, in preparation for putting them into their`
		919	`proper context.`
		920	`*/`
		921	`void clear_exp_list`
		922	`PROTO_N ( (el) )`
		923	`PROTO_T ( exp_list el )`
		924	`{`
		925	`exp t = el.start;`
		926	`if (t == nilexp)`
		927	`return;`
		928	`while (1)`
		929	`{`
		930	`parked(t) = 0;`
		931	`if (t == el.end)`
		932	`return;`
		933	`t = bro(t);`
		934	`};`
		935	`}`
		936
		937
		938	`alignment frame_alignment;`
		939
		940	`/* ntest codes */`
		941	`ntest f_equal = 5;`
		942	`ntest f_greater_than = 1;`
		943	`ntest f_greater_than_or_equal = 2;`
		944	`ntest f_less_than = 3;`
		945	`ntest f_less_than_or_equal = 4;`
		946	`ntest f_not_equal = 6;`
		947	`ntest f_not_greater_than = 10;`
		948	`ntest f_not_greater_than_or_equal = 9;`
		949	`ntest f_not_less_than = 8;`
		950	`ntest f_not_less_than_or_equal = 7;`
		951
		952	`ntest f_less_than_or_greater_than = 11;`
		953	`ntest f_not_less_than_and_not_greater_than = 12;`
		954	`ntest f_comparable = 13;`
		955	`ntest f_not_comparable = 14;`
		956
		957	`static ntest convert_ntest[] = {0, 1, 2, 3, 4, 5, 6,`
		958	`1, 2, 3, 4, 6, 5, 13, 14};`
		959
		960	`static exp replace_ntest`
		961	`PROTO_N ( (nt, dest, arg1, arg2) )`
		962	`PROTO_T ( ntest nt X label dest X exp arg1 X exp arg2 )`
		963	`{`
		964	`exp res;`
		965	`exp_list el;`
		966	`el = new_exp_list(2);`
		967	`el = add_exp_list(el, arg1, 0);`
		968	`el = add_exp_list(el, arg2, 1);`
		969
		970	`if (nt == f_comparable)`
		971	`res = f_make_top();`
		972	`else`
		973	`res = f_goto(dest);`
		974
		975	`return f_sequence(el, res);`
		976	`}`
		977
		978
		979	`/* rounding mode codes */`
		980	`rounding_mode f_to_nearest = R2NEAR;`
		981	`rounding_mode f_toward_larger = R2PINF;`
		982	`rounding_mode f_toward_smaller = R2NINF;`
		983	`rounding_mode f_toward_zero = R2ZERO;`
		984	`rounding_mode f_round_as_state = 4;`
		985
		986	`transfer_mode f_standard_transfer_mode = 0;`
		987	`transfer_mode f_volatile = 1;`
		988	`transfer_mode f_overlap = 2;`
		989	`transfer_mode f_complete = 4;`
		990
		991	`#define max(x,y) ((x)>(y)) ? (x) : (y)`
		992	`/* careful: use simple arguments! */`
		993
		994
		995
		996	`alignment f_alignment`
		997	`PROTO_N ( (sha) )`
		998	`PROTO_T ( shape sha )`
		999	`{`
		1000	`return align_of(sha);`
		1001	`}`
		1002
		1003	`/* we may not yet know the actual values for the alignments,`
		1004	`merely that they are computed from other alignments by unite.`
		1005	`So we have to set up equations which are solved at the end of aldefs`
		1006	`*/`
		1007	`alignment f_obtain_al_tag`
		1008	`PROTO_N ( (a1) )`
		1009	`PROTO_T ( al_tag a1 )`
		1010	`{`
		1011	`alignment j;`
		1012	`if (a1->al.al_n == 1)`
		1013	`return long_to_al(a1->al.al_val.al);`
		1014	`j = (alignment)calloc(1, sizeof(aldef));`
		1015	`j -> al.al_n = 3;`
		1016	`j -> al.al_val.al_join.a = a1;`
		1017	`j -> next_aldef = top_aldef;`
		1018	`top_aldef = j;`
		1019	`return j;`
		1020	`}`
		1021
		1022	`alignment f_unite_alignments`
		1023	`PROTO_N ( (a1, a2) )`
		1024	`PROTO_T ( alignment a1 X alignment a2 )`
		1025	`{`
		1026	`alignment j;`
		1027	`if (a1->al.al_n == 1 && a2->al.al_n == 1)`
		1028	`{`
		1029	`if (a1->al.al_val.al_frame == a2->al.al_val.al_frame) {`
		1030	`if (a1->al.al_val.al > a2->al.al_val.al)`
		1031	`{ return a1; }`
		1032	`else`
		1033	`{ return a2; }`
		1034	`}`
		1035	`else`
		1036	`if (a1->al.al_val.al_frame ==0) { return a2; }`
		1037	`else`
		1038	`if (a2->al.al_val.al_frame == 0) { return a1; }`
		1039	`else {`
		1040	`return (&frame_als[(a1->al.al_val.al_frame \| a2->al.al_val.al_frame)-1]);`
		1041	`}`
		1042
		1043	`};`
		1044
		1045	`j = (alignment)calloc(1, sizeof(aldef));`
		1046	`j -> al.al_n = 2;`
		1047	`j -> al.al_val.al_join.a = a1;`
		1048	`j -> al.al_val.al_join.b = a2;`
		1049	`j -> next_aldef = top_aldef;`
		1050	`top_aldef = j;`
		1051	`return j;`
		1052	`}`
		1053
		1054
		1055
		1056	`void init_access`
		1057	`PROTO_Z ()`
		1058	`{`
		1059	`return;`
		1060	`}`
		1061
		1062	`access f_dummy_access;`
		1063
		1064
		1065	`access f_visible = 1;`
		1066	`access f_standard_access = 0;`
		1067	`access f_long_jump_access = 2;`
		1068	`access f_constant = 4;`
		1069	`access f_no_other_read = 8;`
		1070	`access f_no_other_write = 16;`
		1071	`access f_register = 32;`
		1072	`access f_out_par = 64;`
		1073	`access f_used_as_volatile = 128;`
		1074	`access f_preserve = 256;`
		1075
		1076	`access f_add_accesses`
		1077	`PROTO_N ( (a1, a2) )`
		1078	`PROTO_T ( access a1 X access a2 )`
		1079	`{`
		1080	`return a1 \| a2;`
		1081	`}`
		1082
		1083
		1084	`alignment f_alloca_alignment;`
		1085	`alignment f_var_param_alignment;`
		1086	`alignment f_code_alignment;`
		1087
		1088	`static struct CAL { short sh_hd; short al; alignment res; struct CAL * rest;}*`
		1089	`cache_pals;`
		1090
		1091
		1092	`void init_alignment`
		1093	`PROTO_Z ()`
		1094	`{`
		1095	`const_al1->al.al_n = 1;`
		1096	`const_al1->al.al_val.al = 1;`
		1097	`const_al1->al.al_val.al_frame = 0;`
		1098	`const_al1->al.sh_hd = 0;`
		1099	`const_al8->al.al_n = 1;`
		1100	`const_al8->al.al_val.al = 8;`
		1101	`const_al8->al.al_val.al_frame = 0;`
		1102	`const_al8->al.sh_hd = 0;`
		1103	`const_al16->al.al_n = 1;`
		1104	`const_al16->al.al_val.al = 16;`
		1105	`const_al16->al.al_val.al_frame = 0;`
		1106	`const_al16->al.sh_hd = 0;`
		1107	`const_al32->al.al_n = 1;`
		1108	`const_al32->al.al_val.al = 32;`
		1109	`const_al32->al.al_val.al_frame = 0;`
		1110	`const_al32->al.sh_hd = 0;`
		1111	`const_al64->al.al_n = 1;`
		1112	`const_al64->al.al_val.al = 64;`
		1113	`const_al64->al.al_val.al_frame = 0;`
		1114	`const_al64->al.sh_hd = 0;`
		1115	`const_al512->al.al_n = 1;`
		1116	`const_al512->al.al_val.al = 512;`
		1117	`const_al512->al.al_val.al_frame = 0;`
		1118	`const_al512->al.sh_hd = 0;`
		1119
		1120	`cache_pals = (struct CAL *)0;`
		1121
		1122	`init_frame_als();`
		1123	`f_alloca_alignment = ALLOCA_ALIGN;`
		1124	`f_var_param_alignment = VAR_PARAM_ALIGN;`
		1125	`f_code_alignment = CODE_ALIGN;`
		1126	`stack_align = max(param_align, double_align);`
		1127	`return;`
		1128	`}`
		1129
		1130	`alignment f_dummy_alignment;`
		1131
		1132
		1133	`static alignment get_pal`
		1134	`PROTO_N ( (a, sh_hd, al) )`
		1135	`PROTO_T ( alignment a X int sh_hd X int al )`
		1136	`{`
		1137	`struct CAL * c = cache_pals;`
		1138	`alignment res;`
		1139	`while (c != (struct CAL*)0) {`
		1140	`if (c->sh_hd == sh_hd && c->al == al) return c->res;`
		1141	`c = c->rest;`
		1142	`}`
		1143	`res = (alignment)xmalloc(sizeof(aldef));`
		1144	`res = a;`
		1145	`res -> al.sh_hd = sh_hd;`
		1146	`c = (struct CAL*)xmalloc(sizeof(struct CAL));`
		1147	`c->sh_hd = sh_hd; c->al = al; c->res = res; c->rest = cache_pals;`
		1148	`cache_pals = c;`
		1149	`return res;`
		1150	`}`
		1151
		1152	`alignment f_parameter_alignment`
		1153	`PROTO_N ( (sha) )`
		1154	`PROTO_T ( shape sha )`
		1155	`{`
		1156	`int n = name(sha);`
		1157	`alignment t =`
		1158	`#if issparc`
		1159	`MIN_PAR_ALIGNMENT;`
		1160	`#else`
		1161	`f_unite_alignments(MIN_PAR_ALIGNMENT, f_alignment(sha));`
		1162	`#endif`
		1163	`#if ishppa`
		1164	`if (shape_size(sha) > 64)`
		1165	`n = nofhd+1;`
		1166	`#endif`
		1167	`#if issparc`
		1168	`if (sparccpd(sha))`
		1169	`n = nofhd+1;`
		1170	`#endif`
		1171
		1172	`return get_pal(t,n,shape_align(sha));`
		1173	`}`
		1174
		1175	`bitfield_variety f_bfvar_bits`
		1176	`PROTO_N ( (issigned, bits) )`
		1177	`PROTO_T ( bool issigned X nat bits )`
		1178	`{`
		1179	`bitfield_variety res;`
		1180	`if (!nat_issmall(bits))`
		1181	`failer(TOO_MANY_BITS);`
		1182	`res.has_sign = issigned;`
		1183	`res.bits = natint(bits);`
		1184	`if (extra_checks && res.bits > SLONG_SZ)`
		1185	`failer(TOO_MANY_BITS);`
		1186	`return res;`
		1187	`}`
		1188
		1189	`void init_bitfield_variety`
		1190	`PROTO_Z ()`
		1191	`{`
		1192	`return;`
		1193	`}`
		1194
		1195	`bitfield_variety f_dummy_bitfield_variety;`
		1196
		1197
		1198	`bool f_false = 0;`
		1199	`bool f_true = 1;`
		1200
		1201	`void init_bool`
		1202	`PROTO_Z ()`
		1203	`{`
		1204	`return;`
		1205	`}`
		1206
		1207	`bool f_dummy_bool;`
		1208
		1209	`caselim f_make_caselim`
		1210	`PROTO_N ( (branch, lower, upper) )`
		1211	`PROTO_T ( label branch X signed_nat lower X signed_nat upper )`
		1212	`{`
		1213	`caselim c;`
		1214	`c.lab = branch;`
		1215	`c.low = lower;`
		1216	`c.high = upper;`
		1217	`return c;`
		1218	`}`
		1219
		1220	`callees f_dummy_callees;`
		1221
		1222	`callees f_same_callees;`
		1223
		1224	`void init_callees`
		1225	`PROTO_Z ()`
		1226	`{`
		1227	`f_same_callees = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0,`
		1228	`same_callees_tag);`
		1229	`return;`
		1230	`}`
		1231
		1232	`void init_caselim`
		1233	`PROTO_Z ()`
		1234	`{`
		1235	`return;`
		1236	`}`
		1237
		1238	`error_treatment f_error_jump`
		1239	`PROTO_N ( (lab) )`
		1240	`PROTO_T ( label lab )`
		1241	`{`
		1242	`error_treatment e;`
		1243	`e.err_code = 4;`
		1244	`e.jmp_dest = lab;`
		1245	`return e;`
		1246	`}`
		1247
		1248
		1249
		1250	`error_code f_dummy_error_code;`
		1251
		1252	`void init_error_code`
		1253	`PROTO_Z ()`
		1254	`{`
		1255	`return;`
		1256	`}`
		1257
		1258	`void init_error_treatment`
		1259	`PROTO_Z ()`
		1260	`{`
		1261	`f_wrap.err_code = 1;`
		1262	`f_impossible.err_code = 0;`
		1263	`f_continue.err_code = 2;`
		1264	`return;`
		1265	`}`
		1266
		1267	`error_treatment f_dummy_error_treatment;`
		1268
		1269
		1270	`exp f_abs`
		1271	`PROTO_N ( (ov_err, arg1) )`
		1272	`PROTO_T ( error_treatment ov_err X exp arg1 )`
		1273	`{`
		1274	`if (name(sh(arg1)) == bothd \|\| !is_signed(sh(arg1)) )`
		1275	`return arg1;`
		1276
		1277	`#if check_shape`
		1278	`if (!is_integer(sh(arg1)))`
		1279	`failer(CHSH_ABS);`
		1280	`#endif`
		1281	`#if !has64bits`
		1282	`if (name(sh(arg1)) >= s64hd &&`
		1283	`(name(arg1)!=val_tag \|\| ov_err.err_code > 2)) {`
		1284	`return TDFcallop1(ov_err,arg1,abs_tag);`
		1285	`}`
		1286	`#endif`
		1287
		1288	`return me_u1(ov_err, arg1, abs_tag);`
		1289	`}`
		1290
		1291	`exp f_add_to_ptr`
		1292	`PROTO_N ( (arg1, arg2) )`
		1293	`PROTO_T ( exp arg1 X exp arg2 )`
		1294	`{`
		1295	`if (name(sh(arg1)) == bothd)`
		1296	`{ kill_exp(arg2,arg2); return arg1; }`
		1297	`if (name(sh(arg2)) == bothd)`
		1298	`{ kill_exp(arg1,arg1); return arg2; }`
		1299
		1300	`#if check_shape`
		1301	`if (!doing_aldefs &&`
		1302	`(name(sh(arg1)) != ptrhd \|\| name(sh(arg2)) != offsethd \|\|`
		1303	`(al1(sh(arg1)) < al1(sh(arg2))`
		1304	`#if issparc`
		1305	`&& al1_of(sh(arg2)) != REAL_ALIGN`
		1306	`#endif`
		1307	`) ))`
		1308	`failer(CHSH_ADDPTR);`
		1309	`#endif`
		1310
		1311	`#if issparc \|\| ishppa`
		1312	`if ((al1_of(sh(arg2))->al.al_val.al_frame & 6) != 0 &&`
		1313	`#else`
		1314	`if ((al1_of(sh(arg2))->al.al_val.al_frame &4) != 0 &&`
		1315	`#endif`
		1316	`al2_of(sh(arg2))->al.sh_hd > nofhd) {`
		1317	`/* indirect varargs param */`
		1318	`exp z = me_b3(f_pointer(f_alignment(sh(arg1))), arg1, arg2, addptr_tag);`
		1319	`return f_contents(sh(arg1), z);`
		1320	`}`
		1321
		1322
		1323	`return(me_b3(f_pointer(al2_of(sh(arg2))), arg1, arg2,`
		1324	`addptr_tag));`
		1325	`}`
		1326
		1327	`exp f_and`
		1328	`PROTO_N ( (arg1, arg2) )`
		1329	`PROTO_T ( exp arg1 X exp arg2 )`
		1330	`{`
		1331	`if (name(sh(arg1)) == bothd)`
		1332	`{ kill_exp(arg2,arg2); return arg1; }`
		1333	`if (name(sh(arg2)) == bothd)`
		1334	`{ kill_exp(arg1,arg1); return arg2; }`
		1335
		1336	`#if check_shape`
		1337	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		1338	`failer(CHSH_AND);`
		1339	`#endif`
		1340	`#if !has64bits`
		1341	`if (name(sh(arg1)) >= s64hd &&`
		1342	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)){`
		1343	`return TDFcallop3(arg1,arg2,and_tag);`
		1344	`}`
		1345	`#endif`
		1346
		1347	`return me_b2( arg1, arg2, and_tag);`
		1348	`}`
		1349
		1350	`exp f_apply_proc`
		1351	`PROTO_N ( (result_shape, arg1, arg2, varparam) )`
		1352	`PROTO_T ( shape result_shape X exp arg1 X exp_list arg2 X exp_option varparam )`
		1353	`{`
		1354	`exp res = getexp(result_shape, nilexp, 0, arg1, nilexp,`
		1355	`0, 0, apply_tag);`
		1356	`int varhack = 0;`
		1357	`if (name(sh(arg1)) == bothd)`
		1358	`return arg1;`
		1359
		1360	`#if check_shape`
		1361	`if (name(sh(arg1)) != prokhd)`
		1362	`failer(CHSH_APPLY);`
		1363	`#endif`
		1364
		1365	`if (varparam.present) {`
		1366	`/* add a declaration for variable parameters */`
		1367	`arg2 = add_exp_list(arg2, varparam.val, arg2.number+1);`
		1368	`varhack =1;`
		1369	`}`
		1370
		1371	`clear_exp_list(arg2);`
		1372
		1373
		1374	`if (name(arg1) == name_tag && isglob(son(arg1)) &&`
		1375	`!isvar(son(arg1)))`
		1376	`{speci sp;`
		1377	`/* check for substitutions for certain global procedures */`
		1378	`sp = special_fn(arg1, arg2.start, result_shape);`
		1379	`if (sp.is_special)`
		1380	`return sp.special_exp;`
		1381	`};`
		1382
		1383	`if (arg2.number==0)`
		1384	`{setfather(res, arg1);}`
		1385	`else`
		1386	`{`
		1387	`clearlast(arg1);`
		1388	`bro(arg1) = arg2.start;`
		1389	`setfather(res, arg2.end);`
		1390	`#ifdef promote_pars`
		1391	`promote_actuals(bro(son(res)));`
		1392	`#endif`
		1393	`};`
		1394
		1395	`/* rewrite struct/union value parameters as pointer-to-copy */`
		1396	`if (redo_structparams && arg2.number > 0) /* has >0 params */`
		1397	`{`
		1398	`exp param, prev;`
		1399
		1400	`prev = arg1;`
		1401	`param = bro(arg1);`
		1402
		1403	`while (1 /"break" below/)`
		1404	`{`
		1405	`if ((varhack && last(param)) \|\|`
		1406	`#if ishppa`
		1407	`( (name(sh(param)) == cpdhd \|\| name(sh(param)) == nofhd \|\|`
		1408	`name(sh(param)) == doublehd) &&`
		1409	`(shape_size(sh(param))>64) ) )`
		1410	`#else`
		1411	`#if issparc`
		1412	`sparccpd(sh(param)) )`
		1413	`#else`
		1414	`name(sh(param)) == cpdhd \|\| name(sh(param)) == nofhd \|\|`
		1415	`name(sh(param)) == doublehd)`
		1416	`#endif`
		1417	`#endif`
		1418	`{`
		1419	`/*`
		1420	`* param IS struct/union-by-value, pass indirectly: make a local`
		1421	`* copy of param and in the parameter list replacce param by`
		1422	`* pointer to the copy.`
		1423	`*`
		1424	`* From:(apply_tag arg1 ...param...)`
		1425	`*`
		1426	`* Make:(new_ident param (apply_tag arg1 .... new_par ...))`
		1427	`* Where new_par = pointer-to-new_ident`
		1428	`*/`
		1429	`exp new_par, new_ident;`
		1430	`shape ptr_s = f_pointer(f_alignment(sh(param)));`
		1431
		1432	`/* new_ident: (ident_tag sh=sh(res) no=1 pt=new_par param res) */`
		1433	`new_ident =`
		1434	`getexp(sh(res), bro(res), (int)last(res), param, nilexp, 0, 1,`
		1435	`ident_tag);`
		1436
		1437	`setvar(new_ident); /* taking its address below*/`
		1438
		1439	`/* new_par: (name_tag sh=ptr_s pt=0 new_ident) */`
		1440	`new_par =`
		1441	`getexp(ptr_s, bro(param), (bool)last(param), new_ident, nilexp, 0, 0,`
		1442	`name_tag);`
		1443	`pt(new_ident) = new_par; /* use of new new_ident by new_par*/`
		1444	`setlastuse(new_par); /* ... is last-and-only use of new_ident */`
		1445
		1446	`/* install res as body of new_ident */`
		1447	`clearlast(param);`
		1448	`bro(param) = res;`
		1449
		1450	`setlast(res);`
		1451	`bro(res) = new_ident;`
		1452
		1453	`bro(prev) = new_par;`
		1454
		1455	`res = new_ident; /* all done */`
		1456
		1457	`/* iteration */`
		1458	`if (last(new_par))`
		1459	`break;`
		1460
		1461	`param = bro(new_par);`
		1462	`prev = new_par;`
		1463	`}`
		1464	`else`
		1465	`{`
		1466	`/* iteration */`
		1467	`if (last(param))`
		1468	`break;`
		1469
		1470	`prev = param;`
		1471	`param = bro(param);`
		1472	`}`
		1473	`}`
		1474	`};`
		1475
		1476
		1477	`/* apply this transformation if the procedure has a structure-like`
		1478	`result and we want to make a new first parameter which is`
		1479	`a reference to where the result is to go. */`
		1480	`if (redo_structfns && !reg_result(result_shape))`
		1481	`{`
		1482	`/* replace f(x) by {var r; f(r, x); cont(r)} */`
		1483	`exp init, vardec, cont, contname, seq, app, appname, t;`
		1484	`exp_list list;`
		1485	`shape ptr_res_shape = f_pointer(f_alignment(result_shape));`
		1486
		1487	`init = getexp(result_shape, nilexp, 0, nilexp, nilexp,`
		1488	`0, 0, clear_tag);`
		1489	`vardec = getexp(result_shape, nilexp, 0, init, nilexp,`
		1490	`0, 1, ident_tag);`
		1491	`setvar(vardec);`
		1492	`contname = getexp(ptr_res_shape, nilexp, 0,`
		1493	`vardec, nilexp, 0, 0, name_tag);`
		1494	`pt(vardec) = contname;`
		1495	`cont = f_contents(result_shape, contname);`
		1496	`appname = getexp(ptr_res_shape, bro(son(res)), 0,`
		1497	`vardec, contname, 0, 0, name_tag);`
		1498	`++no(vardec);`
		1499	`pt(vardec) = appname;`
		1500	`app = getexp(f_top, nilexp, 0, son(res), nilexp, 0, 32,`
		1501	`apply_tag);`
		1502	`if (last(son(res)))`
		1503	`{`
		1504	`clearlast(son(res));`
		1505	`setlast(appname);`
		1506	`bro(appname) = app;`
		1507	`};`
		1508	`bro(son(res)) = appname;`
		1509	`t = son(app);`
		1510	`list.number = 1;`
		1511	`while (!last(t))`
		1512	`{`
		1513	`t = bro(t);`
		1514	`};`
		1515	`bro(t) = app;`
		1516	`list.start = app;`
		1517	`list.end = app;`
		1518	`seq = f_sequence(list, cont);`
		1519	`bro(init) = seq;`
		1520	`setfather(vardec, seq);`
		1521	`retcell(res);`
		1522	`return vardec;`
		1523	`};`
		1524
		1525
		1526	`return res;`
		1527	`}`
		1528
		1529	`exp f_assign`
		1530	`PROTO_N ( (arg1, arg2) )`
		1531	`PROTO_T ( exp arg1 X exp arg2 )`
		1532	`{`
		1533	`if (name(sh(arg1)) == bothd)`
		1534	`{ kill_exp(arg2,arg2); return arg1; }`
		1535	`if (name(sh(arg2)) == bothd)`
		1536	`{ kill_exp(arg1,arg1); return arg2; }`
		1537
		1538
		1539	`return me_b3( f_top, arg1, arg2, ass_tag);`
		1540	`}`
		1541
		1542	`exp f_assign_with_mode`
		1543	`PROTO_N ( (md, arg1, arg2) )`
		1544	`PROTO_T ( transfer_mode md X exp arg1 X exp arg2 )`
		1545	`{`
		1546	`if (name(sh(arg1)) == bothd)`
		1547	`{ kill_exp(arg2,arg2); return arg1; }`
		1548	`if (name(sh(arg2)) == bothd)`
		1549	`{ kill_exp(arg1,arg1); return arg2; }`
		1550
		1551	`if (md & f_complete) {`
		1552	`exp d = me_startid(f_top, arg2, 0);`
		1553	`return me_complete_id(d,`
		1554	`f_assign_with_mode(md & ~f_complete,arg1, me_obtain(d)) );`
		1555	`}`
		1556	`#ifdef no_trap_on_nil_contents`
		1557	`if ((md & f_trap_on_nil) != 0) {`
		1558	`exp d = me_startid(f_top, arg1, 0);`
		1559	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		1560	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		1561	`exp_list el;`
		1562	`exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),`
		1563	`f_make_null_ptr(al1_of(sh(arg1))), test_tag);`
		1564	`exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp,`
		1565
		1566	`md &= ~f_trap_on_nil;`
		1567	`el = new_exp_list(1);`
		1568	`el = add_exp_list(el, test, 1);`
		1569	`return me_complete_id(d,`
		1570	`f_conditional(&lb, f_sequence(el, trp),`
		1571	`f_assign_with_mode(md, me_obtain(d), arg2)) );`
		1572
		1573	`};`
		1574	`#endif`
		1575	`if ((md & f_volatile)!=0)`
		1576	`return me_b3(f_top, arg1, arg2, assvol_tag);`
		1577	`else`
		1578	`if ( (md & f_overlap) &&`
		1579	`(name(arg2) == cont_tag \|\| name(arg2) == contvol_tag) &&`
		1580	`! reg_result(sh(arg2)) )`
		1581	`return f_move_some(md, son(arg2), arg1,f_shape_offset(sh(arg2)));`
		1582	`else return me_b3(f_top, arg1, arg2, ass_tag);`
		1583	`}`
		1584
		1585	`exp f_bitfield_assign`
		1586	`PROTO_N ( (p, off, val) )`
		1587	`PROTO_T ( exp p X exp off X exp val )`
		1588	`{`
		1589	`exp res;`
		1590	`if (name(sh(p)) == bothd)`
		1591	`return p;`
		1592	`if (name(sh(val)) == bothd)`
		1593	`return val;`
		1594
		1595	`#if check_shape`
		1596	`if (name(sh(p)) != ptrhd \|\| name(sh(off)) != offsethd )`
		1597	`failer(CHSH_BFASS);`
		1598	`#endif`
		1599	`if (name(off) == val_tag) {`
		1600	`res = me_b3(f_top, p, val, bfass_tag);`
		1601	`no(res) = no(off);`
		1602	`return res;`
		1603	`}`
		1604	`else {`
		1605	`int alofptr = al1(sh(p));`
		1606	`shape s = containedshape(alofptr, 0);`
		1607	`shape bfs = sh(val);`
		1608	`int nbits = shape_size(sh(val));`
		1609	`alignment als = f_alignment(s);`
		1610	`alignment alb = long_to_al(1);`
		1611	`shape os = f_offset(als,als);`
		1612	`shape bos = f_offset(alb,alb);`
		1613	`exp mask0 = getexp(s, nilexp, 0, nilexp, nilexp, 0,`
		1614	`((1 << nbits)-1), val_tag);`
		1615
		1616	`exp noff1 = getexp(sh(off), nilexp, 0, nilexp, nilexp, 0, 0,`
		1617	`name_tag);`
		1618	`exp noff2 = getexp(sh(off), nilexp, 0, nilexp, noff1, 0, 0,`
		1619	`name_tag);`
		1620	`exp idoff = getexp(f_top, nilexp, 0, off, noff2, 0, 2, ident_tag);`
		1621	`son(noff1) = idoff; son(noff2) = idoff;`
		1622	`{`
		1623	`exp addbf = f_offset_add( noff1,f_shape_offset(bfs) );`
		1624	`exp byteoffinit = f_offset_subtract(hold_check(f_offset_pad(als, addbf)),`
		1625	`hold_check(f_offset_pad(als, f_shape_offset(s))) );`
		1626	`exp v1bit = getexp(bos, nilexp, 0, nilexp, nilexp, 0, 1, val_tag);`
		1627	`exp nby1 = getexp(os, nilexp, 0, nilexp, nilexp, 0, 0, name_tag);`
		1628	`exp nby2 = getexp(os, nilexp, 0, nilexp, nby1, 0, 0, name_tag);`
		1629	`exp nby3 = getexp(os, nilexp, 0, nilexp, nby2, 0, 0, name_tag);`
		1630	`exp idby = getexp(f_top, idoff, 1, byteoffinit, nby3, 0,`
		1631	`3, ident_tag);`
		1632	`exp bitoffinit = f_offset_div(ulongsh,`
		1633	`f_offset_subtract(noff2,f_offset_pad(f_alignment(bfs), nby2)),`
		1634	`v1bit);`
		1635	`exp bnt1 = getexp(ulongsh, nilexp,0, nilexp, nilexp, 0,`
		1636	`0, name_tag);`
		1637	`exp bnt2 = getexp(ulongsh, nilexp,0, nilexp, bnt1, 0, 0, name_tag);`
		1638	`#if little_end`
		1639	`exp idbnt = getexp(f_top, idby, 1, bitoffinit, bnt2, 0, 2, ident_tag);`
		1640	`#else`
		1641	`exp v = getexp(ulongsh, nilexp, 0, nilexp, nilexp, 0,`
		1642	`shape_size(s)-nbits, val_tag);`
		1643	`exp idbnt = getexp(f_top, idby, 1, f_minus(f_wrap, v, bitoffinit),`
		1644	`bnt2, 0, 2, ident_tag);`
		1645	`#endif`
		1646	`exp pn1 = getexp(sh(p), nilexp,0, nilexp, nilexp, 0, 0, name_tag);`
		1647	`exp pn2 = getexp(sh(p), nilexp,0, nilexp, pn1, 0, 0, name_tag);`
		1648	`exp idpn = getexp(f_top, idbnt, 1, f_add_to_ptr(p, nby1), pn2, 0,`
		1649	`2, ident_tag);`
		1650
		1651	`exp cnt; exp mask1; exp orit; exp asit;`
		1652	`son(nby1) = idby; son(nby2) = idby; son(nby3) = idby;`
		1653	`son(bnt1) = idbnt; son(bnt2) = idbnt;`
		1654	`son(pn1) = idpn; son(pn2) = idpn;`
		1655	`bro(son(idby)) = idbnt; clearlast(son(idby));`
		1656	`bro(son(idbnt)) = idpn; clearlast(son(idbnt));`
		1657	`bro(son(idoff)) = idby; clearlast(son(idoff));`
		1658
		1659	`mask1 = f_not(f_shift_left(f_wrap, mask0, bnt1));`
		1660	`cnt = f_and(f_contents(s, pn1), mask1);`
		1661	`orit = f_or(cnt, f_shift_left(f_wrap, f_change_bitfield_to_int(s, val),`
		1662	`bnt2));`
		1663	`asit = f_assign(pn2, orit);`
		1664	`bro(son(idpn)) = asit; clearlast(son(idpn));`
		1665	`bro(asit) = idpn; setlast(asit);`
		1666
		1667	`return idoff;`
		1668	`}`
		1669	`}`
		1670
		1671	`}`
		1672
		1673	`exp f_bitfield_assign_with_mode`
		1674	`PROTO_N ( (md, p, off, val) )`
		1675	`PROTO_T ( transfer_mode md X exp p X exp off X exp val )`
		1676	`{`
		1677	`exp res;`
		1678	`if (name(sh(p)) == bothd)`
		1679	`return p;`
		1680	`if (name(sh(val)) == bothd)`
		1681	`return val;`
		1682
		1683	`if (md == f_standard_transfer_mode)`
		1684	`return f_bitfield_assign (p, off, val);`
		1685
		1686	`#if check_shape`
		1687	`if (name(sh(p)) != ptrhd \|\| name(sh(off)) != offsethd \|\|`
		1688	`name(off) != val_tag)`
		1689	`failer(CHSH_BFASS);`
		1690	`#endif`
		1691	`#ifdef no_trap_on_nil_contents`
		1692	`if ((md & f_trap_on_nil) != 0) {`
		1693	`exp d = me_startid(f_top, p, 0);`
		1694	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		1695	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		1696	`exp_list el;`
		1697	`exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),`
		1698	`f_make_null_ptr(al1_of(sh(p))), test_tag);`
		1699	`exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp,`
		1700
		1701	`md &= ~f_trap_on_nil;`
		1702	`el = new_exp_list(1);`
		1703	`el = add_exp_list(el, test, 1);`
		1704	`return me_complete_id(d,`
		1705	`f_conditional(&lb, f_sequence(el, trp),`
		1706	`f_bitfield_assign_with_mode(md, me_obtain(d), off, val)) );`
		1707
		1708	`};`
		1709	`#endif`
		1710	`if (md & f_volatile)`
		1711	`res = me_b3(f_top, p, val, bfassvol_tag);`
		1712	`else`
		1713	`res = me_b3(f_top, p, val, bfass_tag);`
		1714	`no(res) = no(off);`
		1715	`return res;`
		1716	`}`
		1717
		1718	`exp f_bitfield_contents`
		1719	`PROTO_N ( (bf, p, off) )`
		1720	`PROTO_T ( bitfield_variety bf X exp p X exp off )`
		1721	`{`
		1722	`exp res;`
		1723	`if (name(sh(p)) == bothd)`
		1724	`return off;`
		1725	`if (name(sh(off)) == bothd)`
		1726	`return p;`
		1727
		1728	`#if check_shape`
		1729	`if (name(sh(p)) != ptrhd \|\| name(sh(off)) != offsethd )`
		1730	`failer(CHSH_BFCONT);`
		1731	`#endif`
		1732
		1733
		1734	`if (name(off) == val_tag) {`
		1735	`res = me_u3(f_bitfield(bf), p, bfcont_tag);`
		1736	`no(res) = no(off);`
		1737	`return res;`
		1738	`}`
		1739	`else {`
		1740	`int alofptr = al1(sh(p));`
		1741	`shape s = containedshape(alofptr, bf.has_sign);`
		1742	`shape bfs = f_bitfield(bf);`
		1743	`alignment als = f_alignment(s);`
		1744	`alignment alb = long_to_al(1);`
		1745	`shape ob = f_offset(alb,alb);`
		1746	`shape os = f_offset(als,als);`
		1747	`exp noff1 = getexp(sh(off), nilexp, 0, nilexp, nilexp, 0, 0,`
		1748	`name_tag);`
		1749	`exp noff2 = getexp(sh(off), nilexp, 0, nilexp, noff1, 0, 0,`
		1750	`name_tag);`
		1751	`exp idoff = getexp(s, nilexp, 0, off, noff2, 0, 2, ident_tag);`
		1752	`son(noff1) = idoff; son(noff2) = idoff;`
		1753	`{`
		1754	`exp addbf = f_offset_add( noff1, f_shape_offset(bfs) );`
		1755	`exp byteoffinit = f_offset_subtract(hold_check(f_offset_pad(als, addbf)),`
		1756	`hold_check(f_offset_pad(als, f_shape_offset(s))) );`
		1757	`exp nby1 = getexp(os, nilexp, 0, nilexp, nilexp, 0, 0, name_tag);`
		1758	`exp nby2 = getexp(os, nilexp, 0, nilexp, nby1, 0, 0, name_tag);`
		1759	`exp idby = getexp(s, nilexp, 0, byteoffinit, nby2, 0, 2, ident_tag);`
		1760	`exp cnt; exp sh1; exp sh2; exp bitoff; exp shl;`
		1761	`exp v = getexp(ulongsh, nilexp, 0, nilexp, nilexp, 0,`
		1762	`shape_size(s) - bf.bits, val_tag);`
		1763	`exp v1bit = getexp(ob, nilexp, 0, nilexp, nilexp, 0, 1, val_tag);`
		1764	`son(nby1) = idby; son(nby2) = idby;`
		1765	`cnt = f_contents(s, f_add_to_ptr(p, nby1));`
		1766	`bitoff = f_offset_div(ulongsh,`
		1767	`f_offset_subtract(noff2,f_offset_pad(f_alignment(bfs), nby2)),`
		1768	`v1bit);`
		1769	`#if (little_end)`
		1770	`shl = f_minus(f_wrap, copy(v), bitoff);`
		1771	`#else`
		1772	`shl = bitoff;`
		1773	`#endif`
		1774	`sh1 = f_shift_left(f_wrap,cnt, shl);`
		1775	`sh2 = f_shift_right(sh1, v);`
		1776	`bro(byteoffinit) = sh2; clearlast(byteoffinit);`
		1777	`bro(sh2) = idby; setlast(sh2);`
		1778	`bro(off) = idby; clearlast(off);`
		1779	`bro(idby) = idoff; setlast(idby);`
		1780	`return(f_change_int_to_bitfield(bf, idoff));`
		1781	`}`
		1782	`}`
		1783
		1784	`}`
		1785
		1786	`exp f_bitfield_contents_with_mode`
		1787	`PROTO_N ( (md, bf, p, off) )`
		1788	`PROTO_T ( transfer_mode md X bitfield_variety bf X exp p X exp off )`
		1789	`{`
		1790	`exp res;`
		1791	`if (name(sh(p)) == bothd)`
		1792	`return p;`
		1793
		1794	`#if check_shape`
		1795	`if (name(sh(p)) != ptrhd \|\| name(sh(off)) != offsethd \|\|`
		1796	`name(off) != val_tag)`
		1797	`failer(CHSH_BFCONT);`
		1798	`#endif`
		1799	`#ifdef no_trap_on_nil_contents`
		1800	`if ((md & f_trap_on_nil) != 0) {`
		1801	`exp d = me_startid(f_bitfield(bf), p, 0);`
		1802	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		1803	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		1804	`exp_list el;`
		1805	`exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),`
		1806	`f_make_null_ptr(al1_of(sh(p))), test_tag);`
		1807	`exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp,`
		1808
		1809	`md &= ~f_trap_on_nil;`
		1810	`el = new_exp_list(1);`
		1811	`el = add_exp_list(el, test, 1);`
		1812	`return me_complete_id(d,`
		1813	`f_conditional(&lb, f_sequence(el, trp),`
		1814	`f_bitfield_contents_with_mode(md, bf, me_obtain(d), off)) );`
		1815
		1816	`};`
		1817	`#endif`
		1818
		1819	`if (md == f_volatile)`
		1820	`res = me_u3(f_bitfield(bf), p, bfcontvol_tag);`
		1821	`else`
		1822	`res = me_u3(f_bitfield(bf), p, bfcont_tag);`
		1823	`no(res) = no(off);`
		1824	`return res;`
		1825	`}`
		1826
		1827
		1828	`#if do_case_transforms`
		1829
		1830	`exp f_case`
		1831	`PROTO_N ( (exhaustive, control, branches) )`
		1832	`PROTO_T ( bool exhaustive X exp control X caselim_list branches )`
		1833	`{`
		1834	`exp r, ht;`
		1835	`shape case_shape;`
		1836	`exp changer;`
		1837	`exp body_of_ident;`
		1838	`exp control_expression;`
		1839	`exp body_of_case;`
		1840	`exp id;`
		1841	`exp copy_ce;`
		1842	`shape changer_shape = (shape_size(sh(control)) >= SLONG_SZ) ? sh(control)`
		1843	`: is_signed(sh(control)) ? slongsh : ulongsh;`
		1844
		1845	`/* UNUSED(branches);`
		1846	`*/`
		1847	`if (name(sh(control)) == bothd)`
		1848	`return control;`
		1849
		1850
		1851
		1852	`bro(global_case) = nilexp;`
		1853	`while(branches != nilexp) {`
		1854	`exp hd = branches;`
		1855	`branches = bro(branches);`
		1856	`bro(hd) = nilexp;`
		1857	`sh(hd) = sh(control);`
		1858	`if (son(hd) != nilexp) {`
		1859	`sh(son(hd)) = sh(control);`
		1860	`}`
		1861	`if (son(hd) != nilexp && docmp_f((int)f_less_than, son(hd), hd)){`
		1862	`--no (son (pt(hd)));`
		1863	`retcell(son(hd));`
		1864	`retcell(hd);`
		1865	`}`
		1866	`else`
		1867	`case_item(hd);`
		1868	`}`
		1869
		1870	`if (bro(global_case) == nilexp)`
		1871	`return control;`
		1872	`case_shape = (exhaustive) ? f_bottom : f_top;`
		1873
		1874	`if (PIC_code)`
		1875	`proc_externs = 1;`
		1876
		1877	`#if check_shape`
		1878	`if (!is_integer(sh(control)))`
		1879	`failer(CHSH_CASE);`
		1880	`#endif`
		1881
		1882	`r = getexp (case_shape, nilexp, 0, control, nilexp, 0,`
		1883	`0, case_tag);`
		1884	`clearlast(control);`
		1885	`bro(control) = bro(global_case);`
		1886	`ht = control;`
		1887	`while (bro (ht) != nilexp) {`
		1888	`ht = bro (ht);`
		1889	`sh(ht) = changer_shape;`
		1890	`if (son(ht) != nilexp)`
		1891	`sh(son(ht)) = changer_shape;`
		1892	`};`
		1893	`setlast (ht);`
		1894	`bro (ht) = r;`
		1895
		1896	`control_expression = son (r);`
		1897	`body_of_case = bro (son (r));`
		1898
		1899	`copy_ce = copy(control_expression);`
		1900	`changer = hold_check(me_u3 (changer_shape, control_expression, chvar_tag));`
		1901	`id = me_startid (sh (changer), changer, 1);`
		1902	`/* the shape of the ident will be overwritten by me_complete_id */`
		1903	`body_of_ident = case_optimisation (body_of_case, id, sh (r),`
		1904	`copy_ce);`
		1905	`id = me_complete_id (id, body_of_ident);`
		1906
		1907	`#ifdef NEWDIAGS`
		1908	`if (extra_diags)`
		1909	`id = f_dg_exp (id, f_branch_dg (f_dg_null_sourcepos));`
		1910	`#endif`
		1911
		1912	`return (hold_check(id));`
		1913	`}`
		1914
		1915	`#else`
		1916
		1917	`exp f_case`
		1918	`PROTO_N ( (exhaustive, control, branches) )`
		1919	`PROTO_T ( bool exhaustive X exp control X caselim_list branches )`
		1920	`{`
		1921	`exp r, ht;`
		1922	`shape case_shape;`
		1923	`/* UNUSED(branches);`
		1924	`if (name(sh(control)) == bothd \|\| bro(global_case) == nilexp)`
		1925	`return control;`
		1926	`*/`
		1927	`if (name(sh(control)) == bothd)`
		1928	`return control;`
		1929
		1930	`bro(global_case) = nilexp;`
		1931	`while(branches != nilexp) {`
		1932	`exp hd = branches;`
		1933	`branches = bro(branches);`
		1934	`bro(hd) = nilexp;`
		1935	`sh(hd) = sh(control);`
		1936	`if (son(hd) != nilexp) {`
		1937	`sh(son(hd)) = sh(control);`
		1938	`}`
		1939	`if (son(hd) != nilexp && docmp_f((int)f_less_than, son(hd), hd)){`
		1940	`--no (son (pt(hd)));`
		1941	`retcell(son(hd));`
		1942	`retcell(hd);`
		1943	`}`
		1944	`else`
		1945	`case_item(hd);`
		1946	`}`
		1947	`if (bro(global_case) == nilexp)`
		1948	`return control;`
		1949	`case_shape = (exhaustive) ? f_bottom : f_top;`
		1950
		1951	`if (PIC_code)`
		1952	`proc_externs = 1;`
		1953
		1954	`#if check_shape`
		1955	`if (!is_integer(sh(control)))`
		1956	`failer(CHSH_CASE);`
		1957	`#endif`
		1958
		1959	`r = getexp (case_shape, nilexp, 0, control, nilexp, 0,`
		1960	`0, case_tag);`
		1961	`clearlast(control);`
		1962	`bro(control) = bro(global_case);`
		1963	`ht = control;`
		1964	`while (bro (ht) != nilexp) {`
		1965	`ht = bro (ht);`
		1966	`sh(ht) = sh(control);`
		1967	`if (son(ht) != nilexp)`
		1968	`sh(son(ht)) = sh(control);`
		1969	`};`
		1970	`setlast (ht);`
		1971	`bro (ht) = r;`
		1972
		1973	`#ifdef NEWDIAGS`
		1974	`if (extra_diags)`
		1975	`r = f_dg_exp (r, f_branch_dg (f_dg_null_sourcepos));`
		1976	`#endif`
		1977
		1978	`return (r);`
		1979	`}`
		1980
		1981	`#endif`
		1982
		1983	`exp f_change_bitfield_to_int`
		1984	`PROTO_N ( (x, arg1) )`
		1985	`PROTO_T ( variety x X exp arg1 )`
		1986	`{`
		1987	`if (name(sh(arg1)) == bothd)`
		1988	`return arg1;`
		1989
		1990	`#if check_shape`
		1991	`if (name(sh(arg1)) != bitfhd)`
		1992	`failer(CHSH_CHBITFIELD);`
		1993	`#endif`
		1994	`#if !has64bits`
		1995	`if (shape_size(x)>32) {`
		1996	`shape n32 = (is_signed(x))?slongsh:ulongsh;`
		1997	`exp z = hold_check(me_c2(n32, arg1, bitf_to_int_tag));`
		1998	`return f_change_variety(f_impossible, x, z);`
		1999	`}`
		2000	`#endif`
		2001	`return me_c2(f_integer(x), arg1, bitf_to_int_tag);`
		2002	`}`
		2003
		2004
		2005
		2006	`exp f_change_int_to_bitfield`
		2007	`PROTO_N ( (x, arg1) )`
		2008	`PROTO_T ( bitfield_variety x X exp arg1 )`
		2009	`{`
		2010	`if (name(sh(arg1)) == bothd)`
		2011	`return arg1;`
		2012
		2013	`#if check_shape`
		2014	`if (!is_integer(sh(arg1)))`
		2015	`failer(CHSH_CHINTBF);`
		2016	`#endif`
		2017	`#if !has64bits`
		2018	`if (shape_size(sh(arg1))>32) {`
		2019	`shape n32 = (is_signed(sh(arg1)))?slongsh:ulongsh;`
		2020	`arg1 = hold_check(f_change_variety(f_wrap, n32, arg1));`
		2021	`}`
		2022	`#endif`
		2023
		2024	`return me_c2(f_bitfield(x), arg1, int_to_bitf_tag);`
		2025	`}`
		2026
		2027	`exp f_change_variety`
		2028	`PROTO_N ( (ov_err, r, arg1) )`
		2029	`PROTO_T ( error_treatment ov_err X variety r X exp arg1 )`
		2030	`{`
		2031	`if (name(sh(arg1)) == bothd)`
		2032	`return arg1;`
		2033
		2034	`#if check_shape`
		2035	`if (!is_integer(sh(arg1)))`
		2036	`failer(CHSH_CHVAR);`
		2037	`#endif`
		2038	`#if !has64bits`
		2039	`if ((name(arg1)!=val_tag \|\| ov_err.err_code >2)`
		2040	`&&( shape_size(sh(arg1))> 32 \|\| name(r)>=s64hd)`
		2041	`&& name(sh(arg1)) != name(r) ){`
		2042	`exp e = arg1;`
		2043	`int ss = is_signed(sh(arg1));`
		2044	`int sd = is_signed(r);`
		2045	`shape x =(ss)?slongsh:ulongsh;`
		2046	`if (shape_size(sh(arg1)) <=32) {`
		2047	`exp e = hold_check(me_c1(x,ov_err, arg1, chvar_tag));`
		2048	`exp z = TDFcallaux(ov_err, e,`
		2049	`(sd)?((ss)?"__TDFUsswiden":"__TDFUuswiden"):`
		2050	`(ss)?"__TDFUsuwiden":"__TDFUuuwiden", r);`
		2051	`return z;`
		2052	`}`
		2053	`else`
		2054	`if (name(r) >= s64hd) {`
		2055	`return TDFcallaux(ov_err, e, (sd)?"__TDFUu642s64":"__TDFUs642u64", r);`
		2056	`}`
		2057	`else {`
		2058	`exp e = TDFcallaux(ov_err, arg1,`
		2059	`(sd)?((ss)?"__TDFUssshorten":"__TDFUusshorten"):`
		2060	`(ss)?"__TDFUsushorten":"__TDFUuushorten",`
		2061	`(sd)?slongsh:ulongsh);`
		2062	`return hold_check(me_c1(f_integer(r),ov_err, e, chvar_tag));`
		2063	`}`
		2064
		2065	`}`
		2066	`#endif`
		2067	`return me_c1(f_integer(r), ov_err, arg1, chvar_tag);`
		2068	`}`
		2069
		2070
		2071
		2072
		2073	`exp f_component`
		2074	`PROTO_N ( (sha, arg1, arg2) )`
		2075	`PROTO_T ( shape sha X exp arg1 X exp arg2 )`
		2076	`{`
		2077	`if (name(sh(arg1)) == bothd)`
		2078	`{ kill_exp(arg2,arg2); return arg1; }`
		2079	`if (name(sh(arg2)) == bothd)`
		2080	`{ kill_exp(arg1,arg1); return arg2; }`
		2081
		2082	`#if check_shape`
		2083	`if (!doing_aldefs &&`
		2084	`(name(sh(arg2)) != offsethd \|\| name(sh(arg1)) != cpdhd \|\|`
		2085	`shape_align(sh(arg1)) < al1(sh(arg2)) \|\|`
		2086	`shape_align(sha) > al2(sh(arg2))))`
		2087	`failer(CHSH_COMPONENT);`
		2088	`#endif`
		2089
		2090	`return me_b3(sha, arg1, arg2, component_tag);`
		2091	`}`
		2092
		2093	`exp f_concat_nof`
		2094	`PROTO_N ( (arg1, arg2) )`
		2095	`PROTO_T ( exp arg1 X exp arg2 )`
		2096	`{`
		2097	`shape sha = getshape(0, const_al1, al2_of(sh(arg1)),`
		2098	`align_of(sh(arg1)),`
		2099	`shape_size(sh(arg1)) + shape_size(sh(arg2)),`
		2100	`nofhd);`
		2101	`if (name(sh(arg1)) == bothd)`
		2102	`{ kill_exp(arg2,arg2); return arg1; }`
		2103	`if (name(sh(arg2)) == bothd)`
		2104	`{ kill_exp(arg1,arg1); return arg2; }`
		2105
		2106	`/* al2_of(sh(arg1)) is the shapemacs.h hd of the nof shape */`
		2107	`#if check_shape`
		2108	`if (!doing_aldefs &&`
		2109	`(shape_align(sh(arg1)) != shape_align(sh(arg2))))`
		2110	`failer(CHSH_CONCATNOF);`
		2111	`#endif`
		2112
		2113	`return me_b3(sha, arg1, arg2, concatnof_tag);`
		2114	`}`
		2115
		2116	`exp f_conditional`
		2117	`PROTO_N ( (alt_label_intro, first, alt) )`
		2118	`PROTO_T ( label alt_label_intro X exp first X exp alt )`
		2119	`{`
		2120	`shape res_shape;`
		2121	`exp r, labst, def;`
		2122	`labst = get_lab(alt_label_intro);`
		2123
		2124	`res_shape = lub_shape (sh (first), sh (alt));`
		2125	`r = getexp (res_shape, nilexp, 0, first, nilexp, 0,`
		2126	`0, cond_tag);`
		2127	`def = son(labst);`
		2128	`setbro(first, labst);`
		2129	`clearlast(first);`
		2130	`setbro(def, alt);`
		2131	`clearlast(def);`
		2132	`setbro(alt, labst);`
		2133	`setlast(alt);`
		2134	`setsh(labst, sh(alt));`
		2135	`setfather (r, labst);`
		2136	`default_freq = (float) (2.0 * default_freq);`
		2137	`return r;`
		2138	`}`
		2139
		2140	`void start_conditional`
		2141	`PROTO_N ( (alt_label_intro) )`
		2142	`PROTO_T ( label alt_label_intro )`
		2143	`{`
		2144	`exp tg;`
		2145	`exp labst;`
		2146	`tg = getexp (f_top, nilexp, 0, nilexp, nilexp, 0, 0,`
		2147	`clear_tag);`
		2148	`labst = getexp (f_bottom, nilexp, 0, tg, nilexp,`
		2149	`0, 0, labst_tag);`
		2150	`default_freq = (float) (default_freq / 2.0);`
		2151	`fno(labst) = default_freq;`
		2152	`++proc_label_count;`
		2153	`set_lab(alt_label_intro, labst);`
		2154	`return;`
		2155	`}`
		2156
		2157	`exp f_contents`
		2158	`PROTO_N ( (s, arg1) )`
		2159	`PROTO_T ( shape s X exp arg1 )`
		2160	`{`
		2161	`if (name(sh(arg1)) == bothd)`
		2162	`return arg1;`
		2163
		2164	`#if check_shape`
		2165	`if (!doing_aldefs &&`
		2166	`(name(sh(arg1)) != ptrhd \|\|`
		2167	`(al1(sh(arg1)) < shape_align(s)`
		2168	`#if issparc`
		2169	`&& align_of(s) != REAL_ALIGN`
		2170	`#endif`
		2171	`) )) {`
		2172	`failer(CHSH_CONTENTS);`
		2173	`}`
		2174	`#endif`
		2175
		2176
		2177
		2178	`return me_c2(s, arg1, cont_tag);`
		2179	`}`
		2180
		2181	`exp f_contents_with_mode`
		2182	`PROTO_N ( (md, s, arg1) )`
		2183	`PROTO_T ( transfer_mode md X shape s X exp arg1 )`
		2184	`{`
		2185	`if (name(sh(arg1)) == bothd)`
		2186	`return arg1;`
		2187
		2188	`#if check_shape`
		2189	`if (!doing_aldefs &&`
		2190	`(name(sh(arg1)) != ptrhd \|\|`
		2191	`(al1(sh(arg1)) < shape_align(s)`
		2192	`&& al1_of(sh(arg1))-> al.sh_hd != doublehd) ))`
		2193	`failer(CHSH_CONTENTS_VOL);`
		2194	`#endif`
		2195	`#ifdef no_trap_on_nil_contents`
		2196	`if ((md & f_trap_on_nil) != 0) {`
		2197	`exp d = me_startid(s, arg1, 0);`
		2198	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		2199	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		2200	`exp_list el;`
		2201	`exp test = me_q1(no_nat_option, f_equal, &lb, me_obtain(d),`
		2202	`f_make_null_ptr(f_alignment(s)), test_tag);`
		2203	`exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp,`
		2204
		2205	`md &= ~f_trap_on_nil;`
		2206	`el = new_exp_list(1);`
		2207	`el = add_exp_list(el, test, 1);`
		2208	`return me_complete_id(d,`
		2209	`f_conditional(&lb, f_sequence(el, trp),`
		2210	`f_contents_with_mode(md, s, me_obtain(d))) );`
		2211
		2212	`};`
		2213	`#endif`
		2214	`if (md & f_volatile)`
		2215	`return me_c2(s, arg1, contvol_tag);`
		2216	`else`
		2217	`return me_c2(s, arg1, cont_tag);`
		2218	`}`
		2219
		2220	`exp f_current_env`
		2221	`PROTO_Z ()`
		2222	`{`
		2223	`if (!in_proc_def) failer("current_env must be in proc definition");`
		2224	`uses_crt_env = 1;`
		2225	`uses_loc_address = 1;`
		2226	`return getexp(f_pointer(frame_alignment), nilexp, 0,`
		2227	`nilexp, nilexp, 0, 0, current_env_tag);`
		2228
		2229	`}`
		2230
		2231	`int eq_et`
		2232	`PROTO_N ( (a, b) )`
		2233	`PROTO_T ( error_treatment a X error_treatment b )`
		2234	`{`
		2235	`return ( a.err_code == b.err_code`
		2236	`&& (a.err_code != 4 \|\| a.jmp_dest == b.jmp_dest)`
		2237	`);`
		2238	`}`
		2239
		2240	`exp div_rem`
		2241	`PROTO_N ( (div0_err, ov_err, arg1, arg2, f) )`
		2242	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X`
		2243	`exp arg2 X exp (*f) PROTO_S ((error_treatment, exp, exp)) )`
		2244	`{`
		2245	`if (eq_et(div0_err, ov_err) \|\| eq_et(ov_err, f_impossible)) {`
		2246	`return f(div0_err, arg1, arg2);`
		2247	`}`
		2248	`else`
		2249	`if (eq_et(div0_err, f_impossible)) {`
		2250	`return f(ov_err, arg1, arg2);`
		2251	`}`
		2252	`else {`
		2253	`exp da2 = me_startid(sh(arg1), arg2, 0);`
		2254	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		2255	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		2256	`exp tst = f_integer_test(no_nat_option, f_equal, &lb,`
		2257	`me_obtain(da2), me_shint(sh(arg2), 0));`
		2258	`exp_list st;`
		2259	`exp wrong;`
		2260	`st = new_exp_list(1);`
		2261	`st = add_exp_list(st,tst,0);`
		2262	`if (div0_err.err_code == 4) {`
		2263	`wrong = f_goto(div0_err.jmp_dest);`
		2264	`}`
		2265	`else`
		2266	`if (div0_err.err_code > 4) {`
		2267	`wrong = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,`
		2268	`f_overflow, trap_tag);`
		2269	`}`
		2270	`else {`
		2271	`wrong = me_shint(sh(arg1), 0);`
		2272	`}`
		2273	`return me_complete_id(da2,`
		2274	`f_conditional(&lb, f_sequence(st, wrong),`
		2275	`f(ov_err, arg1, me_obtain(da2)) ) );`
		2276	`}`
		2277	`}`
		2278
		2279	`exp div0_aux`
		2280	`PROTO_N ( (ov_err, arg1, arg2) )`
		2281	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		2282	`{`
		2283	`#if !has64bits`
		2284	`if (name(sh(arg1)) >= s64hd &&`
		2285	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag`
		2286	`\|\| ov_err.err_code > 2)){`
		2287	`return TDFcallop2(ov_err,arg1,arg2,div0_tag);`
		2288	`}`
		2289	`#endif`
		2290	`#if div0_implemented`
		2291	`return me_b1(ov_err, arg1, arg2, div0_tag);`
		2292	`#else`
		2293	`if (name(arg2) == val_tag && !isbigval(arg2)) {`
		2294	`int n = no(arg2);`
		2295	`if ((n & (n-1)) == 0)`
		2296	`return me_b1(ov_err, arg1, arg2, div1_tag);`
		2297	`};`
		2298	`return me_b1(ov_err, arg1, arg2, div2_tag);`
		2299	`#endif`
		2300	`}`
		2301	`exp f_div0`
		2302	`PROTO_N ( (div0_err, ov_err, arg1, arg2) )`
		2303	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 )`
		2304	`{`
		2305	`if (name(sh(arg1)) == bothd)`
		2306	`{ kill_exp(arg2,arg2); return arg1; }`
		2307	`if (name(sh(arg2)) == bothd)`
		2308	`{ kill_exp(arg1,arg1); return arg2; }`
		2309
		2310	`#if check_shape`
		2311	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		2312	`failer(CHSH_DIV0);`
		2313	`#endif`
		2314	`return div_rem(div0_err, ov_err, arg1, arg2, div0_aux);`
		2315	`}`
		2316
		2317	`exp div1_aux`
		2318	`PROTO_N ( (ov_err, arg1, arg2) )`
		2319	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		2320	`{`
		2321	`#if !has64bits`
		2322	`if (name(sh(arg1)) >= s64hd &&`
		2323	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag`
		2324	`\|\| ov_err.err_code > 2)){`
		2325	`return TDFcallop2(ov_err,arg1,arg2,div1_tag);`
		2326	`}`
		2327	`#endif`
		2328	`return me_b1(ov_err, arg1, arg2, div1_tag);`
		2329	`}`
		2330
		2331	`exp f_div1`
		2332	`PROTO_N ( (div0_err, ov_err, arg1, arg2) )`
		2333	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 )`
		2334	`{`
		2335	`if (name(sh(arg1)) == bothd)`
		2336	`{ kill_exp(arg2,arg2); return arg1; }`
		2337	`if (name(sh(arg2)) == bothd)`
		2338	`{ kill_exp(arg1,arg1); return arg2; }`
		2339
		2340	`#if check_shape`
		2341	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		2342	`failer(CHSH_DIV1);`
		2343	`#endif`
		2344
		2345	`return div_rem(div0_err, ov_err, arg1, arg2, div1_aux);`
		2346	`}`
		2347
		2348	`exp div2_aux`
		2349	`PROTO_N ( (ov_err, arg1, arg2) )`
		2350	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		2351	`{`
		2352	`#if !has64bits`
		2353	`if (name(sh(arg1)) >= s64hd &&`
		2354	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag`
		2355	`\|\| ov_err.err_code > 2)) {`
		2356	`return TDFcallop2(ov_err,arg1,arg2,div2_tag);`
		2357	`}`
		2358	`#endif`
		2359	`return me_b1(ov_err, arg1, arg2, div2_tag);`
		2360	`}`
		2361
		2362	`exp f_div2`
		2363	`PROTO_N ( (div0_err, ov_err, arg1, arg2) )`
		2364	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 )`
		2365	`{`
		2366	`if (name(sh(arg1)) == bothd)`
		2367	`{ kill_exp(arg2,arg2); return arg1; }`
		2368	`if (name(sh(arg2)) == bothd)`
		2369	`{ kill_exp(arg1,arg1); return arg2; }`
		2370
		2371
		2372	`#if check_shape`
		2373	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		2374	`failer(CHSH_DIV2);`
		2375	`#endif`
		2376	`return div_rem(div0_err, ov_err, arg1, arg2, div2_aux);`
		2377	`}`
		2378
		2379
		2380
		2381	`exp f_env_offset`
		2382	`PROTO_N ( (fa, y, t) )`
		2383	`PROTO_T ( alignment fa X alignment y X tag t )`
		2384	`{`
		2385	`exp e = get_tag(t);`
		2386	`shape s = f_offset(fa, y);`
		2387	`exp res;`
		2388	`if (e == nilexp) {`
		2389	`e = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0,`
		2390	`0, ident_tag);`
		2391	`son(e) = e; /* used to indicate that tag is not yet defined!?*/`
		2392	`set_tag(t, e);`
		2393	`}`
		2394	`res = getexp(s, nilexp, 0, e, nilexp, 0, 0, env_offset_tag);`
		2395	`setvis(e);`
		2396	`setenvoff(e);`
		2397	`return res;`
		2398	`}`
		2399
		2400
		2401
		2402	`exp f_fail_installer`
		2403	`PROTO_N ( (message) )`
		2404	`PROTO_T ( string message )`
		2405	`{`
		2406	`char * m = (char *)xcalloc(message.number+1, sizeof(char));`
		2407	`int i;`
		2408	`for (i=0; i<message.number; ++i)`
		2409	`m[i] = message.ints.chars[i];`
		2410	`m[message.number] = 0;`
		2411	`failer(m);`
		2412	`exit(EXIT_FAILURE);`
		2413	`return(nilexp);`
		2414	`}`
		2415
		2416
		2417
		2418	`exp f_goto`
		2419	`PROTO_N ( (dest) )`
		2420	`PROTO_T ( label dest )`
		2421	`{`
		2422	`exp lab = get_lab(dest);`
		2423	`exp r = getexp(f_bottom, nilexp, 0, nilexp, lab,`
		2424	`0, 0, goto_tag);`
		2425	`++no(son(lab));`
		2426	`return r;`
		2427	`}`
		2428
		2429	`exp f_goto_local_lv`
		2430	`PROTO_N ( (arg1) )`
		2431	`PROTO_T ( exp arg1 )`
		2432	`{`
		2433	`if (name(sh(arg1)) == bothd)`
		2434	`return arg1;`
		2435
		2436	`#if check_shape`
		2437	`if (name(sh(arg1)) != ptrhd)`
		2438	`failer(CHSH_GOLOCALLV);`
		2439	`#endif`
		2440
		2441	`return me_u3(f_bottom, arg1, goto_lv_tag);`
		2442	`}`
		2443
		2444	`exp f_identify`
		2445	`PROTO_N ( (acc, name_intro, definition, body) )`
		2446	`PROTO_T ( access_option acc X tag name_intro X exp definition X exp body )`
		2447	`{`
		2448	`exp i = get_tag(name_intro);`
		2449	`exp d = son(i);`
		2450	`UNUSED(acc);`
		2451	`if (name(sh(definition)) == bothd)`
		2452	`{ kill_exp(body,body); return definition; }`
		2453	`setsh(i, sh(body));`
		2454	`setbro(d, body);`
		2455	`clearlast(d);`
		2456	`setfather (i, body);`
		2457	`return i;`
		2458	`}`
		2459
		2460	`void start_identify`
		2461	`PROTO_N ( (acc, name_intro, definition) )`
		2462	`PROTO_T ( access_option acc X tag name_intro X exp definition )`
		2463	`{`
		2464	`exp i = get_tag(name_intro);`
		2465	`if (i == nilexp \|\| son(i) != i) {`
		2466	`i = getexp(f_bottom, nilexp, 0, definition, nilexp, 0,`
		2467	`0, ident_tag);`
		2468	`}`
		2469	`else { /* could have been already used in env_offset */`
		2470	`son(i) = definition;`
		2471	`}`
		2472	`clearvar(i);`
		2473	`if ((acc & (f_visible \| f_long_jump_access)) != 0)`
		2474	`{`
		2475	`setvis(i);`
		2476	`};`
		2477	`set_tag(name_intro, i);`
		2478
		2479	`return;`
		2480	`}`
		2481
		2482	`exp f_ignorable`
		2483	`PROTO_N ( (arg1) )`
		2484	`PROTO_T ( exp arg1 )`
		2485	`{`
		2486	`if (name(sh(arg1)) == bothd)`
		2487	`return arg1;`
		2488	`return me_u2(arg1, ignorable_tag);`
		2489	`}`
		2490
		2491
		2492	`exp f_integer_test`
		2493	`PROTO_N ( (prob, nt, dest, arg1, arg2) )`
		2494	`PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X exp arg2 )`
		2495	`{`
		2496	`if (name(sh(arg1)) == bothd)`
		2497	`{ kill_exp(arg2,arg2); return arg1; }`
		2498	`if (name(sh(arg2)) == bothd)`
		2499	`{ kill_exp(arg1,arg1); return arg2; }`
		2500
		2501	`#if check_shape`
		2502	`if (!is_integer(sh(arg1)) \|\| !eq_shape(sh(arg1), sh(arg2)))`
		2503	`failer(CHSH_INTTEST);`
		2504	`#endif`
		2505	`#if !has64bits`
		2506	`if (name(sh(arg1)) >= s64hd &&`
		2507	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)) {`
		2508	`error_treatment ov_err;`
		2509	`ov_err = f_wrap;`
		2510	`arg1 = TDFcallop2(ov_err,arg1,arg2,test_tag);`
		2511	`arg2 = getexp(slongsh, nilexp, 0, nilexp, nilexp, 0,`
		2512	`0, val_tag);`
		2513	`}`
		2514	`#endif`
		2515	`if (nt == f_comparable \|\| nt == f_not_comparable)`
		2516	`return replace_ntest(nt, dest, arg1, arg2);`
		2517	`else`
		2518	`return me_q1(prob, convert_ntest[nt], dest, arg1, arg2, test_tag);`
		2519	`}`
		2520
		2521	`exp f_labelled`
		2522	`PROTO_N ( (placelabs_intro, starter, places) )`
		2523	`PROTO_T ( label_list placelabs_intro X exp starter X exp_list places )`
		2524	`{`
		2525	`exp f = places.start;`
		2526	`exp b;`
		2527	`int i;`
		2528	`clear_exp_list(places);`
		2529
		2530	`for (i=0; i<places.number; ++i)`
		2531	`{exp labst = get_lab(placelabs_intro.elems[i]);`
		2532	`b = bro(f);`
		2533
		2534	`setbro(son(labst), f);`
		2535	`setbro(f, labst);`
		2536	`setlast(f);`
		2537	`setsh(labst, sh(f));`
		2538	`if (name(starter) == case_tag \|\|`
		2539	`(name(starter) == seq_tag && name(son(son(starter))) == case_tag))`
		2540	`fno(labst) = (float)(1.0/places.number);`
		2541	`else`
		2542	`fno(labst) = (float)5.0;`
		2543	`f = b;`
		2544	`};`
		2545	`return(clean_labelled(starter, placelabs_intro));`
		2546	`}`
		2547
		2548	`void start_labelled`
		2549	`PROTO_N ( ( placelabs_intro) )`
		2550	`PROTO_T ( label_list placelabs_intro )`
		2551	`{`
		2552	`UNUSED(placelabs_intro);`
		2553	`if (crt_repeat != nilexp)`
		2554	`++no (crt_repeat);`
		2555	`repeat_list = getexp (f_top, crt_repeat, 0, nilexp,`
		2556	`repeat_list, 0, 0, 0);`
		2557	`crt_repeat = repeat_list;`
		2558
		2559	`return;`
		2560	`}`
		2561
		2562	`exp f_last_local`
		2563	`PROTO_N ( (x) )`
		2564	`PROTO_T ( exp x )`
		2565	`{`
		2566	`UNUSED(x);`
		2567	`return getexp(f_pointer(f_alloca_alignment), nilexp, 0, nilexp, nilexp,`
		2568	`0, 0, last_local_tag);`
		2569	`}`
		2570
		2571	`exp f_local_alloc`
		2572	`PROTO_N ( (arg1) )`
		2573	`PROTO_T ( exp arg1 )`
		2574	`{`
		2575	`alignment a;`
		2576	`if (name(sh(arg1)) == bothd)`
		2577	`return arg1;`
		2578
		2579	`#if check_shape`
		2580	`if (name(sh(arg1)) != offsethd)`
		2581	`failer(CHSH_LOCALLOC);`
		2582	`#endif`
		2583	`if (al2(sh(arg1)) <8 ) {`
		2584	`arg1 = hold_check(f_offset_pad(f_alignment(ucharsh), arg1) );`
		2585	`}`
		2586	`a = long_to_al(al1(sh(arg1)));`
		2587	`has_alloca = 1;`
		2588	`return me_u3(f_pointer(a), arg1, alloca_tag);`
		2589	`}`
		2590
		2591	`exp f_local_alloc_check`
		2592	`PROTO_N ( (arg1) )`
		2593	`PROTO_T ( exp arg1 )`
		2594	`{`
		2595	`exp res = f_local_alloc(arg1);`
		2596	`if (name(res)==alloca_tag) {`
		2597	`set_checkalloc(res);`
		2598	`}`
		2599	`return res;`
		2600	`}`
		2601
		2602	`exp f_local_free`
		2603	`PROTO_N ( (a, p) )`
		2604	`PROTO_T ( exp a X exp p )`
		2605	`{`
		2606	`if (name(sh(a)) == bothd)`
		2607	`{ kill_exp(p,p); return a; }`
		2608	`if (name(sh(p)) == bothd)`
		2609	`{ kill_exp(a,a); return p; }`
		2610
		2611	`#if check_shape`
		2612	`if (name(sh(a)) != offsethd \|\| name(sh(p)) != ptrhd)`
		2613	`failer(CHSH_LOCFREE);`
		2614	`#endif`
		2615	`if (al2(sh(a)) <8 ) {`
		2616	`a = hold_check(f_offset_pad(f_alignment(ucharsh), a) );`
		2617	`}`
		2618
		2619	`return me_b3(f_top, p, a, local_free_tag);`
		2620	`}`
		2621
		2622	`exp f_local_free_all`
		2623	`PROTO_Z ()`
		2624	`{`
		2625	`has_setjmp = 1; /* this really means dont inline`
		2626	`and use a stack frame */`
		2627	`return getexp(f_top, nilexp, 0, nilexp, nilexp,`
		2628	`0, 0, local_free_all_tag);`
		2629	`}`
		2630
		2631
		2632	`exp f_long_jump`
		2633	`PROTO_N ( (arg1, arg2) )`
		2634	`PROTO_T ( exp arg1 X exp arg2 )`
		2635	`{`
		2636	`if (name(sh(arg1)) == bothd)`
		2637	`{ kill_exp(arg2,arg2); return arg1; }`
		2638	`if (name(sh(arg2)) == bothd)`
		2639	`{ kill_exp(arg1,arg1); return arg2; }`
		2640
		2641	`#if check_shape`
		2642	`if (name(sh(arg1)) != ptrhd \|\| name(sh(arg2)) != ptrhd)`
		2643	`failer(CHSH_LONGJUMP);`
		2644	`#endif`
		2645
		2646	`has_setjmp = 1; /* this really means dont inline`
		2647	`and use a stack frame */`
		2648	`return me_b3(f_bottom, arg1, arg2, long_jump_tag);`
		2649	`}`
		2650
		2651	`static int comp_compare`
		2652	`PROTO_N ( (a, b) )`
		2653	`PROTO_T ( CONST void * a X CONST void * b )`
		2654	`{`
		2655	`return no(((exp)a)) - no(((exp)b));`
		2656	`}`
		2657
		2658
		2659	`exp f_make_compound`
		2660	`PROTO_N ( (arg1, arg2) )`
		2661	`PROTO_T ( exp arg1 X exp_list arg2 )`
		2662	`{`
		2663	`exp first = arg2.start;`
		2664	`exp r = getexp (f_compound(arg1), nilexp, 0, first,`
		2665	`nilexp, 0, 0, compound_tag);`
		2666	`clear_exp_list(arg2);`
		2667
		2668	`if (arg2.number == 0)`
		2669	`{`
		2670	`setname (r, clear_tag);`
		2671	`return r;`
		2672	`}`
		2673
		2674	`#if check_shape`
		2675	`{`
		2676	`exp t = first;`
		2677	`while (1)`
		2678	`{`
		2679	`if (t != arg2.end && name(sh(bro(t))) == bothd)`
		2680	`return bro(t);`
		2681	`if (t == arg2.end \|\|`
		2682	`name(sh(t)) != offsethd \|\|`
		2683	`(!doing_aldefs && al2(sh(t)) < shape_align(sh(bro(t)))))`
		2684	`failer(CHSH_MAKECPD);`
		2685	`if (bro(t) == arg2.end)`
		2686	`break;`
		2687	`t = bro(bro(t));`
		2688	`};`
		2689	`};`
		2690	`#endif`
		2691
		2692	`setfather (r, arg2.end);`
		2693
		2694	`if (!doing_aldefs && arg2.number > 2) {`
		2695	`exp * arr = (exp*)xcalloc(arg2.number, sizeof(exp));`
		2696	`int i;`
		2697	`exp t = son(r);`
		2698
		2699
		2700	`for (i = 0; i < arg2.number; ++i) {`
		2701	`if (!(i & 1) && (no(t) + shape_size(sh(bro(t))) > shape_size(sh(r)) ))`
		2702	`failer ("make_compound size exceeded");`
		2703	`arr[i] = t;`
		2704	`t = bro(t);`
		2705	`};`
		2706
		2707	`#ifdef promote_pars`
		2708	`for (i = 0; i < arg2.number; i+=2) {`
		2709	`alignment a = al2_of(sh(arr[i]));`
		2710	`if (a->al.sh_hd !=0) {`
		2711	`shape s = sh(arr[i+1]);`
		2712	`if (name(s)>=scharhd && name(s)<=uwordhd) {`
		2713	`shape ns = (is_signed(s))? slongsh:ulongsh;`
		2714	`exp w = hold_check(f_change_variety(f_wrap,ns, arr[i+1]));`
		2715	`arr[i+1] = w;`
		2716	`}`
		2717	`}`
		2718	`}`
		2719
		2720	`#endif`
		2721
		2722	`qsort(arr, (size_t)(arg2.number/2), (size_t)(2*sizeof(exp)),`
		2723	`comp_compare);`
		2724
		2725	`son(r) = arr[0];`
		2726	`for (i = 1; i < arg2.number; ++i) {`
		2727	`bro(arr[i-1]) = arr[i];`
		2728	`clearlast(arr[i-1]);`
		2729	`};`
		2730	`bro(arr[arg2.number-1]) = r;`
		2731	`setlast(arr[arg2.number-1]);`
		2732
		2733	`xfree((void*)arr);`
		2734	`};`
		2735
		2736	`return r;`
		2737	`}`
		2738
		2739
		2740
		2741	`exp f_make_int`
		2742	`PROTO_N ( (v, value) )`
		2743	`PROTO_T ( variety v X signed_nat value )`
		2744	`{`
		2745	`int n;`
		2746
		2747	`if (!snat_issmall(value) \|\|`
		2748	`(n = snatint(value), shape_size(v) > 32 &&`
		2749	`(n & (int)0x80000000) != 0))`
		2750	`{`
		2751	`flpt b;`
		2752	`exp res;`
		2753
		2754	`if (shape_size(v) <= 32) {`
		2755	`if (!extra_checks) {`
		2756	`flt64 temp;`
		2757	`int ov;`
		2758	`temp = flt_to_f64(value.signed_nat_val.big_s_nat, 0, &ov);`
		2759	`n = temp.small;`
		2760	`res = getexp(f_integer(v), nilexp, 0, nilexp, nilexp, 0,`
		2761	`n, val_tag);`
		2762	`return res;`
		2763	`}`
		2764	`else {`
		2765	`failer(BIG_32);`
		2766	`exit(EXIT_FAILURE);`
		2767	`}`
		2768	`};`
		2769	`if (snat_issmall(value)) {`
		2770	`flt64 temp;`
		2771	`temp.big = 0;`
		2772	`temp.small = (unsigned int)n;`
		2773	`b = f64_to_flt(temp, 0);`
		2774	`}`
		2775	`else { /* copy required since exp may be killed & value may be token res */`
		2776	`b = new_flpt();`
		2777	`flt_copy (flptnos[value.signed_nat_val.big_s_nat], &flptnos[b]);`
		2778	`};`
		2779	`if (snatneg(value))`
		2780	`flptnos[b].sign = -1;`
		2781
		2782	`if (flptnos[b].exp > 3) {`
		2783	`failer(BIG_32);`
		2784	`exit(EXIT_FAILURE);`
		2785	`};`
		2786	`res = getexp(f_integer(v), nilexp, 0, nilexp, nilexp, 0,`
		2787	`b, val_tag);`
		2788	`setbigval(res);`
		2789	`return res;`
		2790	`}`
		2791	`else {`
		2792	`if (snatneg(value))`
		2793	`n = -n;`
		2794
		2795	`return getexp(f_integer(v), nilexp, 0, nilexp, nilexp, 0,`
		2796	`n, val_tag);`
		2797	`};`
		2798	`}`
		2799
		2800	`exp f_make_local_lv`
		2801	`PROTO_N ( (lab) )`
		2802	`PROTO_T ( label lab )`
		2803	`{`
		2804	`exp l = get_lab(lab);`
		2805	`exp res = getexp(f_local_label_value, nilexp, 0, nilexp, l,`
		2806	`0, 0, make_lv_tag);`
		2807	`++no(son(l));`
		2808	`set_loaded_lv(l);`
		2809	`has_lv = 1;`
		2810	`return res;`
		2811	`}`
		2812
		2813	`exp f_make_nof`
		2814	`PROTO_N ( (arg1) )`
		2815	`PROTO_T ( exp_list arg1 )`
		2816	`{`
		2817	`exp first = arg1.start;`
		2818	`nat t;`
		2819	`exp r;`
		2820	`clear_exp_list(arg1);`
		2821	`nat_issmall(t) = 1;`
		2822	`natint(t) = arg1.number;`
		2823	`if (arg1.number == 0) {`
		2824	`return getexp(f_nof(t, f_top), nilexp, 0, nilexp, nilexp,`
		2825	`0, 0, nof_tag);`
		2826	`};`
		2827	`r = getexp (f_nof(t, sh(first)), nilexp, 0, first,`
		2828	`nilexp, 0, 0, nof_tag);`
		2829
		2830	`#if check_shape`
		2831	`{exp temp = first;`
		2832	`while (1)`
		2833	`{`
		2834	`if (!eq_shape(sh(temp), sh(first)))`
		2835	`failer(CHSH_MAKENOF);`
		2836	`if (temp == arg1.end)`
		2837	`break;`
		2838	`temp = bro(temp);`
		2839	`};`
		2840	`};`
		2841	`#endif`
		2842
		2843	`if (name(sh(first))==bitfhd) {`
		2844	`/* make make_nof bitbields into make-compound */`
		2845	`int sf = shape_size(sh(first));`
		2846	`int snof = shape_size(sh(r));`
		2847	`exp *a = &arg1.start;`
		2848	`int scs = (((sf-1)&sf)==0)?sf:snof;`
		2849	`shape cs = containedshape(scs, 1);`
		2850	`int i;`
		2851	`shape cpds = f_compound(hold_check(f_offset_pad(f_alignment(cs),`
		2852	`f_shape_offset(sh(r)))));`
		2853	`exp soff = getexp(f_offset(f_alignment(cpds), f_alignment(sh(first))),`
		2854	`nilexp, 0, nilexp, nilexp, 0, 0, val_tag);`
		2855	`for(i=0; i< arg1.number; i++) {`
		2856	`bro(soff) = *a;`
		2857	`*a = copyexp(soff);`
		2858	`a = &bro(bro(*a));`
		2859	`no(soff)+= sf;`
		2860	`}`
		2861	`arg1.number *= 2;`
		2862	`return f_make_compound(hold_check(f_shape_offset(cpds)), arg1);`
		2863	`}`
		2864
		2865
		2866	`setfather (r, arg1.end);`
		2867	`return r;`
		2868	`}`
		2869
		2870	`exp f_make_nof_int`
		2871	`PROTO_N ( (v, s) )`
		2872	`PROTO_T ( variety v X string s )`
		2873	`{`
		2874	`shape sha;`
		2875	`exp res;`
		2876	`nat t;`
		2877	`int i;`
		2878	`shape elem_sh = f_integer(v);`
		2879	`int elem_sz = shape_size(elem_sh);`
		2880
		2881	`if (PIC_code)`
		2882	`proc_externs = 1;`
		2883
		2884	`nat_issmall(t) = 1;`
		2885	`natint(t) = s.number;`
		2886	`sha = f_nof(t, elem_sh);`
		2887	`res = getexp(sha, nilexp, 0, nilexp, nilexp, (prop)elem_sz,`
		2888	`0, string_tag);`
		2889
		2890
		2891	`if (elem_sz == 64) {`
		2892	`int * ss = (int*)xcalloc(s.number, sizeof(int));`
		2893	`for (i = 0; i < s.number; ++i) {`
		2894	`flt64 x;`
		2895	`flpt f;`
		2896	`int ov;`
		2897	`int sg = is_signed(elem_sh);`
		2898	`x.big = 0;`
		2899	`switch (s.size) {`
		2900	`case 8:`
		2901	`x.small = (unsigned int)s.ints.chars[i];`
		2902	`break;`
		2903	`case 16:`
		2904	`x.small = (unsigned int)s.ints.shorts[i];`
		2905	`break;`
		2906	`case 32:`
		2907	`x.small = (unsigned int)s.ints.longs[i];`
		2908	`break;`
		2909	`default: {`
		2910	`f = (flpt)s.ints.longs[i];`
		2911	`x = flt_to_f64(f, 0, &ov);`
		2912	`flpt_ret(f);`
		2913	`if (s.size < 64 && sg)`
		2914	`x.big = (x.big << (64-s.size)) >> (64-s.size);`
		2915	`};`
		2916	`};`
		2917	`ss[i] = f64_to_flt(x, sg);`
		2918	`};`
		2919	`nostr(res) = (char) (void)ss;`
		2920	`return res;`
		2921	`};`
		2922
		2923	`switch (s.size)`
		2924	`{`
		2925	`case 8:`
		2926	`{`
		2927	`switch (elem_sz)`
		2928	`{`
		2929	`case 8: nostr(res) = (char*)s.ints.chars;`
		2930	`return res;`
		2931	`case 16:{short * ss =`
		2932	`(short*)xcalloc(s.number, sizeof(short));`
		2933	`for (i = 0; i < s.number; ++i)`
		2934	`ss[i] = (short)(unsigned char)s.ints.chars[i];`
		2935	`nostr(res) = (char) (void)ss;`
		2936	`return res;`
		2937	`};`
		2938	`case 32:{int * ss =`
		2939	`(int*)xcalloc(s.number, sizeof(int));`
		2940	`for (i = 0; i < s.number; ++i)`
		2941	`ss[i] = (int)(unsigned char)s.ints.chars[i];`
		2942	`nostr(res) = (char) (void)ss;`
		2943	`return res;`
		2944	`};`
		2945	`};`
		2946	`};`
		2947	`case 16:`
		2948	`{`
		2949	`switch (elem_sz)`
		2950	`{`
		2951	`case 8:{char * ss =`
		2952	`(char*)xcalloc(s.number, sizeof(char));`
		2953	`for (i = 0; i < s.number; ++i)`
		2954	`ss[i] = (char)(unsigned short)s.ints.shorts[i];`
		2955	`nostr(res) = (char) (void)ss;`
		2956	`return res;`
		2957	`};`
		2958	`case 16: nostr(res) = (char) (void)s.ints.shorts;`
		2959	`return res;`
		2960	`case 32:{int * ss =`
		2961	`(int*)xcalloc(s.number, sizeof(int));`
		2962	`for (i = 0; i < s.number; ++i)`
		2963	`ss[i] = (int)(unsigned short)s.ints.shorts[i];`
		2964	`nostr(res) = (char) (void)ss;`
		2965	`return res;`
		2966	`};`
		2967	`};`
		2968	`};`
		2969	`case 32:`
		2970	`{`
		2971	`switch (elem_sz)`
		2972	`{`
		2973	`case 8:{char * ss =`
		2974	`(char*)xcalloc(s.number, sizeof(char));`
		2975	`for (i = 0; i < s.number; ++i)`
		2976	`ss[i] = (char)(unsigned long)s.ints.longs[i];`
		2977	`nostr(res) = (char) (void)ss;`
		2978	`return res;`
		2979	`};`
		2980	`case 16:{short * ss =`
		2981	`(short*)xcalloc(s.number, sizeof(short));`
		2982	`for (i = 0; i < s.number; ++i)`
		2983	`ss[i] = (short)(unsigned long)s.ints.longs[i];`
		2984	`nostr(res) = (char) (void)ss;`
		2985	`return res;`
		2986	`};`
		2987	`case 32: nostr(res) = (char)(void)s.ints.longs;`
		2988	`return res;`
		2989	`};`
		2990	`};`
		2991	`};`
		2992	`return res;`
		2993	`}`
		2994
		2995	`exp f_make_null_local_lv`
		2996	`PROTO_Z ()`
		2997	`{`
		2998	`return me_null(f_local_label_value, lv_null, null_tag);`
		2999	`}`
		3000
		3001	`exp f_make_null_proc`
		3002	`PROTO_Z ()`
		3003	`{`
		3004	`return me_null(f_proc, proc_null, null_tag);`
		3005	`}`
		3006
		3007	`exp f_make_null_ptr`
		3008	`PROTO_N ( (a) )`
		3009	`PROTO_T ( alignment a )`
		3010	`{`
		3011	`return me_null(f_pointer(a), ptr_null, null_tag);`
		3012	`}`
		3013
		3014	`exp f_maximum`
		3015	`PROTO_N ( (arg1, arg2) )`
		3016	`PROTO_T ( exp arg1 X exp arg2 )`
		3017	`{`
		3018	`if (name(sh(arg1)) == bothd)`
		3019	`{ kill_exp(arg2,arg2); return arg1; }`
		3020	`if (name(sh(arg2)) == bothd)`
		3021	`{ kill_exp(arg1,arg1); return arg2; }`
		3022
		3023	`#if check_shape`
		3024	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		3025	`failer(CHSH_MAX);`
		3026	`#endif`
		3027	`#if !has64bits`
		3028	`if (name(sh(arg1)) >= s64hd &&`
		3029	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)) {`
		3030	`return TDFcallop3(arg1,arg2,max_tag);`
		3031	`}`
		3032	`#endif`
		3033	`return me_b2(arg1, arg2, max_tag);`
		3034	`}`
		3035
		3036	`exp f_minimum`
		3037	`PROTO_N ( (arg1, arg2) )`
		3038	`PROTO_T ( exp arg1 X exp arg2 )`
		3039	`{`
		3040	`if (name(sh(arg1)) == bothd)`
		3041	`{ kill_exp(arg2,arg2); return arg1; }`
		3042	`if (name(sh(arg2)) == bothd)`
		3043	`{ kill_exp(arg1,arg1); return arg2; }`
		3044	`#if check_shape`
		3045	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		3046	`failer(CHSH_MIN);`
		3047	`#endif`
		3048	`#if !has64bits`
		3049	`if (name(sh(arg1)) >= s64hd &&`
		3050	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)) {`
		3051	`error_treatment ov_err;`
		3052	`ov_err = f_wrap;`
		3053	`return TDFcallop2(ov_err,arg1,arg2,min_tag);`
		3054	`}`
		3055	`#endif`
		3056
		3057	`return me_b2(arg1, arg2, min_tag);`
		3058	`}`
		3059
		3060	`static int in_initial_value;`
		3061
		3062	`static void push_proc_props`
		3063	`PROTO_Z ()`
		3064	`{`
		3065	`proc_props * temp = (proc_props*)xcalloc(1, sizeof(proc_props));`
		3066	`temp->proc_struct_result = proc_struct_result;`
		3067	`temp->has_alloca = has_alloca;`
		3068	`temp->proc_is_recursive = proc_is_recursive;`
		3069	`temp->uses_crt_env = uses_crt_env;`
		3070	`temp->has_setjmp = has_setjmp;`
		3071	`temp->uses_loc_address = uses_loc_address;`
		3072	`temp->proc_label_count = proc_label_count;`
		3073	`temp->proc_struct_res = proc_struct_res;`
		3074	`temp->default_freq = default_freq;`
		3075	`temp->proc_externs = proc_externs;`
		3076	`temp->in_proc_def = in_proc_def;`
		3077	`temp->pushed = old_proc_props;`
		3078	`temp->rep_make_proc = rep_make_proc;`
		3079	`temp->frame_alignment = frame_alignment;`
		3080	`temp->in_initial_value = in_initial_value;`
		3081	`old_proc_props = temp;`
		3082	`return;`
		3083	`}`
		3084
		3085	`static void pop_proc_props`
		3086	`PROTO_Z ()`
		3087	`{`
		3088	`proc_props * temp = old_proc_props;`
		3089	`proc_struct_result = temp->proc_struct_result;`
		3090	`has_alloca = temp->has_alloca;`
		3091	`proc_is_recursive =temp-> proc_is_recursive;`
		3092	`uses_crt_env = temp->uses_crt_env;`
		3093	`has_setjmp = temp->has_setjmp;`
		3094	`uses_loc_address = temp->uses_loc_address;`
		3095	`proc_label_count = temp->proc_label_count;`
		3096	`proc_struct_res = temp->proc_struct_res;`
		3097	`default_freq = temp->default_freq;`
		3098	`proc_externs = temp->proc_externs;`
		3099	`in_proc_def = temp->in_proc_def;`
		3100	`old_proc_props = temp->pushed;`
		3101	`rep_make_proc = temp->rep_make_proc;`
		3102	`frame_alignment = temp->frame_alignment;`
		3103	`in_initial_value = temp->in_initial_value;`
		3104	`if (temp != &initial_value_pp) xfree((void*)temp);`
		3105	`return;`
		3106	`}`
		3107
		3108	`void start_make_proc`
		3109	`PROTO_N ( (result_shape, params_intro, vartag) )`
		3110	`PROTO_T ( shape result_shape X tagshacc_list params_intro X tagacc_option vartag )`
		3111	`{`
		3112	`/* initialise global flags which are used at the end of the`
		3113	`reading process in f_make_proc */`
		3114	`UNUSED(result_shape); UNUSED(params_intro);`
		3115	`push_proc_props();`
		3116
		3117	`proc_struct_result = nilexp;`
		3118	`has_alloca = 0;`
		3119	`proc_is_recursive = 0;`
		3120	`uses_crt_env = 0;`
		3121	`has_setjmp = 0;`
		3122	`uses_loc_address = 0;`
		3123	`proc_label_count = 0;`
		3124	`proc_struct_res = 0;`
		3125	`default_freq = 1.0;`
		3126	`proc_externs = 0;`
		3127	`in_initial_value = 0;`
		3128	`frame_alignment = f_unite_alignments(f_locals_alignment, var_callers_alignment);`
		3129
		3130	`if (vartag.present) {`
		3131	`shape sha = getshape(0, const_al1, const_al1,`
		3132	`VAR_PARAM_ALIGN, 0, cpdhd);`
		3133	`exp d = getexp(sha, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);`
		3134	`exp i = getexp(f_bottom, nilexp, 1, d, nilexp, 0, 0, ident_tag);`
		3135	`setvis(i);`
		3136	`setvar(i);`
		3137	`setparam(i);`
		3138	`set_tag(vartag.val.tg, i);`
		3139	`};`
		3140
		3141	`/* set this flag to distinguish values created during procedure`
		3142	`reading.`
		3143	`*/`
		3144	`in_proc_def = 1;`
		3145
		3146	`return;`
		3147	`}`
		3148
		3149	`exp f_make_proc`
		3150	`PROTO_N ( (result_shape, params_intro, vartag, body) )`
		3151	`PROTO_T ( shape result_shape X tagshacc_list params_intro X tagacc_option vartag X exp body )`
		3152	`{`
		3153	`exp res;`
		3154	`int varhack = 0;`
		3155	`#if ishppa`
		3156	`exp t,id,ptr;`
		3157	`#endif`
		3158
		3159	`#if check_shape`
		3160	`if (name(sh(body)) != bothd)`
		3161	`failer(CHSH_MAKE_PROC);`
		3162	`#endif`
		3163
		3164	`if (vartag.present) {`
		3165	`exp i = get_tag(vartag.val.tg);`
		3166	`if (params_intro.id == nilexp)`
		3167	`params_intro.id = i;`
		3168	`else`
		3169	`bro(params_intro.last_def) = i;`
		3170	`bro(i) = params_intro.last_id;`
		3171	`params_intro.last_def = son(i);`
		3172	`params_intro.last_id = i;`
		3173	`setvis(i);`
		3174	`++params_intro.number;`
		3175	`varhack = 1;`
		3176	`};`
		3177
		3178	`res = getexp(f_proc, nilexp, 0, params_intro.id, result_shape,`
		3179	`0, 0, proc_tag);`
		3180
		3181	`if (params_intro.number == 0)`
		3182	`{`
		3183	`son(res) = body;`
		3184	`setlast(body);`
		3185	`bro(body) = res;`
		3186	`}`
		3187	`else`
		3188	`{`
		3189	`bro(son(res)) = res;`
		3190	`bro(params_intro.last_def) = body;`
		3191	`setlast(body);`
		3192	`bro(body) = params_intro.last_id;`
		3193	`#ifdef promote_pars`
		3194	`promote_formals(son(res));`
		3195	`#endif`
		3196	`};`
		3197
		3198	`/* set the properties of the procedure construction from the`
		3199	`global values accumulated during reading.`
		3200	`WE OUGHT TO POP THE OLD VALUES.`
		3201	`*/`
		3202	`if (has_alloca)`
		3203	`set_proc_has_alloca(res);`
		3204	`if (proc_is_recursive)`
		3205	`setrecursive(res);`
		3206	`if (has_lv)`
		3207	`set_proc_has_lv(res);`
		3208	`if (uses_crt_env)`
		3209	`set_proc_uses_crt_env(res);`
		3210	`if (has_setjmp)`
		3211	`set_proc_has_setjmp(res);`
		3212	`if (uses_loc_address)`
		3213	`set_loc_address(res);`
		3214	`if (proc_struct_res)`
		3215	`set_struct_res(res);`
		3216	`if (proc_externs)`
		3217	`set_proc_uses_external(res);`
		3218
		3219	`/* apply check_id to the parameters */`
		3220
		3221	`if (params_intro.number !=0)`
		3222	`{`
		3223	`exp param;`
		3224	`for (param = params_intro.last_id; param != res; param = bro(param))`
		3225	`{`
		3226	`if (redo_structparams &&`
		3227	`#if ishppa`
		3228	`(varhack \|\| ((shape_size(sh(son(param)))>64) &&`
		3229	`(name(sh(son(param))) == cpdhd \|\|name(sh(son(param))) == nofhd \|\|`
		3230	`name(sh(son(param))) == doublehd))))`
		3231	`#else`
		3232	`#if issparc`
		3233	`(varhack \|\| sparccpd(sh(son(param))) ))`
		3234
		3235	`#else`
		3236	`(varhack \|\| name(sh(son(param))) == cpdhd\|\|name(sh(son(param))) == nofhd \|\|`
		3237	`name(sh(son(param))) == doublehd))`
		3238	`#endif`
		3239	`#endif`
		3240
		3241	`{`
		3242	`/*`
		3243	`* Param IS struct/union-by-value. Incoming acutal parameter`
		3244	`* will have been changed to be ptr-to expected value (see`
		3245	`* f_apply_proc()), so adjust usage in body.`
		3246	`*/`
		3247	`exp use; /* use of ident in pt() chain */`
		3248	`exp prev; /* previous use in pt() chain */`
		3249	`exp eo = nilexp;`
		3250	`shape ptr_s = f_pointer(f_alignment(sh(son(param))));`
		3251
		3252	`#if ishppa`
		3253	`/* modify parameter itself */`
		3254	`if (!varhack)`
		3255	`{`
		3256	`exp obtain_param;`
		3257	`exp assign;`
		3258	`shape sha=sh(son(param));`
		3259	`t=me_obtain(param);`
		3260	`if (uses_crt_env)`
		3261	`{`
		3262	`eo = f_env_offset(frame_alignment,f_parameter_alignment(ptr_s),brog(param));`
		3263	`obtain_param = f_add_to_ptr(f_current_env(), eo);`
		3264	`}`
		3265	`id=me_startid(f_top,me_u3(sha,t,cont_tag),1);`
		3266	`ptr=me_startid(f_top,me_obtain(id),0);`
		3267	`if (uses_crt_env)`
		3268	`{`
		3269	`assign = f_assign(obtain_param, me_obtain(id));`
		3270	`body = f_sequence(add_exp_list(new_exp_list(1),assign, 0), body);`
		3271	`}`
		3272	`clearlast(son(ptr));`
		3273	`bro(son(ptr))=body;`
		3274	`setlast(body);`
		3275	`bro(body)=ptr;`
		3276	`sh(ptr)=sh(body);`
		3277	`body=id;`
		3278	`clearlast(son(id));`
		3279	`bro(son(id)) = ptr;`
		3280	`setlast(ptr);`
		3281	`bro(ptr) = id;`
		3282	`sh(id) = sh(ptr);`
		3283	`bro(params_intro.last_def) = body;`
		3284	`setlast(body);`
		3285	`bro(body) = param;`
		3286	`}`
		3287	`#endif`
		3288
		3289	`/* visit each use of the parameter modifying appropriately*/`
		3290	`for (prev = param, use = pt(prev);`
		3291	`use != nilexp;`
		3292	`prev = use, use = pt(prev))`
		3293	`if (!uses_crt_env \|\| (uses_crt_env && use != eo))`
		3294	`{`
		3295	`if (!isvar(param)) /* add cont */`
		3296	`{`
		3297	`exp new_use =`
		3298	`getexp(ptr_s,`
		3299	`use, (bool)1, son(use), pt(use), props(use), 0, name_tag);`
		3300	`son(use) = new_use;`
		3301	`pt(prev) = new_use;`
		3302	`pt(use) = nilexp;`
		3303	`props(use) = (prop)0;`
		3304	`setname(use, cont_tag); /* retain same no and sh */`
		3305
		3306	`use = new_use;`
		3307	`}`
		3308
		3309	`if (no(use) > 0) /* add reff */`
		3310	`{`
		3311	`exp new_use =`
		3312	`getexp(ptr_s,`
		3313	`use, (bool)1, son(use), pt(use), props(use), 0, name_tag);`
		3314	`son(use) = new_use;`
		3315	`pt(prev) = new_use;`
		3316	`pt(use) = nilexp;`
		3317	`props(use) = (prop)0;`
		3318	`setname(use, reff_tag); /* retain same no and sh */`
		3319
		3320	`use = new_use;`
		3321	`}`
		3322	`} /* for */`
		3323
		3324	`#if ishppa`
		3325	`if (!varhack)`
		3326	`{`
		3327	`/* Change all but ptr's references to param to references to ptr */`
		3328	`for (use = pt(param); use != nilexp; use = pt(use))`
		3329	`{`
		3330	`if ((son(use)==param) && (use!=son(son(id)))`
		3331	`&& (!uses_crt_env \|\| (uses_crt_env && use != eo )))`
		3332	`son(use)=ptr;`
		3333	`}`
		3334	`pt(ptr)=pt(param);`
		3335	`}`
		3336	`#endif`
		3337
		3338	`/* modify parameter itself */`
		3339	`if (isenvoff(param)) {`
		3340	`props(param) = (prop)0;`
		3341	`setvis(param);`
		3342	`}`
		3343	`else { props(param) = (prop)0; }`
		3344	`setparam(param);`
		3345	`setcaonly(param);`
		3346	`if (varhack) { setvis(param); }`
		3347	`setsh(son(param), ptr_s);`
		3348	`} /* if redo... */`
		3349	`varhack = 0;`
		3350	`IGNORE check_id(param, param); /* apply check_id to the parameters */`
		3351	`} /* for */`
		3352	`}`
		3353
		3354	`if (proc_struct_result != nilexp)`
		3355	`{`
		3356	`bro(son(proc_struct_result)) = son(res);`
		3357	`setfather(proc_struct_result, son(res));`
		3358	`son(res) = proc_struct_result;`
		3359	`setfather(res, proc_struct_result);`
		3360	`};`
		3361
		3362	`/* clear this flag to distinguish values created during procedure`
		3363	`reading.`
		3364	`*/`
		3365	`in_proc_def = 0;`
		3366
		3367	`pop_proc_props();`
		3368
		3369	`if (old_proc_props != (proc_props *)0 \|\| rep_make_proc) {`
		3370	`dec * extra_dec = make_extra_dec(make_local_name(), 0, 0, res, f_proc);`
		3371	`exp e = extra_dec -> dec_u.dec_val.dec_exp;`
		3372	`res = getexp (f_proc, nilexp, 0, e, nilexp, 0, 0, name_tag);`
		3373	`pt(e) = res;`
		3374	`no(e) = 1;`
		3375	`};`
		3376
		3377
		3378	`return res;`
		3379	`}`
		3380
		3381	`procprops crt_procprops;`
		3382
		3383	`void`
		3384	`start_make_general_proc`
		3385	`PROTO_N ( (result_shape,prcprops,caller_intro,callee_intro) )`
		3386	`PROTO_T ( shape result_shape X procprops prcprops X tagshacc_list caller_intro X tagshacc_list callee_intro )`
		3387	`{`
		3388	`/* initialise global flags which are used at the end of the`
		3389	`reading process in f_make_proc */`
		3390
		3391	`push_proc_props();`
		3392
		3393	`proc_struct_result = nilexp;`
		3394	`has_alloca = 0;`
		3395	`proc_is_recursive = 0;`
		3396	`uses_crt_env = 0;`
		3397	`has_setjmp = 0;`
		3398	`uses_loc_address = 0;`
		3399	`proc_label_count = 0;`
		3400	`proc_struct_res = 0;`
		3401	`default_freq = 1.0;`
		3402	`frame_alignment = f_unite_alignments(f_locals_alignment,`
		3403	`f_callers_alignment((prcprops & f_var_callers) !=0) );`
		3404	`frame_alignment = f_unite_alignments(frame_alignment,`
		3405	`f_callees_alignment((prcprops & f_var_callees) !=0) );`
		3406
		3407	`proc_externs = 0;`
		3408	`/* set this flag to distinguish values created during procedure`
		3409	`reading.`
		3410	`*/`
		3411	`in_proc_def = 1;`
		3412	`crt_procprops = prcprops;`
		3413	`return;`
		3414	`}`
		3415
		3416	`exp f_make_general_proc`
		3417	`PROTO_N ( (result_shape,prcprops,caller_intro,callee_intro,body) )`
		3418	`PROTO_T ( shape result_shape X procprops prcprops X`
		3419	`tagshacc_list caller_intro X tagshacc_list callee_intro X`
		3420	`exp body )`
		3421	`{`
		3422	`exp res;`
		3423	`#if check_shape`
		3424	`if (name(sh(body)) != bothd)`
		3425	`failer(CHSH_MAKE_PROC);`
		3426	`#endif`
		3427	`res = getexp(f_proc, nilexp, 0, caller_intro.id, result_shape,`
		3428	`0, 0, general_proc_tag);`
		3429
		3430	`if (caller_intro.number == 0 && callee_intro.number == 0) {`
		3431	`son(res) = body;`
		3432	`setlast(body);`
		3433	`bro(body) = res;`
		3434	`}`
		3435	`else`
		3436	`if (callee_intro.number == 0) {`
		3437	`bro(son(res)) = res;`
		3438	`bro(caller_intro.last_def) = body;`
		3439	`setlast(body);`
		3440	`bro(body) = caller_intro.last_id;`
		3441	`}`
		3442	`else {`
		3443	`int i;`
		3444	`exp z = callee_intro.id;`
		3445	`for(i=0; i<callee_intro.number; i++) {`
		3446	`set_callee(z);`
		3447	`z = bro(son(z));`
		3448	`}`
		3449	`if (caller_intro.number !=0) {`
		3450	`bro(caller_intro.last_def) = callee_intro.id;`
		3451	`bro(callee_intro.id) = caller_intro.last_id; /???/`
		3452	`}`
		3453	`else {`
		3454	`son(res) = callee_intro.id;`
		3455	`}`
		3456	`bro(son(res)) = res;`
		3457	`bro(callee_intro.last_def) = body;`
		3458	`setlast(body);`
		3459	`bro(body) = callee_intro.last_id;`
		3460	`}`
		3461
		3462	`#ifdef promote_pars`
		3463	`promote_formals(son(res));`
		3464	`#endif`
		3465	`/* set the properties of the procedure construction from the`
		3466	`global values accumulated during reading.`
		3467	`WE OUGHT TO POP THE OLD VALUES.`
		3468	`*/`
		3469	`if (has_alloca)`
		3470	`set_proc_has_alloca(res);`
		3471	`if (proc_is_recursive)`
		3472	`setrecursive(res);`
		3473	`if (has_lv)`
		3474	`set_proc_has_lv(res);`
		3475	`if (uses_crt_env)`
		3476	`set_proc_uses_crt_env(res);`
		3477	`if (has_setjmp)`
		3478	`set_proc_has_setjmp(res);`
		3479	`if (uses_loc_address)`
		3480	`set_loc_address(res);`
		3481	`if (proc_struct_res)`
		3482	`set_struct_res(res);`
		3483	`if (proc_externs)`
		3484	`set_proc_uses_external(res);`
		3485
		3486	`if (caller_intro.number !=0)`
		3487	`{ bool varhack = 0;`
		3488	`exp param;`
		3489	`for (param = caller_intro.last_id; param != res; param = bro(param))`
		3490	`{`
		3491	`if (redo_structparams && !varhack &&`
		3492	`#if ishppa`
		3493	`shape_size(sh(son(param))) > 64)`
		3494	`#else`
		3495	`(name(sh(son(param))) == cpdhd \|\|name(sh(son(param))) == nofhd \|\|`
		3496	`#if issparc`
		3497	`sparccpd(sh(son(param))) \|\|`
		3498	`#endif`
		3499
		3500	`name(sh(son(param))) == doublehd))`
		3501	`#endif`
		3502	`{`
		3503	`/*`
		3504	`* Param IS struct/union-by-value. Incoming acutal parameter`
		3505	`* will have been changed to be ptr-to expected value (see`
		3506	`* f_apply_proc()), so adjust usage in body.`
		3507	`*/`
		3508	`exp use; /* use of ident in pt() chain */`
		3509	`exp prev; /* previous use in pt() chain */`
		3510
		3511	`shape ptr_s = f_pointer(f_alignment(sh(son(param))));`
		3512	`int mustbevis;`
		3513
		3514	`/* visit each use of the parameter modifying appropriately*/`
		3515	`for (prev = param, use = pt(prev);`
		3516	`use != nilexp;`
		3517	`prev = use, use = pt(prev))`
		3518	`{`
		3519	`if (!isvar(param)) /* add cont */`
		3520	`{`
		3521	`exp new_use =`
		3522	`getexp(ptr_s,`
		3523	`use, (bool)1, son(use), pt(use), props(use), 0, name_tag);`
		3524	`son(use) = new_use;`
		3525	`pt(prev) = new_use;`
		3526	`pt(use) = nilexp;`
		3527	`props(use) = (prop)0;`
		3528	`setname(use, cont_tag); /* retain same no and sh */`
		3529
		3530	`use = new_use;`
		3531	`}`
		3532
		3533	`if (no(use) > 0) /* add reff */`
		3534	`{`
		3535	`exp new_use =`
		3536	`getexp(ptr_s,`
		3537	`use, (bool)1, son(use), pt(use), props(use), 0, name_tag);`
		3538	`son(use) = new_use;`
		3539	`pt(prev) = new_use;`
		3540	`pt(use) = nilexp;`
		3541	`props(use) = (prop)0;`
		3542	`setname(use, reff_tag); /* retain same no and sh */`
		3543
		3544	`use = new_use;`
		3545	`}`
		3546	`} /* for */`
		3547
		3548	`/* modify parameter itself */`
		3549	`mustbevis = isenvoff(param);`
		3550	`if (isoutpar(param)) {`
		3551	`props(param) = (prop)0;`
		3552	`setoutpar(param);`
		3553	`}`
		3554	`else props(param) = (prop)0;`
		3555	`if (mustbevis) { setvis(param); }`
		3556	`setparam(param);`
		3557	`setcaonly(param);`
		3558	`setsh(son(param), ptr_s);`
		3559	`} /* if redo... */`
		3560	`varhack = 0;`
		3561	`IGNORE check_id(param, param); /* apply check_id to the caller parameters */`
		3562	`} /* for */`
		3563	`}`
		3564
		3565	`if (callee_intro.number !=0)`
		3566	`{`
		3567	`exp param= callee_intro.last_id;`
		3568	`int i;`
		3569
		3570	`for (i=callee_intro.number; i!=0; param = father(param), i--)`
		3571	`{`
		3572
		3573	`IGNORE check_id(param, param); /* apply check_id to the callee parameters */`
		3574	`} /* for */`
		3575	`}`
		3576
		3577	`if (redo_structfns && !reg_result(result_shape)) {`
		3578	`if (proc_struct_result==nilexp){`
		3579	`exp init = getexp(f_pointer(f_alignment(result_shape)),`
		3580	`nilexp, 0, nilexp, nilexp,`
		3581	`0, 0, clear_tag);`
		3582	`exp iddec = getexp(sh(son(res)), nilexp, 0, init, nilexp,`
		3583	`0, 0, ident_tag);`
		3584	`setparam(iddec);`
		3585	`proc_struct_result = iddec;`
		3586	`};`
		3587
		3588	`bro(son(proc_struct_result)) = son(res);`
		3589	`setfather(proc_struct_result, son(res));`
		3590	`son(res) = proc_struct_result;`
		3591	`setfather(res, proc_struct_result);`
		3592	`};`
		3593
		3594	`/* clear this flag to distinguish values created during procedure`
		3595	`reading.`
		3596	`*/`
		3597	`in_proc_def = 0;`
		3598
		3599	`set_make_procprops(res,prcprops);`
		3600
		3601	`pop_proc_props();`
		3602	`if (old_proc_props != (proc_props *)0 \|\| rep_make_proc) {`
		3603	`dec * extra_dec = make_extra_dec(make_local_name(), 0, 0, res, f_proc);`
		3604	`exp e = extra_dec -> dec_u.dec_val.dec_exp;`
		3605	`res = getexp (f_proc, nilexp, 0, e, nilexp, 0, 0, name_tag);`
		3606	`pt(e) = res;`
		3607	`no(e) = 1;`
		3608	`};`
		3609
		3610	`return res;`
		3611	`}`
		3612
		3613
		3614	`exp find_caller_id`
		3615	`PROTO_N ( (n, p) )`
		3616	`PROTO_T ( int n X exp p )`
		3617	`{`
		3618	`while (name(p) == ident_tag) {`
		3619	`if (name(son(p)) == caller_name_tag && no(son(p))==n) {`
		3620	`return p;`
		3621	`}`
		3622	`p = bro(son(p));`
		3623	`}`
		3624	`return nilexp;`
		3625	`}`
		3626
		3627	`void start_apply_general_proc`
		3628	`PROTO_N ( (result_shape, prcprops, p, caller_params_intro, callee_params) )`
		3629	`PROTO_T ( shape result_shape X procprops_option prcprops X exp p X`
		3630	`otagexp_list caller_params_intro X callees callee_params )`
		3631	`{`
		3632	`return;`
		3633	`}`
		3634
		3635	`exp f_apply_general_proc`
		3636	`PROTO_N ( (result_shape, prcprops, p, caller_pars, callee_pars, postlude) )`
		3637	`PROTO_T ( shape result_shape X procprops prcprops X exp p X`
		3638	`otagexp_list caller_pars X callees callee_pars X exp postlude )`
		3639	`{`
		3640	`exp res = getexp(result_shape, nilexp, 0, p, nilexp,`
		3641	`0, 0, apply_general_tag);`
		3642	`exp r_p;`
		3643	`exp redos = nilexp;`
		3644	`exp last_redo;`
		3645	`has_alloca = 1;`
		3646
		3647	`if (name(callee_pars) == same_callees_tag) {`
		3648	`/* it's a constant */`
		3649	`callee_pars = copy(callee_pars);`
		3650	`}`
		3651
		3652
		3653	`if (redo_structparams){`
		3654	`int i;`
		3655	`exp * plce = &caller_pars.start;`
		3656	`for(i=0; i< caller_pars.number; i++) {`
		3657	`exp ote = *plce;`
		3658	`exp param = (name(ote)==caller_tag)?son(ote):ote;`
		3659	`if ((name(sh(param)) == cpdhd \|\| name(sh(param)) == nofhd \|\|`
		3660	`name(sh(param)) == doublehd)`
		3661	`#if issparc`
		3662	`\|\| sparccpd(sh(param))`
		3663
		3664	`#endif`
		3665	`#if ishppa`
		3666	`&& shape_size(sh(param))>64`
		3667	`#endif`
		3668	`) { /* make copy of par and use ptr as par */`
		3669	`shape nshape = f_pointer(f_alignment(sh(param)));`
		3670	`exp rd = me_startid(nshape, param, 1);`
		3671	`exp npar = me_obtain(rd);`
		3672	`exp id;`
		3673	`if (name(ote)==caller_tag &&`
		3674	`(id = find_caller_id(i, caller_pars.id)) != nilexp) {`
		3675	`exp p = pt(id);`
		3676	`son(ote) = npar;`
		3677	`bro(npar)= ote; setlast(npar);`
		3678	`sh(son(id)) = sh(npar);`
		3679	`while(p != nilexp) { /* replaces uses in postlude */`
		3680	`exp bp = bro(p);`
		3681	`int l = last(p);`
		3682	`exp np = pt(p);`
		3683	`exp * pos = refto(father(p), p);`
		3684	`exp c;`
		3685	`sh(p) = nshape;`
		3686	`c = f_contents(sh(ote), p);`
		3687	`if (l) { setlast(c); } else {clearlast(c); }`
		3688	`bro(c) = bp;`
		3689	`*pos = c;`
		3690	`p = np;`
		3691	`}`
		3692	`sh(ote) = nshape;`
		3693	`plce = &bro(ote);`
		3694	`}`
		3695	`else {`
		3696	`if (last(ote)) { setlast(npar); }`
		3697	`bro(npar) = bro(ote);`
		3698	`if (ote == caller_pars.end) caller_pars.end = npar;`
		3699	`*plce = npar;`
		3700	`plce = &bro(npar);`
		3701	`}`
		3702	`bro(son(rd)) = redos; clearlast(son(rd));`
		3703	`if (redos != nilexp) {`
		3704	`bro(redos) = rd; setlast(redos);`
		3705	`}`
		3706	`else last_redo = rd;`
		3707	`redos = rd;`
		3708	`}`
		3709	`else {plce = &bro(ote);}`
		3710	`}`
		3711	`}`
		3712
		3713	`if (caller_pars.id != nilexp) {`
		3714	`exp a = caller_pars.id;`
		3715	`while (bro(son(a)) != nilexp) { a = bro(son(a)); }`
		3716	`bro(son(a)) = postlude;`
		3717	`setfather(a,postlude);`
		3718	`postlude = caller_pars.id;`
		3719	`}`
		3720
		3721	`setfather(res, postlude);`
		3722
		3723	`bro(callee_pars) = postlude; clearlast(callee_pars);`
		3724	`props(callee_pars) = prcprops;`
		3725
		3726	`r_p = getexp(f_top, callee_pars, 0, caller_pars.start, nilexp, prcprops,`
		3727	`caller_pars.number, 0);`
		3728	`if (caller_pars.number !=0) { setfather(r_p,caller_pars.end); }`
		3729
		3730	`bro(p) = r_p; clearlast(p);`
		3731	`#ifdef promote_pars`
		3732	`{ int i;`
		3733	`exp ote = caller_pars.start;`
		3734	`for (i = 0; i< caller_pars.number; i++) {`
		3735	`shape s = sh(ote);`
		3736	`if (name(s)>=scharhd && name(s)<=uwordhd) {`
		3737	`shape ns = (is_signed(s))? slongsh:ulongsh;`
		3738	`exp par = (name(ote)==caller_tag)?son(ote):ote;`
		3739	`exp next = bro(ote);`
		3740	`exp id;`
		3741	`int l = last(ote);`
		3742	`exp w = hold_check(f_change_variety(f_wrap,ns, copy(par)));`
		3743	`if (name(ote)==caller_tag) sh(ote)=ns;`
		3744	`replace(par, w, nilexp);`
		3745	`kill_exp(par, nilexp);`
		3746	`if (name(ote) == caller_tag &&`
		3747	`(id = find_caller_id(i, postlude)) != nilexp) {`
		3748	`exp p = pt(id);`
		3749	`sh(son(id))=ns;`
		3750	`while(p != nilexp) { /* replaces uses in postlude */`
		3751	`exp nextp = pt(p);`
		3752	`sh(p) = ns;`
		3753	`w = f_change_variety(f_wrap, s, copy(p));`
		3754	`replace(p, w, nilexp);`
		3755	`kill_exp(p, nilexp);`
		3756	`p = nextp;`
		3757	`}`
		3758	`}`
		3759	`if (l) break;`
		3760	`ote = next;`
		3761	`}`
		3762	`else ote = bro(ote);`
		3763	`}`
		3764	`}`
		3765	`#endif`
		3766
		3767	`if (redo_structfns && !reg_result(result_shape))`
		3768	`{`
		3769	`/* replace f(x) by {var r; f(r, x); cont(r)} */`
		3770	`exp init, vardec, cont, contname, seq, app, appname, tmp;`
		3771	`exp_list list;`
		3772	`shape ptr_res_shape = f_pointer(f_alignment(result_shape));`
		3773
		3774	`init = getexp(result_shape, nilexp, 0, nilexp, nilexp,`
		3775	`0, 0, clear_tag);`
		3776	`vardec = getexp(result_shape, nilexp, 0, init, nilexp,`
		3777	`0, 1, ident_tag);`
		3778	`setvar(vardec);`
		3779	`contname = getexp(ptr_res_shape, nilexp, 0,`
		3780	`vardec, nilexp, 0, 0, name_tag);`
		3781	`pt(vardec) = contname;`
		3782	`cont = f_contents(result_shape, contname);`
		3783
		3784	`appname = getexp(ptr_res_shape, son(r_p), 0,`
		3785	`vardec, contname, 0, 0, name_tag);`
		3786	`if(no(r_p)++ == 0) {`
		3787	`setfather(r_p, appname);`
		3788	`}`
		3789	`++no(vardec);`
		3790	`pt(vardec) = appname;`
		3791	`app = getexp(f_top, nilexp, 0, son(res), nilexp, 0, 32,`
		3792	`apply_general_tag);`
		3793	`son(r_p) = appname;`
		3794
		3795	`tmp = postlude;`
		3796	`while(name(tmp)==ident_tag && name(son(tmp))==caller_name_tag) {`
		3797	`no(son(tmp))++;`
		3798	`tmp = bro(son(tmp));`
		3799	`}`
		3800
		3801	`bro(postlude) = app;`
		3802	`list.number = 1;`
		3803	`list.start = app;`
		3804	`list.end = app;`
		3805	`seq = f_sequence(list, cont);`
		3806	`bro(init) = seq;`
		3807	`setfather(vardec, seq);`
		3808	`retcell(res);`
		3809	`res = vardec;`
		3810	`};`
		3811
		3812	`if (redos != nilexp) { /* put in decs given by redo_structparams */`
		3813	`bro(son(last_redo)) = res; clearlast(son(last_redo));`
		3814	`bro(res) = last_redo; setlast(res);`
		3815	`res = redos;`
		3816	`}`
		3817
		3818	`return res;`
		3819	`}`
		3820
		3821
		3822	`exp f_tail_call`
		3823	`PROTO_N ( (prcprops,p,callee_params) )`
		3824	`PROTO_T ( procprops prcprops X exp p X callees callee_params )`
		3825	`{`
		3826	`exp res = getexp(f_bottom,nilexp, 0, p, nilexp, 0,0,`
		3827	`tail_call_tag);`
		3828	`exp e_p;`
		3829	`if (name(callee_params) == same_callees_tag) {`
		3830	`/* it's a constant */`
		3831	`callee_params = copy(callee_params);`
		3832	`}`
		3833	`e_p = getexp(f_top, res, 1, callee_params, nilexp, prcprops,`
		3834	`0, 0);`
		3835	`has_setjmp = 1; /* stop inlining ! */`
		3836	`has_alloca = 1; /* make sure has fp */`
		3837	`props(callee_params) = prcprops;`
		3838	`bro(p) = callee_params; clearlast(p);`
		3839	`setfather(res, callee_params);`
		3840	`return res;`
		3841	`}`
		3842
		3843
		3844
		3845	`exp f_untidy_return`
		3846	`PROTO_N ( (arg) )`
		3847	`PROTO_T ( exp arg )`
		3848	`{`
		3849	`exp res = getexp(f_bottom, nilexp, 0, arg, nilexp, 0, 0,`
		3850	`untidy_return_tag);`
		3851	`setfather(res,arg);`
		3852	`has_setjmp = 1;`
		3853	`return res;`
		3854	`}`
		3855
		3856	`alignment f_parameter_align`
		3857	`PROTO_N ( (a) )`
		3858	`PROTO_T ( alignment a )`
		3859	`{`
		3860	`return( f_var_param_alignment);`
		3861
		3862	`}`
		3863
		3864	`exp f_set_stack_limit`
		3865	`PROTO_N ( (flim) )`
		3866	`PROTO_T ( exp flim )`
		3867	`{`
		3868	`return me_u3(f_top, flim, set_stack_limit_tag);`
		3869	`}`
		3870
		3871	`exp f_give_stack_limit`
		3872	`PROTO_N ( (frame_al) )`
		3873	`PROTO_T ( alignment frame_al )`
		3874	`{`
		3875	`exp res = getexp(f_pointer(frame_al), nilexp, 0, nilexp, nilexp, 0, 0,`
		3876	`give_stack_limit_tag);`
		3877	`return res;`
		3878	`}`
		3879
		3880	`exp f_make_stack_limit`
		3881	`PROTO_N ( (stack_base, frame_size, alloca_size) )`
		3882	`PROTO_T ( exp stack_base X exp frame_size X exp alloca_size )`
		3883	`{`
		3884
		3885	`exp sz;`
		3886	`frame_size = hold_check(f_offset_pad(al1_of(sh(alloca_size)), frame_size) );`
		3887	`alloca_size = hold_check(f_offset_pad(f_alignment(ucharsh), alloca_size) );`
		3888	`sz = hold_check(f_offset_add(frame_size, alloca_size));`
		3889	`return me_b2(stack_base, sz, make_stack_limit_tag);`
		3890	`}`
		3891	`exp f_env_size`
		3892	`PROTO_N ( (proctag) )`
		3893	`PROTO_T ( tag proctag )`
		3894	`{`
		3895	`exp res = getexp(f_offset(f_locals_alignment,f_locals_alignment ), nilexp, 0,`
		3896	`f_obtain_tag(proctag), nilexp, 0, 0, env_size_tag);`
		3897	`bro(son(res))=res; setlast(son(res));`
		3898	`return res;`
		3899	`}`
		3900
		3901
		3902
		3903	`nat f_error_val`
		3904	`PROTO_N ( (ec) )`
		3905	`PROTO_T ( error_code ec )`
		3906	`{`
		3907	`nat res;`
		3908	`nat_issmall(res) =1;`
		3909	`natint(res) = ec;`
		3910	`return res;`
		3911	`}`
		3912
		3913	`exp f_make_top`
		3914	`PROTO_Z ()`
		3915	`{`
		3916	`return getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, top_tag);`
		3917	`}`
		3918
		3919	`exp f_make_value`
		3920	`PROTO_N ( (s) )`
		3921	`PROTO_T ( shape s )`
		3922	`{`
		3923	`return me_l1(s, clear_tag);`
		3924	`}`
		3925
		3926	`exp f_minus`
		3927	`PROTO_N ( (ov_err, arg1, arg2) )`
		3928	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		3929	`{`
		3930	`if (name(sh(arg1)) == bothd)`
		3931	`{ kill_exp(arg2,arg2); return arg1; }`
		3932	`if (name(sh(arg2)) == bothd)`
		3933	`{ kill_exp(arg1,arg1); return arg2; }`
		3934
		3935	`#if check_shape`
		3936	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		3937	`failer(CHSH_MINUS);`
		3938	`#endif`
		3939	`#if !has64bits`
		3940	`if (name(sh(arg1)) >= s64hd &&`
		3941	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		3942	`return TDFcallop2(ov_err,arg1,arg2,minus_tag);`
		3943	`}`
		3944	`#endif`
		3945	`return me_b1(ov_err, arg1, arg2, minus_tag);`
		3946	`}`
		3947
		3948	`exp f_move_some`
		3949	`PROTO_N ( (md, arg1, arg2, arg3) )`
		3950	`PROTO_T ( transfer_mode md X exp arg1 X exp arg2 X exp arg3 )`
		3951	`{`
		3952	`exp r = getexp(f_top, nilexp, 0, arg1, nilexp, 0, 0,`
		3953	`movecont_tag);`
		3954	`if (name(sh(arg1)) == bothd)`
		3955	`{ kill_exp(arg2,arg2); kill_exp(arg3,arg3); return arg1; }`
		3956	`if (name(sh(arg2)) == bothd)`
		3957	`{ kill_exp(arg1,arg1); kill_exp(arg3,arg3); return arg2; }`
		3958	`if (name(sh(arg3)) == bothd)`
		3959	`{ kill_exp(arg1,arg1); kill_exp(arg2,arg2); return arg3; }`
		3960
		3961	`#if check_shape`
		3962	`if (name(sh(arg1)) != ptrhd \|\| name(sh(arg2)) != ptrhd \|\|`
		3963	`name(sh(arg3)) != offsethd \|\|`
		3964	`al1(sh(arg1)) < al1(sh(arg3)) \|\| al1(sh(arg2)) < al1(sh(arg3)))`
		3965	`failer(CHSH_MOVESOME);`
		3966	`#endif`
		3967	`#ifdef no_trap_on_nil_contents`
		3968	`if ((md & f_trap_on_nil) != 0) {`
		3969	`exp d2 = me_startid(f_top, arg2, 0);`
		3970	`exp d1 = me_startid(f_top, arg1,0);`
		3971	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		3972	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		3973	`exp_list el;`
		3974	`exp test2 = me_q1(no_nat_option, f_not_equal, &lb, me_obtain(d2),`
		3975	`f_make_null_ptr(al1_of(sh(arg2))), test_tag);`
		3976	`exp test1 = me_q1(no_nat_option, f_not_equal, &lb, me_obtain(d1),`
		3977	`f_make_null_ptr(al1_of(sh(arg1))), test_tag);`
		3978	`exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp,`
		3979
		3980	`md &= ~f_trap_on_nil;`
		3981	`el = new_exp_list(2);`
		3982	`el = add_exp_list(el, test1, 1);`
		3983	`el = add_exp_list(el, test2, 2);`
		3984
		3985	`return me_complete_id(d2,me_complete_id(d1,`
		3986	`f_conditional(&lb, f_sequence(el,f_move_some(md, me_obtain(d1), me_obtain(d2), arg3) ),trp`
		3987	`) ));`
		3988
		3989	`};`
		3990	`#endif`
		3991	`if (!(md & f_overlap) && name(arg3) == val_tag && al2(sh(arg3)) > 1) {`
		3992	`exp c = f_contents(f_compound(arg3), arg1);`
		3993	`return f_assign(arg2, c);`
		3994	`};`
		3995
		3996	`if (al2(sh(arg3)) < 8) {`
		3997	`arg3 = hold_check(f_offset_pad(f_alignment(ucharsh), arg3));`
		3998	`}`
		3999
		4000	`if (!(md & f_overlap))`
		4001	`setnooverlap(r);`
		4002	`clearlast(arg1);`
		4003	`setbro(arg1, arg2);`
		4004	`clearlast(arg2);`
		4005	`setbro(arg2, arg3);`
		4006	`setfather(r, arg3);`
		4007	`return r;`
		4008	`}`
		4009
		4010	`exp f_mult`
		4011	`PROTO_N ( (ov_err, arg1, arg2) )`
		4012	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		4013	`{`
		4014	`if (name(sh(arg1)) == bothd)`
		4015	`{ kill_exp(arg2,arg2); return arg1; }`
		4016	`if (name(sh(arg2)) == bothd)`
		4017	`{ kill_exp(arg1,arg1); return arg2; }`
		4018
		4019	`#if check_shape`
		4020	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		4021	`failer(CHSH_MULT);`
		4022	`#endif`
		4023	`#if !has64bits`
		4024	`if (name(sh(arg1)) >= s64hd &&`
		4025	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		4026	`return TDFcallop2(ov_err,arg1,arg2,mult_tag);`
		4027	`}`
		4028	`#endif`
		4029
		4030	`return me_b1(ov_err, arg1, arg2, mult_tag);`
		4031	`}`
		4032
		4033	`exp f_n_copies`
		4034	`PROTO_N ( (n, arg1) )`
		4035	`PROTO_T ( nat n X exp arg1 )`
		4036	`{`
		4037	`exp r;`
		4038	`if (name(sh(arg1)) == bothd)`
		4039	`return arg1;`
		4040
		4041	`#if !has64bits`
		4042	`if (!nat_issmall(n))`
		4043	`failer(TOO_BIG_A_VECTOR);`
		4044	`#endif`
		4045
		4046	`r = getexp(f_nof(n, sh(arg1)), nilexp, 0, arg1, nilexp,`
		4047	`0, natint(n), ncopies_tag);`
		4048	`if (name(sh(arg1))==bitfhd) {`
		4049	`/* make ncopies bitfields into (ncopies) make-compound */`
		4050	`int sf = shape_size(sh(arg1));`
		4051	`int snof = shape_size(sh(r));`
		4052	`int scs = (((sf-1)&sf)==0)?sf:snof;`
		4053	`shape cs = containedshape( scs, 1);`
		4054	`exp_list a;`
		4055	`shape cpds = f_compound(hold_check(f_offset_pad(f_alignment(cs),`
		4056	`f_shape_offset(sh(r)))));`
		4057	`exp soff = getexp(f_offset(f_alignment(cpds), f_alignment(sh(arg1))),`
		4058	`nilexp, 0, nilexp, nilexp, 0, 0, val_tag);`
		4059	`exp cexp;`
		4060	`a.start = copyexp(soff);`
		4061	`a.end = a.start;`
		4062	`a.number = 2;`
		4063	`bro(a.end) = copyexp(arg1);`
		4064	`a.end = bro(a.end);`
		4065	`for(no(soff)=sf; no(soff) <= shape_size(cs)-sf; no(soff)+=sf ) {`
		4066	`bro(a.end) = copyexp(soff); clearlast(a.end);`
		4067	`a.end = bro(a.end);`
		4068	`bro(a.end) = copyexp(arg1);`
		4069	`a.end = bro(a.end);`
		4070	`a.number +=2;`
		4071	`}`
		4072
		4073	`setlast(a.end);`
		4074	`bro(a.end) = nilexp;`
		4075	`cexp = f_make_compound(hold_check(f_shape_offset(cs)), a);`
		4076	`if (shape_size(cs) >=shape_size(cpds)) {`
		4077	`return cexp;`
		4078	`}`
		4079	`else {`
		4080	`natint(n) = shape_size(cpds)/shape_size(cs);`
		4081	`return f_n_copies(n, cexp);`
		4082	`}`
		4083	`}`
		4084
		4085	`setfather(r, arg1);`
		4086	`return r;`
		4087	`}`
		4088
		4089	`exp f_negate`
		4090	`PROTO_N ( (ov_err, arg1) )`
		4091	`PROTO_T ( error_treatment ov_err X exp arg1 )`
		4092	`{`
		4093	`if (name(sh(arg1)) == bothd)`
		4094	`return arg1;`
		4095
		4096	`#if check_shape`
		4097	`if (!is_integer(sh(arg1)))`
		4098	`failer(CHSH_NEGATE);`
		4099	`#endif`
		4100	`if (!is_signed(sh(arg1)) && ov_err.err_code >2) {`
		4101	`return f_minus(ov_err, me_shint(sh(arg1),0), arg1);`
		4102	`}`
		4103	`#if !has64bits`
		4104	`if (name(sh(arg1)) >= s64hd &&`
		4105	`(name(arg1)!=val_tag\|\| ov_err.err_code > 2 )) {`
		4106	`return TDFcallop1(ov_err,arg1,neg_tag);`
		4107	`}`
		4108	`#endif`
		4109
		4110	`return me_u1(ov_err, arg1, neg_tag);`
		4111	`}`
		4112
		4113	`exp f_not`
		4114	`PROTO_N ( (arg1) )`
		4115	`PROTO_T ( exp arg1 )`
		4116	`{`
		4117	`if (name(sh(arg1)) == bothd)`
		4118	`return arg1;`
		4119
		4120	`#if check_shape`
		4121	`if (!is_integer(sh(arg1)))`
		4122	`failer(CHSH_NOT);`
		4123	`#endif`
		4124	`#if !has64bits`
		4125	`if (name(sh(arg1)) >= s64hd &&`
		4126	`name(arg1)!=val_tag ){`
		4127	`return TDFcallop4(arg1,not_tag);`
		4128	`}`
		4129	`#endif`
		4130	`return me_u2(arg1, not_tag);`
		4131	`}`
		4132
		4133	`exp f_obtain_tag`
		4134	`PROTO_N ( (t) )`
		4135	`PROTO_T ( tag t )`
		4136	`{`
		4137	`shape s;`
		4138	`exp r;`
		4139	`exp tg = get_tag(t);`
		4140
		4141	`if (tg == nilexp)`
		4142	`failer(UNDEF_TAG);`
		4143
		4144	`if (isglob(tg))`
		4145	`{`
		4146	`s = sh(t -> dec_u.dec_val.dec_exp);`
		4147	`#ifdef NEWDIAGS`
		4148	`if (!within_diags)`
		4149	`proc_externs = 1;`
		4150	`#else`
		4151	`proc_externs = 1;`
		4152	`#endif`
		4153	`}`
		4154	`else`
		4155	`s = sh(son(tg));`
		4156
		4157	`if (isvar(tg)) {`
		4158	`if (isparam(tg)) {`
		4159	`s = f_pointer(f_parameter_alignment(s));`
		4160	`}`
		4161	`else {`
		4162	`s = f_pointer(f_alignment(s));`
		4163	`}`
		4164	`}`
		4165
		4166	`r = getexp (s, nilexp, 0, tg, pt (tg), 0, 0, name_tag);`
		4167	`pt(tg) = r;`
		4168	`no(tg) = no(tg)+1;`
		4169	`return(r);`
		4170	`}`
		4171
		4172	`exp f_offset_add`
		4173	`PROTO_N ( (arg1, arg2) )`
		4174	`PROTO_T ( exp arg1 X exp arg2 )`
		4175	`{`
		4176	`shape sres;`
		4177	`if (name(sh(arg1)) == bothd)`
		4178	`{ kill_exp(arg2,arg2); return arg1; }`
		4179	`if (name(sh(arg2)) == bothd)`
		4180	`{ kill_exp(arg1,arg1); return arg2; }`
		4181
		4182
		4183	`#if check_shape`
		4184	`if (!doing_aldefs &&`
		4185	`((name(sh(arg1)) != offsethd \|\| name(sh(arg2)) != offsethd \|\|`
		4186	`(al1(sh(arg2)) > al2(sh(arg1))`
		4187	`#if issparc`
		4188	`&& al1_of(sh(arg2)) != REAL_ALIGN`
		4189	`#endif`
		4190	`) )))`
		4191	`failer(CHSH_OFFSETADD);`
		4192	`#endif`
		4193	`sres = f_offset(al1_of(sh(arg1)), al2_of(sh(arg2)));`
		4194	`#if 0`
		4195	`if ((al1_of(sh(arg1))->al.al_val.al_frame & 4) != 0 &&`
		4196	`al2_of(sh(arg2))->al.sh_hd != 0) {`
		4197	`exp ne;`
		4198	`if (al2_of(sh(arg2))->al.sh_hd > nofhd) {`
		4199	`shape ps = f_pointer(f_alignment(sh(arg1)));`
		4200	`ne = hold_check(`
		4201	`f_offset_pad(f_alignment(ps), f_shape_offset(ps))`
		4202	`);`
		4203	`}`
		4204	`else {`
		4205	`ne = arg2;`
		4206	`}`
		4207	`arg2 = hold_check(me_u2(ne, offset_negate_tag));`
		4208	`}`
		4209	`#endif`
		4210	`return me_b3(sres,arg1, arg2, offset_add_tag);`
		4211	`}`
		4212
		4213	`exp f_offset_div`
		4214	`PROTO_N ( (v, arg1, arg2) )`
		4215	`PROTO_T ( variety v X exp arg1 X exp arg2 )`
		4216	`{`
		4217	`if (name(sh(arg1)) == bothd)`
		4218	`{ kill_exp(arg2,arg2); return arg1; }`
		4219	`if (name(sh(arg2)) == bothd)`
		4220	`{ kill_exp(arg1,arg1); return arg2; }`
		4221	`#if check_shape`
		4222	`if (name(sh(arg1)) != offsethd \|\| name(sh(arg2)) != offsethd)`
		4223	`failer(CHSH_OFFSETDIV);`
		4224	`#endif`
		4225
		4226	`return me_b3(f_integer(v), arg1, arg2, offset_div_tag);`
		4227	`}`
		4228
		4229	`exp f_offset_div_by_int`
		4230	`PROTO_N ( (arg1, arg2) )`
		4231	`PROTO_T ( exp arg1 X exp arg2 )`
		4232	`{`
		4233	`if (name(sh(arg1)) == bothd)`
		4234	`{ kill_exp(arg2,arg2); return arg1; }`
		4235	`if (name(sh(arg2)) == bothd)`
		4236	`{ kill_exp(arg1,arg1); return arg2; }`
		4237
		4238	`#if check_shape`
		4239	`if (!doing_aldefs &&`
		4240	`(name(sh(arg1)) != offsethd \|\| !is_integer(sh(arg2)) \|\|`
		4241	`(al1(sh(arg1)) != al2(sh(arg1)) && al2(sh(arg1))!=1)) )`
		4242	`failer(CHSH_OFFSETDIVINT);`
		4243	`#endif`
		4244
		4245	`return me_b3(sh(arg1), arg1, arg2, offset_div_by_int_tag);`
		4246	`}`
		4247
		4248	`exp f_offset_max`
		4249	`PROTO_N ( (arg1, arg2) )`
		4250	`PROTO_T ( exp arg1 X exp arg2 )`
		4251	`{`
		4252	`alignment a1 = al1_of(sh(arg1));`
		4253	`alignment a2 = al1_of(sh(arg2));`
		4254	`alignment a3 = al2_of(sh(arg1));`
		4255	`shape sha;`
		4256	`if (name(sh(arg1)) == bothd)`
		4257	`{ kill_exp(arg2,arg2); return arg1; }`
		4258	`if (name(sh(arg2)) == bothd)`
		4259	`{ kill_exp(arg1,arg1); return arg2; }`
		4260
		4261	`#if check_shape`
		4262	`if (!doing_aldefs &&`
		4263	`(name(sh(arg1)) != offsethd \|\| name(sh(arg2)) != offsethd))`
		4264	`failer(CHSH_OFFSETMAX);`
		4265	`#endif`
		4266
		4267	`if (a1->al.al_n != 1 \|\| a2->al.al_n != 1) {`
		4268	`alignment ares = (alignment)calloc(1, sizeof(aldef));`
		4269	`if (!doing_aldefs)`
		4270	`failer(CHSH_OFFSETMAX);`
		4271	`ares->al.al_n = 2;`
		4272	`ares->al.al_val.al_join.a = a1;`
		4273	`ares->al.al_val.al_join.b = a2;`
		4274	`ares->next_aldef = top_aldef;`
		4275	`top_aldef = ares;`
		4276	`sha = f_offset(ares, a3);`
		4277	`}`
		4278	`else`
		4279	`sha = f_offset(long_to_al(max(a1->al.al_val.al,`
		4280	`a2->al.al_val.al)),`
		4281	`a3);`
		4282
		4283	`return me_b3(sha, arg1, arg2, offset_max_tag);`
		4284	`}`
		4285	`exp f_offset_mult`
		4286	`PROTO_N ( (arg1, arg2) )`
		4287	`PROTO_T ( exp arg1 X exp arg2 )`
		4288	`{`
		4289	`if (name(sh(arg1)) == bothd)`
		4290	`{ kill_exp(arg2,arg2); return arg1; }`
		4291	`if (name(sh(arg2)) == bothd)`
		4292	`{ kill_exp(arg1,arg1); return arg2; }`
		4293
		4294	`#if check_shape`
		4295	`if (!doing_aldefs &&`
		4296	`(name(sh(arg1)) != offsethd \|\| !is_integer(sh(arg2))))`
		4297	`failer(CHSH_OFFSETMULT);`
		4298	`#endif`
		4299
		4300	`if (shape_size(sh(arg2)) != PTR_SZ) {`
		4301	`if (PTR_SZ == 32)`
		4302	`arg2 = hold_check(f_change_variety(f_impossible, slongsh, arg2));`
		4303	`else`
		4304	`arg2 = hold_check(f_change_variety(f_impossible, s64sh, arg2));`
		4305	`};`
		4306
		4307	`return me_b3(sh(arg1), arg2, arg1, offset_mult_tag);`
		4308	`/* the order of arguments is being interchanged */`
		4309	`}`
		4310
		4311	`exp f_offset_negate`
		4312	`PROTO_N ( (arg1) )`
		4313	`PROTO_T ( exp arg1 )`
		4314	`{`
		4315	`if (name(sh(arg1)) == bothd)`
		4316	`return arg1;`
		4317
		4318	`#if check_shape`
		4319	`if (!doing_aldefs &&`
		4320	`(name(sh(arg1)) != offsethd \|\|`
		4321	`(al1(sh(arg1)) != al2(sh(arg1)) && al2(sh(arg1)) != 1`
		4322	`#if issparc`
		4323	`&& al1_of(sh(arg1)) != REAL_ALIGN`
		4324	`#endif`
		4325	`)))`
		4326	`failer(CHSH_OFFSETNEG);`
		4327	`#endif`
		4328
		4329	`return me_u2(arg1, offset_negate_tag);`
		4330	`}`
		4331
		4332	`exp f_offset_pad`
		4333	`PROTO_N ( (a, arg1) )`
		4334	`PROTO_T ( alignment a X exp arg1 )`
		4335	`{`
		4336	`shape sha;`
		4337	`if (name(sh(arg1)) == bothd)`
		4338	`return arg1;`
		4339
		4340	`#if check_shape`
		4341	`if (name(sh(arg1)) != offsethd)`
		4342	`failer(CHSH_OFFSETPAD);`
		4343	`#endif`
		4344
		4345	`if (a->al.al_n != 1 \|\| al1_of(sh(arg1))->al.al_n != 1) {`
		4346	`alignment ares = (alignment)calloc(1, sizeof(aldef));`
		4347	`if (!doing_aldefs)`
		4348	`failer(ILL_OFFSETPAD);`
		4349	`ares->al.al_n = 2;`
		4350	`ares->al.al_val.al_join.a = a;`
		4351	`ares->al.al_val.al_join.b = al1_of(sh(arg1));`
		4352	`ares->next_aldef = top_aldef;`
		4353	`top_aldef = ares;`
		4354	`sha = f_offset(ares, a);`
		4355	`}`
		4356	`else`
		4357	`if (al1_of(sh(arg1))->al.al_val.al_frame != 0)`
		4358	`sha = f_offset(al1_of(sh(arg1)), a);`
		4359	`else`
		4360	`sha = f_offset(long_to_al(max(a->al.al_val.al,`
		4361	`al1(sh(arg1)))),`
		4362	`a);`
		4363
		4364
		4365	`return(me_u3(sha, arg1, offset_pad_tag));`
		4366	`}`
		4367
		4368
		4369
		4370
		4371	`exp f_offset_subtract`
		4372	`PROTO_N ( (arg1, arg2) )`
		4373	`PROTO_T ( exp arg1 X exp arg2 )`
		4374	`{`
		4375	`if (name(sh(arg1)) == bothd)`
		4376	`{ kill_exp(arg2,arg2); return arg1; }`
		4377	`if (name(sh(arg2)) == bothd)`
		4378	`{ kill_exp(arg1,arg1); return arg2; }`
		4379
		4380	`return me_b3(f_offset(al2_of(sh(arg2)),`
		4381	`al2_of(sh(arg1))),`
		4382	`arg1, arg2, offset_subtract_tag);`
		4383	`}`
		4384
		4385	`exp f_offset_test`
		4386	`PROTO_N ( (prob, nt, dest, arg1, arg2) )`
		4387	`PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X exp arg2 )`
		4388	`{`
		4389	`if (name(sh(arg1)) == bothd)`
		4390	`{ kill_exp(arg2,arg2); return arg1; }`
		4391	`if (name(sh(arg2)) == bothd)`
		4392	`{ kill_exp(arg1,arg1); return arg2; }`
		4393
		4394	`#if check_shape`
		4395	`if (!doing_aldefs &&`
		4396	`(name(sh(arg1)) != offsethd \|\| name(sh(arg2)) != offsethd \|\|`
		4397	`/* al1(sh(arg1)) != al1(sh(arg2)) \|\| */`
		4398	`al2(sh(arg1)) != al2(sh(arg2))))`
		4399	`failer(CHSH_OFFSETTEST);`
		4400	`#endif`
		4401
		4402	`if (nt == f_comparable \|\| nt == f_not_comparable)`
		4403	`return replace_ntest(nt, dest, arg1, arg2);`
		4404	`else`
		4405	`return me_q1(prob, convert_ntest[nt], dest, arg1, arg2, test_tag);`
		4406	`}`
		4407
		4408	`exp f_offset_zero`
		4409	`PROTO_N ( (a) )`
		4410	`PROTO_T ( alignment a )`
		4411	`{`
		4412	`return getexp(f_offset(a, a), nilexp, 0,`
		4413	`nilexp, nilexp, 0, 0, val_tag);`
		4414	`}`
		4415
		4416	`exp f_or`
		4417	`PROTO_N ( (arg1, arg2) )`
		4418	`PROTO_T ( exp arg1 X exp arg2 )`
		4419	`{`
		4420	`if (name(sh(arg1)) == bothd)`
		4421	`{ kill_exp(arg2,arg2); return arg1; }`
		4422	`if (name(sh(arg2)) == bothd)`
		4423	`{ kill_exp(arg1,arg1); return arg2; }`
		4424
		4425	`#if check_shape`
		4426	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		4427	`failer(CHSH_OR);`
		4428	`#endif`
		4429	`#if !has64bits`
		4430	`if (name(sh(arg1)) >= s64hd &&`
		4431	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)){`
		4432	`return TDFcallop3(arg1,arg2,or_tag);`
		4433	`}`
		4434	`#endif`
		4435	`return me_b2( arg1, arg2, or_tag);`
		4436	`}`
		4437
		4438	`exp f_plus`
		4439	`PROTO_N ( (ov_err, arg1, arg2) )`
		4440	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		4441	`{`
		4442	`if (name(sh(arg1)) == bothd)`
		4443	`{ kill_exp(arg2,arg2); return arg1; }`
		4444	`if (name(sh(arg2)) == bothd)`
		4445	`{ kill_exp(arg1,arg1); return arg2; }`
		4446
		4447	`#if check_shape`
		4448	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		4449	`failer(CHSH_PLUS);`
		4450	`#endif`
		4451	`#if !has64bits`
		4452	`if (name(sh(arg1)) >= s64hd &&`
		4453	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		4454	`return TDFcallop2(ov_err,arg1,arg2,plus_tag);`
		4455	`}`
		4456	`#endif`
		4457	`return me_b1(ov_err, arg1, arg2, plus_tag);`
		4458	`}`
		4459
		4460	`exp f_pointer_test`
		4461	`PROTO_N ( (prob, nt, dest, arg1, arg2) )`
		4462	`PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X exp arg2 )`
		4463	`{`
		4464	`if (name(sh(arg1)) == bothd)`
		4465	`{ kill_exp(arg2,arg2); return arg1; }`
		4466	`if (name(sh(arg2)) == bothd)`
		4467	`{ kill_exp(arg1,arg1); return arg2; }`
		4468
		4469	`#if check_shape`
		4470	`if (!doing_aldefs &&`
		4471	`(name(sh(arg1)) != ptrhd \|\| al1(sh(arg1)) != al1(sh(arg2))))`
		4472	`failer(CHSH_PTRTEST);`
		4473	`#endif`
		4474
		4475	`if (nt == f_comparable \|\| nt == f_not_comparable)`
		4476	`return replace_ntest(nt, dest, arg1, arg2);`
		4477	`else`
		4478	`return me_q1(prob, convert_ntest[nt], dest, arg1, arg2, test_tag);`
		4479	`}`
		4480
		4481
		4482	`exp f_proc_test`
		4483	`PROTO_N ( (prob, nt, dest, arg1, arg2) )`
		4484	`PROTO_T ( nat_option prob X ntest nt X label dest X exp arg1 X exp arg2 )`
		4485	`{`
		4486	`if (name(sh(arg1)) == bothd)`
		4487	`{ kill_exp(arg2,arg2); return arg1; }`
		4488	`if (name(sh(arg2)) == bothd)`
		4489	`{ kill_exp(arg1,arg1); return arg2; }`
		4490
		4491	`#if check_shape`
		4492	`/*`
		4493	`ONLY REMOVED TEMPORARILY!`
		4494	`if (name(sh(arg1)) != prokhd \|\| name(sh(arg2)) != prokhd)`
		4495	`failer(CHSH_PROCTEST);`
		4496	`*/`
		4497	`#endif`
		4498
		4499	`if (nt == f_comparable \|\| nt == f_not_comparable)`
		4500	`return replace_ntest(nt, dest, arg1, arg2);`
		4501	`else`
		4502	`return me_q1(prob, convert_ntest[nt], dest, arg1, arg2, test_tag);`
		4503	`}`
		4504
		4505	`exp f_profile`
		4506	`PROTO_N ( (n) )`
		4507	`PROTO_T ( nat n )`
		4508	`{`
		4509	`return getexp(f_top, nilexp, 0, nilexp, nilexp,`
		4510	`0, natint(n), prof_tag);`
		4511	`}`
		4512
		4513	`exp rem1_aux`
		4514	`PROTO_N ( (ov_err, arg1, arg2) )`
		4515	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		4516	`{`
		4517	`#if !has64bits`
		4518	`if (name(sh(arg1)) >= s64hd &&`
		4519	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		4520	`return TDFcallop2(ov_err,arg1,arg2,mod_tag);`
		4521	`}`
		4522	`#endif`
		4523	`return me_b1(ov_err, arg1, arg2, mod_tag);`
		4524	`}`
		4525
		4526	`exp f_rem1`
		4527	`PROTO_N ( (div0_err, ov_err, arg1, arg2) )`
		4528	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 )`
		4529	`{`
		4530	`if (name(sh(arg1)) == bothd)`
		4531	`{ kill_exp(arg2,arg2); return arg1; }`
		4532	`if (name(sh(arg2)) == bothd)`
		4533	`{ kill_exp(arg1,arg1); return arg2; }`
		4534
		4535	`#if check_shape`
		4536	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		4537	`failer(CHSH_REM1);`
		4538	`#endif`
		4539	`return div_rem(div0_err, ov_err, arg1, arg2, rem1_aux);`
		4540	`}`
		4541
		4542	`exp rem0_aux`
		4543	`PROTO_N ( (ov_err, arg1, arg2) )`
		4544	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		4545	`{`
		4546	`#if !has64bits`
		4547	`if (name(sh(arg1)) >= s64hd &&`
		4548	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		4549	`return TDFcallop2(ov_err,arg1,arg2,rem0_tag);`
		4550	`}`
		4551	`#endif`
		4552	`#if div0_implemented`
		4553	`return me_b1(ov_err, arg1, arg2, rem0_tag);`
		4554	`#else`
		4555	`if (name(arg2) == val_tag && !isbigval(arg2)) {`
		4556	`int n = no(arg2);`
		4557	`if ((n & (n-1)) == 0)`
		4558	`return me_b1(ov_err, arg1, arg2, mod_tag);`
		4559	`};`
		4560	`return me_b1(ov_err, arg1, arg2, rem2_tag);`
		4561	`#endif`
		4562	`}`
		4563	`exp f_rem0`
		4564	`PROTO_N ( (div0_err, ov_err, arg1, arg2) )`
		4565	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 )`
		4566	`{`
		4567	`if (name(sh(arg1)) == bothd)`
		4568	`{ kill_exp(arg2,arg2); return arg1; }`
		4569	`if (name(sh(arg2)) == bothd)`
		4570	`{ kill_exp(arg1,arg1); return arg2; }`
		4571
		4572
		4573	`#if check_shape`
		4574	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		4575	`failer(CHSH_REM0);`
		4576	`#endif`
		4577
		4578	`return div_rem(div0_err, ov_err, arg1, arg2, rem0_aux);`
		4579
		4580	`}`
		4581
		4582	`exp rem2_aux`
		4583	`PROTO_N ( (ov_err, arg1, arg2) )`
		4584	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		4585	`{`
		4586	`#if !has64bits`
		4587	`if (name(sh(arg1)) >= s64hd &&`
		4588	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		4589	`return TDFcallop2(ov_err,arg1,arg2,rem2_tag);`
		4590	`}`
		4591	`#endif`
		4592	`return me_b1(ov_err, arg1, arg2, rem2_tag);`
		4593	`}`
		4594
		4595	`exp f_rem2`
		4596	`PROTO_N ( (div0_err, ov_err, arg1, arg2) )`
		4597	`PROTO_T ( error_treatment div0_err X error_treatment ov_err X exp arg1 X exp arg2 )`
		4598	`{`
		4599	`if (name(sh(arg1)) == bothd)`
		4600	`{ kill_exp(arg2,arg2); return arg1; }`
		4601	`if (name(sh(arg2)) == bothd)`
		4602	`{ kill_exp(arg1,arg1); return arg2; }`
		4603
		4604	`#if check_shape`
		4605	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		4606	`failer(CHSH_REM2);`
		4607	`#endif`
		4608
		4609	`return div_rem(div0_err, ov_err, arg1, arg2, rem2_aux);`
		4610	`}`
		4611
		4612	`static int silly_count = 0; /* for pathological numbers of repeats*/`
		4613	`exp f_repeat`
		4614	`PROTO_N ( (repeat_label_intro, start, body) )`
		4615	`PROTO_T ( label repeat_label_intro X exp start X exp body )`
		4616	`{`
		4617	`exp r = getexp (sh (body), nilexp, 0, start, crt_repeat,`
		4618	`0, 0, rep_tag);`
		4619	`exp labst = get_lab(repeat_label_intro);`
		4620
		4621	`bro (start) = labst;`
		4622	`clearlast (start);`
		4623	`setbro (son(labst), body);`
		4624	`clearlast (son(labst));`
		4625	`setbro (body, labst);`
		4626	`setlast (body);`
		4627	`setsh (labst, sh (body));`
		4628	`son (crt_repeat) = r;`
		4629	`crt_repeat = bro(crt_repeat);`
		4630	`setfather (r, labst);`
		4631	`if (silly_count == 0) {`
		4632	`default_freq = (float) (default_freq / 20.0);`
		4633	`}`
		4634	`else silly_count--;`
		4635	`return r;`
		4636	`}`
		4637
		4638	`void start_repeat`
		4639	`PROTO_N ( (repeat_label_intro) )`
		4640	`PROTO_T ( label repeat_label_intro )`
		4641	`{`
		4642	`exp labst;`
		4643	`exp def;`
		4644	`def = getexp (f_top, nilexp, 0, nilexp, nilexp, 0, 0,`
		4645	`clear_tag);`
		4646
		4647	`/* enter this repeat on crt_repeat and repeat_list - see`
		4648	`documentation */`
		4649	`if (crt_repeat != nilexp)`
		4650	`++no (crt_repeat);`
		4651	`repeat_list = getexp (f_top, crt_repeat, 0, nilexp,`
		4652	`repeat_list, 1, 0, 0);`
		4653	`crt_repeat = repeat_list;`
		4654	`labst = getexp (f_bottom, nilexp, 0, def, nilexp,`
		4655	`0, 0, labst_tag);`
		4656	`if (default_freq < (float) 10e10) {`
		4657	`default_freq = (float) (20.0 * default_freq);`
		4658	`}`
		4659	`else silly_count++;`
		4660	`fno(labst) = default_freq;`
		4661	`++proc_label_count;`
		4662	`set_lab(repeat_label_intro, labst);`
		4663	`return;`
		4664	`}`
		4665
		4666	`exp f_return`
		4667	`PROTO_N ( (arg1) )`
		4668	`PROTO_T ( exp arg1 )`
		4669	`{`
		4670	`if (name(sh(arg1)) == bothd)`
		4671	`return arg1;`
		4672	`if (!reg_result(sh(arg1)))`
		4673	`proc_struct_res = 1;`
		4674
		4675	`/* transformation if we are giving procedures which deliver a struct`
		4676	`result an extra pointer parameter */`
		4677	`if (redo_structfns && !reg_result(sh(arg1)))`
		4678	`{`
		4679	`exp ret, obt;`
		4680	`exp assname, ass;`
		4681	`shape ptr_res_shape;`
		4682	`exp_list list;`
		4683
		4684	`if (proc_struct_result == nilexp)`
		4685	`{`
		4686	`exp init = getexp(f_pointer(f_alignment(sh(arg1))),`
		4687	`nilexp, 0, nilexp, nilexp,`
		4688	`0, 0, clear_tag);`
		4689	`exp iddec = getexp(sh(arg1), nilexp, 0, init, nilexp,`
		4690	`0, 0, ident_tag);`
		4691	`setparam(iddec);`
		4692	`proc_struct_result = iddec;`
		4693	`};`
		4694	`ptr_res_shape = f_pointer(f_alignment(sh(arg1)));`
		4695	`obt = getexp(ptr_res_shape, nilexp, 0, proc_struct_result,`
		4696	`pt(proc_struct_result), 0, 0, name_tag);`
		4697	`++no(proc_struct_result);`
		4698	`pt(proc_struct_result) = obt;`
		4699
		4700	`ret = me_u3(f_bottom, obt, res_tag);`
		4701
		4702	`assname = getexp(ptr_res_shape, nilexp, 0, proc_struct_result,`
		4703	`pt(proc_struct_result), 0, 0, name_tag);`
		4704	`++no(proc_struct_result);`
		4705	`pt(proc_struct_result) = assname;`
		4706	`ass = hold_check(f_assign(assname, arg1));`
		4707	`list.number = 1;`
		4708	`list.start = ass;`
		4709	`list.end = ass;`
		4710	`return f_sequence(list, ret);`
		4711	`};`
		4712	`return me_u3(f_bottom, arg1, res_tag);`
		4713	`}`
		4714
		4715	`exp f_rotate_left`
		4716	`PROTO_N ( (arg1, arg2) )`
		4717	`PROTO_T ( exp arg1 X exp arg2 )`
		4718	`{`
		4719	`if (name(sh(arg1)) == bothd)`
		4720	`{ kill_exp(arg2,arg2); return arg1; }`
		4721	`if (name(sh(arg2)) == bothd)`
		4722	`{ kill_exp(arg1,arg1); return arg2; }`
		4723
		4724	`#if check_shape`
		4725	`if (!is_integer(sh(arg1)) \|\| !is_integer(sh(arg2)))`
		4726	`failer(CHSH_ROTL);`
		4727	`#endif`
		4728	`#if !has_rotate`
		4729	`{`
		4730	`shape sa = sh(arg1);`
		4731	`int sz = shape_size(sa);`
		4732	`shape usa = (sz==8)?ucharsh:(sz==16)?uwordsh:(sz==32)?ulongsh:u64sh;`
		4733	`exp d1 = me_startid(sa,`
		4734	`hold_check(f_change_variety(f_wrap, usa,arg1)), 0);`
		4735	`exp d2 = me_startid(sa, arg2, 0);`
		4736	`exp d3 = me_startid(sa,`
		4737	`hold_check(f_shift_left(f_impossible, me_obtain(d1),`
		4738	`me_obtain(d2))), 0);`
		4739	`exp d4 = me_startid(sa,`
		4740	`hold_check(f_minus(f_impossible, me_shint(sh(arg2), sz),`
		4741	`me_obtain(d2)))`
		4742	`, 0);`
		4743	`exp sr = hold_check(f_shift_right(me_obtain(d1), me_obtain(d4)));`
		4744	`exp orit = hold_check(f_or(sr, me_obtain(d3)));`
		4745	`exp corit = hold_check(f_change_variety(f_wrap, sa, orit));`
		4746	`return hold_check( me_complete_id(d1,`
		4747	`hold_check( me_complete_id(d2,`
		4748	`hold_check( me_complete_id(d3,`
		4749	`hold_check( me_complete_id(d4, corit))`
		4750	`)) )) ));`
		4751	`}`
		4752
		4753
		4754	`#endif`
		4755
		4756	`return me_b2(arg1, arg2, rotl_tag);`
		4757	`}`
		4758
		4759	`exp f_rotate_right`
		4760	`PROTO_N ( (arg1, arg2) )`
		4761	`PROTO_T ( exp arg1 X exp arg2 )`
		4762	`{`
		4763	`if (name(sh(arg1)) == bothd)`
		4764	`{ kill_exp(arg2,arg2); return arg1; }`
		4765	`if (name(sh(arg2)) == bothd)`
		4766	`{ kill_exp(arg1,arg1); return arg2; }`
		4767
		4768	`#if check_shape`
		4769	`if (!is_integer(sh(arg1)) \|\| !is_integer(sh(arg2)))`
		4770	`failer(CHSH_ROTR);`
		4771	`#endif`
		4772	`#if !has_rotate`
		4773	`return f_rotate_left(arg1,`
		4774	`hold_check(f_minus(f_impossible,`
		4775	`me_shint(sh(arg2), shape_size(sh(arg1))),`
		4776	`arg2)`
		4777	`));`
		4778	`#endif`
		4779
		4780	`return me_b2(arg1, arg2, rotr_tag);`
		4781	`}`
		4782
		4783
		4784
		4785	`exp f_sequence`
		4786	`PROTO_N ( (statements, result) )`
		4787	`PROTO_T ( exp_list statements X exp result )`
		4788	`{`
		4789	`exp r;`
		4790	`exp h = getexp(f_bottom, result, 0, statements.start,`
		4791	`nilexp, 0, statements.number, 0);`
		4792	`exp l = statements.end;`
		4793	`clear_exp_list(statements);`
		4794
		4795	`/* re-organise so that sequence lists do not get too long.`
		4796	`limit to MAX_ST_LENGTH */`
		4797	`if (statements.number == 0)`
		4798	`return result;`
		4799	`if (statements.number <= MAX_ST_LENGTH) {`
		4800	`setlast(l);`
		4801	`setbro(l, h);`
		4802	`r = getexp(sh(result), nilexp, 0, h, nilexp, 0, 0, seq_tag);`
		4803	`setfather (r, result);`
		4804	`return r;`
		4805	`}`
		4806	`else {`
		4807	`int num_bits = statements.number / MAX_ST_LENGTH;`
		4808	`int rest = statements.number - (num_bits*MAX_ST_LENGTH);`
		4809	`exp_list work;`
		4810	`exp_list res;`
		4811	`exp t = statements.start;`
		4812	`int i, j;`
		4813	`res = new_exp_list(num_bits+1);`
		4814	`if (rest == 0)`
		4815	`{`
		4816	`--num_bits;`
		4817	`rest = MAX_ST_LENGTH;`
		4818	`};`
		4819
		4820	`for (i = 0; i < num_bits; ++i)`
		4821	`{`
		4822	`work.start = t;`
		4823	`work.number = MAX_ST_LENGTH;`
		4824	`for (j = 0; j < (MAX_ST_LENGTH-1); ++j)`
		4825	`t = bro(t);`
		4826	`work.end = t;`
		4827	`t = bro(t);`
		4828	`res = add_exp_list(res,`
		4829	`hold_check(f_sequence(work, f_make_top())),`
		4830	`i);`
		4831	`};`
		4832
		4833	`work.start = t;`
		4834	`work.end = l;`
		4835	`work.number = rest;`
		4836	`res = add_exp_list(res,`
		4837	`hold_check(f_sequence(work, f_make_top())),`
		4838	`num_bits);`
		4839	`return f_sequence(res, result);`
		4840	`};`
		4841	`}`
		4842
		4843	`exp f_shape_offset`
		4844	`PROTO_N ( (s) )`
		4845	`PROTO_T ( shape s )`
		4846	`{`
		4847
		4848	`return getexp(f_offset(f_alignment(s), long_to_al(1)),`
		4849	`nilexp, 0,`
		4850	`nilexp, nilexp,`
		4851	`0, shape_size(s), val_tag);`
		4852	`}`
		4853
		4854	`exp f_shift_left`
		4855	`PROTO_N ( (ov_err, arg1, arg2) )`
		4856	`PROTO_T ( error_treatment ov_err X exp arg1 X exp arg2 )`
		4857	`{`
		4858	`if (name(sh(arg1)) == bothd)`
		4859	`{ kill_exp(arg2,arg2); return arg1; }`
		4860	`if (name(sh(arg2)) == bothd)`
		4861	`{ kill_exp(arg1,arg1); return arg2; }`
		4862
		4863	`#if check_shape`
		4864	`if (!is_integer(sh(arg1)) \|\| !is_integer(sh(arg2)))`
		4865	`failer(CHSH_SHL);`
		4866	`#endif`
		4867	`#if !has64bits`
		4868	`if (name(sh(arg1)) >= s64hd &&`
		4869	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag\|\| ov_err.err_code > 2)) {`
		4870	`arg2 = hold_check(f_change_variety(ov_err, ulongsh, arg2));`
		4871	`return TDFcallop2(ov_err,arg1,arg2,shl_tag);`
		4872	`}`
		4873	`#endif`
		4874
		4875	`if (ov_err.err_code == 4)`
		4876	`{`
		4877	`exp d1 = me_startid(f_top, arg1, 0);`
		4878	`exp d2 = me_startid(f_top, arg2, 0);`
		4879	`exp d3 = me_startid(f_top,`
		4880	`hold_check(f_shift_left(f_impossible, me_obtain(d1),`
		4881	`me_obtain(d2))), 0);`
		4882	`exp_list el;`
		4883	`exp right = hold_check(f_shift_right(me_obtain(d3), me_obtain(d2)));`
		4884	`exp test = me_q1(no_nat_option, f_equal, ov_err.jmp_dest, right,`
		4885	`me_obtain(d1), test_tag);`
		4886	`el = new_exp_list(1);`
		4887	`el = add_exp_list(el, test, 1);`
		4888	`return me_complete_id(d1,`
		4889	`me_complete_id(d2,`
		4890	`me_complete_id(d3, f_sequence(el, me_obtain(d3)) )));`
		4891	`}`
		4892	`else`
		4893	`if (ov_err.err_code > 4) {`
		4894	`exp d1 = me_startid(f_top, arg1, 0);`
		4895	`exp d2 = me_startid(f_top, arg2, 0);`
		4896	`exp d3 = me_startid(f_top,`
		4897	`hold_check(f_shift_left(f_impossible, me_obtain(d1),`
		4898	`me_obtain(d2))), 0);`
		4899	`exp_list el;`
		4900	`exp right = hold_check(f_shift_right(me_obtain(d3), me_obtain(d2)));`
		4901	`exp trp = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0, f_overflow,`
		4902	`trap_tag);`
		4903	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		4904	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0, labst_tag);`
		4905	`exp test = me_q1(no_nat_option, f_equal, &lb, right,`
		4906	`me_obtain(d1), test_tag);`
		4907	`el = new_exp_list(1);`
		4908	`el = add_exp_list(el, test, 1);`
		4909	`return me_complete_id(d1,`
		4910	`me_complete_id(d2,`
		4911	`me_complete_id(d3,`
		4912	`f_conditional(&lb, f_sequence(el, me_obtain(d3)),trp) )));`
		4913
		4914	`};`
		4915
		4916	`return me_b1(ov_err, arg1, arg2, shl_tag);`
		4917	`}`
		4918
		4919	`exp f_shift_right`
		4920	`PROTO_N ( (arg1, arg2) )`
		4921	`PROTO_T ( exp arg1 X exp arg2 )`
		4922	`{`
		4923	`if (name(sh(arg1)) == bothd)`
		4924	`{ kill_exp(arg2,arg2); return arg1; }`
		4925	`if (name(sh(arg2)) == bothd)`
		4926	`{ kill_exp(arg1,arg1); return arg2; }`
		4927
		4928	`#if check_shape`
		4929	`if (!is_integer(sh(arg1)) \|\| !is_integer(sh(arg2)))`
		4930	`failer(CHSH_SHR);`
		4931	`#endif`
		4932	`#if !has64bits`
		4933	`if (name(sh(arg1)) >= s64hd &&`
		4934	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)) {`
		4935	`error_treatment ov_err;`
		4936	`ov_err = f_wrap;`
		4937	`arg2 = hold_check(f_change_variety(ov_err, ulongsh, arg2));`
		4938	`return TDFcallop2(ov_err,arg1,arg2,shr_tag);`
		4939	`}`
		4940	`#endif`
		4941	`return me_b2(arg1, arg2, shr_tag);`
		4942	`}`
		4943
		4944	`exp f_subtract_ptrs`
		4945	`PROTO_N ( (arg1, arg2) )`
		4946	`PROTO_T ( exp arg1 X exp arg2 )`
		4947	`{`
		4948	`if (name(sh(arg1)) == bothd)`
		4949	`{ kill_exp(arg2,arg2); return arg1; }`
		4950	`if (name(sh(arg2)) == bothd)`
		4951	`{ kill_exp(arg1,arg1); return arg2; }`
		4952	`return me_b3(f_offset(al1_of(sh(arg2)),`
		4953	`al1_of(sh(arg1))),`
		4954	`arg1, arg2, minptr_tag);`
		4955	`}`
		4956
		4957	`exp f_variable`
		4958	`PROTO_N ( (acc, name_intro, init, body) )`
		4959	`PROTO_T ( access_option acc X tag name_intro X exp init X exp body )`
		4960	`{`
		4961	`exp i = get_tag(name_intro);`
		4962	`exp d = son(i);`
		4963	`UNUSED(acc); UNUSED(init);`
		4964	`setsh(i, sh(body));`
		4965	`setbro(d, body);`
		4966	`clearlast(d);`
		4967	`setfather (i, body);`
		4968	`#ifdef NEWDIAGS`
		4969	`if (doing_mark_scope) /* must be reading old diags */`
		4970	`correct_mark_scope (i);`
		4971	`#endif`
		4972	`return i;`
		4973	`}`
		4974
		4975	`void start_variable`
		4976	`PROTO_N ( (acc, name_intro, init) )`
		4977	`PROTO_T ( access_option acc X tag name_intro X exp init )`
		4978	`{`
		4979	`exp i = get_tag(name_intro);`
		4980	`if (i == nilexp \|\| son(i) != i) {`
		4981	`i = getexp(f_bottom, nilexp, 0, init, nilexp, 0,`
		4982	`0, ident_tag);`
		4983	`}`
		4984	`else { /* could have been already used in env_offset */`
		4985	`son(i) = init;`
		4986	`}`
		4987	`setvar(i);`
		4988	`if (acc & (f_visible \| f_long_jump_access))`
		4989	`{`
		4990	`setvis(i);`
		4991	`setenvoff(i);`
		4992	`}`
		4993	`else`
		4994	`if ((acc & f_no_other_read) && (acc & f_no_other_write))`
		4995	`setcaonly(i);`
		4996	`set_tag(name_intro, i);`
		4997
		4998	`return;`
		4999	`}`
		5000
		5001	`exp f_xor`
		5002	`PROTO_N ( (arg1, arg2) )`
		5003	`PROTO_T ( exp arg1 X exp arg2 )`
		5004	`{`
		5005	`if (name(sh(arg1)) == bothd)`
		5006	`{ kill_exp(arg2,arg2); return arg1; }`
		5007	`if (name(sh(arg2)) == bothd)`
		5008	`{ kill_exp(arg1,arg1); return arg2; }`
		5009
		5010	`#if check_shape`
		5011	`if (!eq_shape(sh(arg1), sh(arg2)) \|\| !is_integer(sh(arg1)))`
		5012	`failer(CHSH_XOR);`
		5013	`#endif`
		5014	`#if !has64bits`
		5015	`if (name(sh(arg1)) >= s64hd &&`
		5016	`(name(arg1)!=val_tag \|\| name(arg2) != val_tag)){`
		5017	`return TDFcallop3(arg1,arg2,xor_tag);`
		5018	`}`
		5019	`#endif`
		5020	`return me_b2( arg1, arg2, xor_tag);`
		5021	`}`
		5022
		5023	`void init_exp`
		5024	`PROTO_Z ()`
		5025	`{`
		5026	`freelist = nilexp;`
		5027	`exps_left = 0;`
		5028	`crt_labno = 0;`
		5029	`global_case = getexp(f_bottom, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		5030	`in_initial_value = 0;`
		5031	`initial_value_pp.proc_struct_result = nilexp;`
		5032	`initial_value_pp.has_alloca = 0;`
		5033	`initial_value_pp.proc_is_recursive = 0;`
		5034	`initial_value_pp.uses_crt_env = 0;`
		5035	`initial_value_pp.has_setjmp = 0;`
		5036	`initial_value_pp.uses_loc_address = 0;`
		5037	`initial_value_pp.proc_label_count = 0;`
		5038	`initial_value_pp.proc_struct_res = 0;`
		5039	`initial_value_pp.default_freq = default_freq;`
		5040	`initial_value_pp.proc_externs = 0;`
		5041	`initial_value_pp.in_proc_def = 0;`
		5042	`initial_value_pp.pushed = (proc_props*)0;`
		5043	`initial_value_pp.rep_make_proc = 0;`
		5044	`return;`
		5045	`}`
		5046
		5047	`exp f_dummy_exp;`
		5048
		5049	`exp f_return_to_label`
		5050	`PROTO_N ( (e) )`
		5051	`PROTO_T ( exp e )`
		5052	`{`
		5053	`has_lv = 1;`
		5054	`return me_u3(f_bottom, e, return_to_label_tag);`
		5055	`}`
		5056
		5057
		5058
		5059	`nat f_computed_nat`
		5060	`PROTO_N ( (arg) )`
		5061	`PROTO_T ( exp arg )`
		5062	`{`
		5063	`nat res;`
		5064	`if (name(arg) == val_tag)`
		5065	`{`
		5066	`if (extra_checks && constovf(arg))`
		5067	`failer(ILLNAT);`
		5068
		5069	`if (!isbigval(arg)) {`
		5070	`nat_issmall(res) = 1;`
		5071	`natint(res) = no(arg);`
		5072	`return res;`
		5073	`}`
		5074	`else {`
		5075	`nat_issmall(res) = 0;`
		5076	`natbig(res) = no(arg);`
		5077	`return res;`
		5078	`};`
		5079	`};`
		5080
		5081	`if (name(arg) == name_tag && !isvar(son(arg))) {`
		5082	`res = f_computed_nat(son(son(arg)));`
		5083	`kill_exp(arg, arg);`
		5084	`return res;`
		5085	`};`
		5086
		5087	`failer(ILLCOMPNAT);`
		5088	`nat_issmall(res) = 1;`
		5089	`natint(res) = 1;`
		5090	`return res;`
		5091	`}`
		5092
		5093	`nat f_make_nat`
		5094	`PROTO_N ( (n) )`
		5095	`PROTO_T ( tdfint n )`
		5096	`{`
		5097	`return n;`
		5098	`}`
		5099
		5100	`void init_nat`
		5101	`PROTO_Z ()`
		5102	`{`
		5103	`return;`
		5104	`}`
		5105
		5106	`nat f_dummy_nat;`
		5107
		5108	`void init_ntest`
		5109	`PROTO_Z ()`
		5110	`{`
		5111	`return;`
		5112	`}`
		5113
		5114	`void init_otagexp`
		5115	`PROTO_Z ()`
		5116	`{`
		5117	`return;`
		5118	`}`
		5119
		5120	`void init_procprops`
		5121	`PROTO_Z ()`
		5122	`{`
		5123	`return;`
		5124	`}`
		5125
		5126
		5127
		5128	`ntest f_dummy_ntest;`
		5129
		5130	`void init_rounding_mode`
		5131	`PROTO_Z ()`
		5132	`{`
		5133	`return;`
		5134	`}`
		5135
		5136	`rounding_mode f_dummy_rounding_mode;`
		5137
		5138	`shape f_bitfield`
		5139	`PROTO_N ( (bf_var) )`
		5140	`PROTO_T ( bitfield_variety bf_var )`
		5141	`{`
		5142	`return getshape(bf_var.has_sign, const_al1, const_al1,`
		5143	`BF_ALIGN, bf_var.bits, bitfhd);`
		5144
		5145	`}`
		5146
		5147	`shape f_compound`
		5148	`PROTO_N ( (off) )`
		5149	`PROTO_T ( exp off )`
		5150	`{`
		5151	`int sz;`
		5152	`if (name(off)==val_tag)`
		5153	`sz = no(off);`
		5154	`else`
		5155	`{failer(ILLCPDOFFSET);`
		5156	`sz = 0;`
		5157	`};`
		5158	`return getshape(0, const_al1, const_al1,`
		5159	`al1_of(sh(off)),`
		5160	`sz, cpdhd);`
		5161	`}`
		5162
		5163	`shape f_floating`
		5164	`PROTO_N ( (fv) )`
		5165	`PROTO_T ( floating_variety fv )`
		5166	`{`
		5167	`switch (fv)`
		5168	`{`
		5169	`case shrealfv:`
		5170	`return shrealsh;`
		5171	`case realfv:`
		5172	`return realsh;`
		5173	`case doublefv:`
		5174	`return doublesh;`
		5175	`case shcomplexfv:`
		5176	`return shcomplexsh;`
		5177	`case complexfv:`
		5178	`return complexsh;`
		5179	`case complexdoublefv:`
		5180	`return complexdoublesh;`
		5181	`};`
		5182	`return realsh;`
		5183	`}`
		5184
		5185	`shape f_integer`
		5186	`PROTO_N ( (var) )`
		5187	`PROTO_T ( variety var )`
		5188	`{`
		5189	`return var;`
		5190	`}`
		5191
		5192	`shape f_nof`
		5193	`PROTO_N ( (n, s) )`
		5194	`PROTO_T ( nat n X shape s )`
		5195	`{`
		5196	`if (doing_aldefs)`
		5197	`return s;`
		5198	`else {`
		5199	`int al = shape_align(s);`
		5200	`int sz = rounder (shape_size(s), al);`
		5201	`int nm = (int)name(s);`
		5202	`int nofsz = natint(n)*sz;`
		5203	`shape res;`
		5204	`if (name(s) == nofhd)`
		5205	`nm = ptno(s);`
		5206	`#if !has64bits`
		5207	`if (!nat_issmall(n))`
		5208	`failer(TOO_BIG_A_VECTOR);`
		5209	`#endif`
		5210	`if (name(s) == tophd) {`
		5211	`/* pathological - make it nof(0, char) */`
		5212	`res = getshape(0, const_al1, const_al1,align_of(ucharsh), 0, nofhd);`
		5213	`}`
		5214	`else`
		5215	`if (al == 1) {`
		5216	`if ( (sz &(sz-1)) != 0 && nofsz > BF_STORE_UNIT) {`
		5217	`IGNORE fprintf(stderr, "Warning: Bitfields of nof cannot all be variety enclosed \n");`
		5218	`}`
		5219	`if ((sz &(sz-1)) == 0 \|\| nofsz > BF_STORE_UNIT) {`
		5220	`shape news = containedshape(sz,1);`
		5221	`int nsz = shape_align(news);`
		5222	`int newn = rounder(nofsz, nsz);`
		5223	`res = getshape(0, const_al1, const_al1, align_of(news),`
		5224	`newn, nofhd);`
		5225	`}`
		5226	`else {`
		5227	`shape news = containedshape(nofsz,1);`
		5228	`res = getshape(0, const_al1, const_al1, align_of(news),`
		5229	`shape_size(news), cpdhd);`
		5230
		5231	`}`
		5232
		5233	`}`
		5234	`else {`
		5235	`res = getshape(0, const_al1, const_al1, align_of(s), nofsz, nofhd);`
		5236	`}`
		5237
		5238	`ptno(res) = nm; /* set the pt field of the shape to the`
		5239	`shapemacs.h hd identifier of the shape */`
		5240	`return res;`
		5241	`};`
		5242	`}`
		5243
		5244	`shape f_offset`
		5245	`PROTO_N ( (arg1, arg2) )`
		5246	`PROTO_T ( alignment arg1 X alignment arg2 )`
		5247	`{`
		5248	`/* use values pre-computed by init since we never alter shapes */`
		5249	`if (arg1->al.al_n != 1 \|\| arg2->al.al_n != 1 \|\|`
		5250	`arg1->al.sh_hd != 0 \|\| arg2->al.sh_hd != 0`
		5251	`\|\| arg1->al.al_val.al_frame !=0 \|\| arg2->al.al_val.al_frame != 0)`
		5252	`return getshape(0, arg1, arg2, OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5253
		5254	`/* use values pre-computed by init since we never alter shapes */`
		5255	`switch (arg1->al.al_val.al)`
		5256	`{`
		5257	`case 512:`
		5258	`switch (arg2->al.al_val.al)`
		5259	`{`
		5260	`case 512: return f_off512_512;`
		5261	`case 64: return f_off512_64;`
		5262	`case 32: return f_off512_32;`
		5263	`case 16: return f_off512_16;`
		5264	`case 8: return f_off512_8;`
		5265	`case 1: return f_off512_1;`
		5266	`default: failer(ILLOFF2); return f_off64_8;`
		5267	`};`
		5268	`case 64:`
		5269	`switch (arg2->al.al_val.al)`
		5270	`{`
		5271	`case 64: return f_off64_64;`
		5272	`case 32: return f_off64_32;`
		5273	`case 16: return f_off64_16;`
		5274	`case 8: return f_off64_8;`
		5275	`case 1: return f_off64_1;`
		5276	`default: failer(ILLOFF2); return f_off64_8;`
		5277	`};`
		5278	`case 32:`
		5279	`switch (arg2->al.al_val.al)`
		5280	`{`
		5281	`case 32: return f_off32_32;`
		5282	`case 16: return f_off32_16;`
		5283	`case 8: return f_off32_8;`
		5284	`case 1: return f_off32_1;`
		5285	`default: failer(ILLOFF2); return f_off32_8;`
		5286	`};`
		5287	`case 16:`
		5288	`switch (arg2->al.al_val.al)`
		5289	`{`
		5290	`case 16: return f_off16_16;`
		5291	`case 8: return f_off16_8;`
		5292	`case 1: return f_off16_1;`
		5293	`default: failer(ILLOFF2); return f_off16_8;`
		5294	`};`
		5295	`case 8:`
		5296	`switch (arg2->al.al_val.al)`
		5297	`{`
		5298	`case 8: return f_off8_8;`
		5299	`case 1: return f_off8_1;`
		5300	`default: failer(ILLOFF2); return f_off8_8;`
		5301	`};`
		5302	`case 1:`
		5303	`switch (arg2->al.al_val.al)`
		5304	`{`
		5305	`case 1: return f_off1_1;`
		5306	`default: failer(ILLOFF2); return f_off1_1;`
		5307	`};`
		5308	`default: failer(ILLOFF1); return f_off8_8;`
		5309	`};`
		5310	`}`
		5311
		5312	`static shape frame_ptrs[32];`
		5313
		5314	`static struct SAL{alignment al; shape ptr_sh; struct SAL * rest;} * cache_pashs;`
		5315
		5316	`shape f_pointer`
		5317	`PROTO_N ( (arg) )`
		5318	`PROTO_T ( alignment arg )`
		5319	`{`
		5320	`/* use values pre-computed by init since we never alter shapes */`
		5321	`int af = arg->al.al_val.al_frame;`
		5322	`if (arg->al.al_n != 1 && af == 0)`
		5323	`return getshape(0, arg, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5324	`if (af != 0) {`
		5325	`if (frame_ptrs[af] == (shape)0) {`
		5326	`frame_ptrs[af] =`
		5327	`getshape(0, arg, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5328	`}`
		5329	`return frame_ptrs[af];`
		5330	`}`
		5331	`if (arg->al.sh_hd !=0) {`
		5332	`struct SAL * c = cache_pashs;`
		5333	`shape res;`
		5334	`while (c != (struct SAL*)0) {`
		5335	`if (arg == c->al) return c->ptr_sh;`
		5336	`c = c->rest;`
		5337	`}`
		5338	`res = getshape(0, arg, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5339	`c = (struct SAL*)xmalloc(sizeof(struct SAL));`
		5340	`c->al = arg; c->ptr_sh = res; c->rest = cache_pashs;`
		5341	`cache_pashs = c;`
		5342	`return res;`
		5343	`}`
		5344
		5345	`switch (arg->al.al_val.al)`
		5346	`{`
		5347	`case 1: return f_ptr1;`
		5348	`case 8: return f_ptr8;`
		5349	`case 16: return f_ptr16;`
		5350	`case 32: return f_ptr32;`
		5351	`case 64: return f_ptr64;`
		5352	`default: failer(ILLALIGN); return f_ptr8;`
		5353	`};`
		5354	`}`
		5355
		5356	`shape f_proc;`
		5357
		5358	`void init_shape`
		5359	`PROTO_Z ()`
		5360	`{`
		5361	`/* pre-compute values for use in f_pointer and f_offset */`
		5362
		5363	`int i;`
		5364	`for(i=0; i<32; i++) frame_ptrs[i] = (shape)0;`
		5365	`cache_pashs = (struct SAL*)0;`
		5366
		5367	`f_bottom = getshape(0, const_al1, const_al1, const_al1, 0, bothd);`
		5368
		5369	`f_top = getshape(0, const_al1, const_al1, TOP_ALIGN, TOP_SZ, tophd);`
		5370
		5371	`f_proc = getshape(0, const_al1, const_al1, PROC_ALIGN, PROC_SZ, prokhd);`
		5372
		5373	`f_ptr1 = getshape(0, const_al1, const_al1, PTR_ALIGN, PTRBIT_SZ, ptrhd);`
		5374
		5375	`f_ptr8 = getshape(0, const_al8, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5376	`f_local_label_value = f_ptr8;`
		5377
		5378	`f_ptr16 = getshape(0, const_al16, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5379
		5380	`f_ptr32 = getshape(0, const_al32, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5381
		5382	`f_ptr64 = getshape(0, const_al64, const_al1, PTR_ALIGN, PTR_SZ, ptrhd);`
		5383
		5384	`f_off1_1 = getshape(1, const_al1, const_al1,`
		5385	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5386
		5387	`f_off0_0 = getshape(1, const_al1, const_al1,`
		5388	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5389
		5390	`f_off8_8 = getshape(1, const_al8, const_al8,`
		5391	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5392
		5393	`f_off8_1 = getshape(1, const_al8, const_al1,`
		5394	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5395
		5396	`f_off16_16 = getshape(1, const_al16, const_al16,`
		5397	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5398
		5399	`f_off16_8 = getshape(1, const_al16, const_al8,`
		5400	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5401
		5402	`f_off16_1 = getshape(1, const_al16, const_al1,`
		5403	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5404
		5405	`f_off32_32 = getshape(1, const_al32, const_al32,`
		5406	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5407
		5408	`f_off32_16 = getshape(1, const_al32, const_al16,`
		5409	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5410
		5411	`f_off32_8 = getshape(1, const_al32, const_al8,`
		5412	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5413
		5414	`f_off32_1 = getshape(1, const_al32, const_al1,`
		5415	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5416
		5417	`f_off64_64 = getshape(1, const_al64, const_al64,`
		5418	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5419
		5420	`f_off64_32 = getshape(1, const_al64, const_al32,`
		5421	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5422
		5423	`f_off64_16 = getshape(1, const_al64, const_al16,`
		5424	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5425
		5426	`f_off64_8 = getshape(1, const_al64, const_al8,`
		5427	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5428
		5429	`f_off64_1 = getshape(1, const_al64, const_al1,`
		5430	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5431
		5432	`f_off512_512 = getshape(1, const_al512, const_al512,`
		5433	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5434
		5435	`f_off512_64 = getshape(1, const_al512, const_al64,`
		5436	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5437
		5438	`f_off512_32 = getshape(1, const_al512, const_al32,`
		5439	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5440
		5441	`f_off512_16 = getshape(1, const_al512, const_al16,`
		5442	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5443
		5444	`f_off512_8 = getshape(1, const_al512, const_al8,`
		5445	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5446
		5447	`f_off512_1 = getshape(1, const_al512, const_al1,`
		5448	`OFFSET_ALIGN, OFFSET_SZ, offsethd);`
		5449
		5450	`return;`
		5451	`}`
		5452
		5453	`shape f_dummy_shape;`
		5454
		5455
		5456	`signed_nat f_computed_signed_nat`
		5457	`PROTO_N ( (arg) )`
		5458	`PROTO_T ( exp arg )`
		5459	`{`
		5460	`signed_nat res;`
		5461	`if (name(arg) == val_tag)`
		5462	`{`
		5463	`if (extra_checks && constovf(arg))`
		5464	`failer(ILLNAT);`
		5465
		5466	`if (!isbigval(arg)) {`
		5467	`snat_issmall(res) = 1;`
		5468	`if (!is_signed(sh(arg)))`
		5469	`{`
		5470	`snatneg(res) = 0;`
		5471	`snatint(res) = no(arg);`
		5472	`}`
		5473	`else`
		5474	`{if (no(arg) < 0)`
		5475	`{`
		5476	`snatneg(res) = 1;`
		5477	`snatint(res) = -no(arg);`
		5478	`}`
		5479	`else`
		5480	`{`
		5481	`snatneg(res) = 0;`
		5482	`snatint(res) = no(arg);`
		5483	`}`
		5484	`};`
		5485	`return res;`
		5486	`}`
		5487	`else {`
		5488	`snat_issmall(res) = 0;`
		5489	`snatneg(res) = (bool)(flptnos[no(arg)].sign == -1);`
		5490	`flptnos[no(arg)].sign = 1;`
		5491	`snatint(res) = no(arg);`
		5492	`return res;`
		5493	`};`
		5494	`};`
		5495
		5496	`if (name(arg) == name_tag && !isvar(son(arg))) {`
		5497	`res = f_computed_signed_nat(son(son(arg)));`
		5498	`kill_exp(arg, arg);`
		5499	`return res;`
		5500	`};`
		5501
		5502	`failer(ILLCOMPSNAT);`
		5503	`snat_issmall(res) = 1;`
		5504	`snatneg(res) = 0;`
		5505	`snatint(res) = 1;`
		5506	`return res;`
		5507	`}`
		5508
		5509	`signed_nat f_snat_from_nat`
		5510	`PROTO_N ( (neg, n) )`
		5511	`PROTO_T ( bool neg X nat n )`
		5512	`{`
		5513	`signed_nat res;`
		5514
		5515	`if (snat_issmall(n)) {`
		5516	`snatneg(res) = (bool)((natint(n) == 0) ? 0 : neg);`
		5517	`snat_issmall(res) = 1;`
		5518	`snatint(res) = natint(n);`
		5519	`return res;`
		5520	`}`
		5521
		5522	`snat_issmall(res) = 0;`
		5523	`snatbig(res) = natbig(n);`
		5524	`snatneg(res) = neg;`
		5525	`return res;`
		5526	`}`
		5527
		5528	`signed_nat f_make_signed_nat`
		5529	`PROTO_N ( (neg, n) )`
		5530	`PROTO_T ( tdfbool neg X tdfint n )`
		5531	`{`
		5532	`return f_snat_from_nat(neg, n);`
		5533	`}`
		5534
		5535	`void init_signed_nat`
		5536	`PROTO_Z ()`
		5537	`{`
		5538	`return;`
		5539	`}`
		5540
		5541	`signed_nat f_dummy_signed_nat;`
		5542
		5543	`string f_dummy_string;`
		5544
		5545	`void init_string`
		5546	`PROTO_Z ()`
		5547	`{`
		5548	`return;`
		5549	`}`
		5550
		5551	`string f_concat_string`
		5552	`PROTO_N ( (a1, a2) )`
		5553	`PROTO_T ( string a1 X string a2 )`
		5554	`{`
		5555	`int i;`
		5556	`string res;`
		5557	`if (a1.size != a2.size) {`
		5558	`failer("Concatenated strings have different unit size");`
		5559	`}`
		5560	`res.number = a1.number + a2.number;`
		5561	`res.size = a1.size;`
		5562	`if (res.size<=8) {`
		5563	`res.ints.chars = (char*)xcalloc(res.number+1, sizeof(char));`
		5564	`for (i=0; i<a1.number; i++)`
		5565	`res.ints.chars[i] = a1.ints.chars[i];`
		5566	`for (i=0; i<a2.number; i++)`
		5567	`res.ints.chars[i+a1.number] = a2.ints.chars[i];`
		5568	`res.ints.chars[res.number]=0;`
		5569	`}`
		5570	`else`
		5571	`if (res.size<=16) {`
		5572	`res.ints.shorts = (short*)xcalloc(res.number+1, sizeof(short));`
		5573	`for (i=0; i<a1.number; i++)`
		5574	`res.ints.shorts[i] = a1.ints.shorts[i];`
		5575	`for (i=0; i<a2.number; i++)`
		5576	`res.ints.shorts[i+a1.number] = a2.ints.shorts[i];`
		5577	`res.ints.shorts[res.number]=0;`
		5578	`}`
		5579	`else {`
		5580	`res.ints.longs = (int*)xcalloc(res.number+1, sizeof(int));`
		5581	`for (i=0; i<a1.number; i++)`
		5582	`res.ints.longs[i] = a1.ints.longs[i];`
		5583	`for (i=0; i<a2.number; i++)`
		5584	`res.ints.longs[i+a1.number] = a2.ints.longs[i];`
		5585	`res.ints.longs[res.number]=0;`
		5586	`}`
		5587	`return res;`
		5588	`}`
		5589
		5590	`string f_make_string`
		5591	`PROTO_N ( (s) )`
		5592	`PROTO_T ( tdfstring s )`
		5593	`{`
		5594	`return s;`
		5595	`}`
		5596
		5597	`tagshacc f_make_tagshacc`
		5598	`PROTO_N ( (sha, visible, tg_intro) )`
		5599	`PROTO_T ( shape sha X access_option visible X tag tg_intro )`
		5600	`{`
		5601	`tagshacc res;`
		5602	`res.sha = sha;`
		5603	`res.visible = visible;`
		5604	`res.tg = tg_intro;`
		5605	`return res;`
		5606	`}`
		5607
		5608	`void init_tagshacc`
		5609	`PROTO_Z ()`
		5610	`{`
		5611	`return;`
		5612	`}`
		5613
		5614	`transfer_mode f_dummy_transfer_mode;`
		5615
		5616	`transfer_mode f_add_modes`
		5617	`PROTO_N ( (md1, md2) )`
		5618	`PROTO_T ( transfer_mode md1 X transfer_mode md2 )`
		5619	`{`
		5620	`return md1 \| md2;`
		5621	`}`
		5622
		5623
		5624	`version f_user_info`
		5625	`PROTO_N ( (t) )`
		5626	`PROTO_T ( tdfident t )`
		5627	`{`
		5628	`version res;`
		5629	`UNUSED(t);`
		5630	`res.major_version = MAJOR_VERSION;`
		5631	`res.minor_version = MINOR_VERSION;`
		5632	`return res;`
		5633	`}`
		5634
		5635
		5636	`variety f_var_limits`
		5637	`PROTO_N ( (lower_bound, upper_bound) )`
		5638	`PROTO_T ( signed_nat lower_bound X signed_nat upper_bound )`
		5639	`{`
		5640	`unsigned int h;`
		5641	`unsigned int l;`
		5642
		5643	`if (!snat_issmall(lower_bound) \|\| !snat_issmall(upper_bound)) {`
		5644	`if (snatneg(lower_bound))`
		5645	`return s64sh;`
		5646	`else`
		5647	`return u64sh;`
		5648	`};`
		5649
		5650	`/* normalise the varieties to use only the six standard ones */`
		5651	`l = (unsigned int)(snatint(lower_bound));`
		5652	`/* these assume the length of unsigned int equals int */`
		5653	`h = (unsigned int)(snatint(upper_bound));`
		5654
		5655
		5656	`if (!snatneg(lower_bound))`
		5657	`{`
		5658	`if (h <= 255)`
		5659	`return ucharsh;`
		5660	`if (h <= 65535)`
		5661	`return uwordsh;`
		5662	`return ulongsh;`
		5663	`};`
		5664
		5665
		5666	`if (l <= 128 && h <= 127)`
		5667	`{`
		5668	`return scharsh;`
		5669	`};`
		5670	`if (l<= 32768 && h <= 32767)`
		5671	`{`
		5672	`return swordsh;`
		5673	`};`
		5674	`return slongsh;`
		5675	`}`
		5676
		5677	`variety f_var_width`
		5678	`PROTO_N ( (sig, bits) )`
		5679	`PROTO_T ( bool sig X nat bits )`
		5680	`{`
		5681	`int w = natint(bits);`
		5682	`if (sig) {`
		5683	`if (w <= 8)`
		5684	`return scharsh;`
		5685	`if (w <= 16)`
		5686	`return swordsh;`
		5687	`if (w <= 32)`
		5688	`return slongsh;`
		5689	`if (w <= 64)`
		5690	`return s64sh;`
		5691	`failer(WIDTH_ERROR);`
		5692	`return slongsh;`
		5693	`}`
		5694
		5695	`if (w <= 8)`
		5696	`return ucharsh;`
		5697	`if (w <= 16)`
		5698	`return uwordsh;`
		5699	`if (w <= 32)`
		5700	`return ulongsh;`
		5701	`if (w <= 64)`
		5702	`return u64sh;`
		5703	`failer(WIDTH_ERROR);`
		5704	`return ulongsh;`
		5705	`}`
		5706
		5707	`void init_variety`
		5708	`PROTO_Z ()`
		5709	`{`
		5710	`ucharsh = getshape(0, const_al1, const_al1, UCHAR_ALIGN, UCHAR_SZ, ucharhd);`
		5711	`scharsh = getshape(1, const_al1, const_al1, SCHAR_ALIGN, SCHAR_SZ, scharhd);`
		5712	`uwordsh = getshape(0, const_al1, const_al1, UWORD_ALIGN, UWORD_SZ, uwordhd);`
		5713	`swordsh = getshape(1, const_al1, const_al1, SWORD_ALIGN, SWORD_SZ, swordhd);`
		5714	`ulongsh = getshape(0, const_al1, const_al1, ULONG_ALIGN, ULONG_SZ, ulonghd);`
		5715	`slongsh = getshape(1, const_al1, const_al1, SLONG_ALIGN, SLONG_SZ, slonghd);`
		5716	`u64sh = getshape(0, const_al1, const_al1, U64_ALIGN, U64_SZ, u64hd);`
		5717	`s64sh = getshape(1, const_al1, const_al1, S64_ALIGN, S64_SZ, s64hd);`
		5718	`return;`
		5719	`}`
		5720
		5721	`variety f_dummy_variety;`
		5722
		5723	`version f_make_version`
		5724	`PROTO_N ( (major_version, minor_version) )`
		5725	`PROTO_T ( tdfint major_version X tdfint minor_version )`
		5726	`{`
		5727	`version res;`
		5728	`res.major_version = natint(major_version);`
		5729	`res.minor_version = natint(minor_version);`
		5730	`if (res.major_version >= 3)`
		5731	`newcode = 1;`
		5732	`else`
		5733	`newcode = 0;`
		5734	`return res;`
		5735	`}`
		5736
		5737	`version_props f_make_versions`
		5738	`PROTO_N ( (version_info) )`
		5739	`PROTO_T ( version_props version_info )`
		5740	`{`
		5741	`UNUSED(version_info);`
		5742	`return 0;`
		5743	`}`
		5744
		5745
		5746	`exp_list new_exp_list`
		5747	`PROTO_N ( (n) )`
		5748	`PROTO_T ( int n )`
		5749	`{`
		5750	`exp_list res;`
		5751	`UNUSED(n);`
		5752	`res.number = 0;;`
		5753	`res.start = nilexp;`
		5754	`res.end = nilexp;`
		5755
		5756	`return res;`
		5757	`}`
		5758
		5759	`exp_list add_exp_list`
		5760	`PROTO_N ( (list, elem, index) )`
		5761	`PROTO_T ( exp_list list X exp elem X int index )`
		5762	`{`
		5763	`UNUSED(index);`
		5764	`++list.number;`
		5765	`parked(elem) = 1;`
		5766	`if (list.start == nilexp)`
		5767	`{`
		5768	`list.start = elem;`
		5769	`list.end = elem;`
		5770	`setlast(elem);`
		5771	`bro(elem) = nilexp;`
		5772	`return list;`
		5773	`};`
		5774	`clearlast(list.end);`
		5775	`bro(list.end) = elem;`
		5776	`list.end = elem;`
		5777	`setlast(elem);`
		5778	`bro(elem) = nilexp;`
		5779	`return list;`
		5780	`}`
		5781
		5782	`caselim_list new_caselim_list`
		5783	`PROTO_N ( (n) )`
		5784	`PROTO_T ( int n )`
		5785	`{`
		5786	`UNUSED(n);`
		5787	`/* bro(global_case) = nilexp;`
		5788	`return 0;`
		5789	`*/`
		5790	`return nilexp;`
		5791	`}`
		5792
		5793	`caselim_list add_caselim_list`
		5794	`PROTO_N ( (list, elem, index) )`
		5795	`PROTO_T ( caselim_list list X caselim elem X int index )`
		5796	`{`
		5797	`/* see the documentation for the representation of cases */`
		5798	`exp ht;`
		5799	`int low;`
		5800	`int high;`
		5801	`exp lowval = getexp (slongsh, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
		5802	`/* UNUSED(list);`
		5803	`*/`
		5804	`UNUSED(index);`
		5805	`pt(lowval) = get_lab(elem.lab); /* label for this branch */`
		5806
		5807	`if (snat_issmall(elem.low)){`
		5808	`low = snatint(elem.low);`
		5809	`if (snatneg(elem.low))`
		5810	`low = - low;`
		5811	`}`
		5812	`else {`
		5813	`#if !has64bits`
		5814	`SET(low);`
		5815	`failer(TOO_BIG_A_CASE_ELEMENT);`
		5816	`#else`
		5817	`low = snatbig(elem.low);`
		5818	`if (snatneg(elem.low)) {`
		5819	`flpt z = new_flpt();`
		5820	`flt_copy(flptnos[low], &flptnos[z]);`
		5821	`low = z;`
		5822	`flptnos[low].sign = - flptnos[low].sign;`
		5823	`}`
		5824	`setbigval(lowval);`
		5825	`#endif`
		5826	`};`
		5827	`no(lowval) = low;`
		5828
		5829	`if (snat_issmall(elem.high)) {`
		5830	`high = snatint(elem.high);`
		5831	`if (snatneg(elem.high))`
		5832	`high = - high;`
		5833	`if (!isbigval(lowval) && high == low)`
		5834	`ht = nilexp;`
		5835	`else`
		5836	`ht = getexp (slongsh, nilexp, 1, nilexp, nilexp, 0, high, 0);`
		5837	`}`
		5838	`else {`
		5839	`#if !has64bits`
		5840	`SET(ht);`
		5841	`failer(TOO_BIG_A_CASE_ELEMENT);`
		5842	`#else`
		5843	`int lh_eq;`
		5844	`high = snatbig(elem.high);`
		5845	`if (snatneg(elem.high)) {`
		5846	`flpt z = new_flpt();`
		5847	`flt_copy(flptnos[high], &flptnos[z]);`
		5848	`high = z;`
		5849	`flptnos[high].sign = - flptnos[high].sign;`
		5850	`}`
		5851	`if (isbigval(lowval)) {`
		5852	`lh_eq = flt_cmp(flptnos[low], flptnos[high]);`
		5853	`}`
		5854	`else`
		5855	`lh_eq = 0;`
		5856
		5857	`if (!lh_eq) {`
		5858	`ht = getexp (slongsh, nilexp, 1, nilexp, nilexp, 0,`
		5859	`high, 0);`
		5860	`setbigval(ht);`
		5861	`}`
		5862	`else`
		5863	`ht = nilexp;`
		5864	`#endif`
		5865	`};`
		5866
		5867	`/* if (ht != nilexp && docmp_f((int)f_less_than, ht, lowval)){`
		5868	`retcell(lowval);`
		5869	`retcell(ht);`
		5870	`return 0;`
		5871	`}`
		5872	`*/`
		5873	`++no (son (pt(lowval))); /* record label use */`
		5874	`son(lowval) = ht;`
		5875	`/* case_item (lowval);`
		5876	`*/`
		5877	`bro(lowval) = list;`
		5878	`return lowval;`
		5879	`}`
		5880
		5881	`label_list new_label_list`
		5882	`PROTO_N ( (n) )`
		5883	`PROTO_T ( int n )`
		5884	`{`
		5885	`label_list res;`
		5886	`res.elems = (label *)xcalloc(n, sizeof(label));`
		5887	`res.number = n;`
		5888	`return res;`
		5889	`}`
		5890
		5891	`label_list add_label_list`
		5892	`PROTO_N ( (list, elem, index) )`
		5893	`PROTO_T ( label_list list X label elem X int index )`
		5894	`{`
		5895	`exp def;`
		5896	`exp labst;`
		5897	`def = getexp (f_top, nilexp, 0, nilexp, nilexp, 0, 0,`
		5898	`clear_tag);`
		5899	`labst = getexp (f_bottom, nilexp, 0, def, nilexp, 0, 0,`
		5900	`labst_tag);`
		5901	`fno(labst) = default_freq;`
		5902	`++proc_label_count;`
		5903	`set_lab(elem, labst);`
		5904	`list.elems[index] = elem;`
		5905	`return list;`
		5906	`}`
		5907
		5908	`tagshacc_list new_tagshacc_list`
		5909	`PROTO_N ( (n) )`
		5910	`PROTO_T ( int n )`
		5911	`{`
		5912	`tagshacc_list res;`
		5913	`res.size = 0;`
		5914	`res.id = nilexp;`
		5915	`res.last_id = nilexp;`
		5916	`res.last_def = nilexp;`
		5917	`res.number = n;`
		5918	`return res;`
		5919	`}`
		5920
		5921	`tagshacc_list add_tagshacc_list`
		5922	`PROTO_N ( (list, elem, index) )`
		5923	`PROTO_T ( tagshacc_list list X tagshacc elem X int index )`
		5924	`{`
		5925	`exp d = getexp(elem.sha, nilexp, 0, nilexp, nilexp, 0, 0, clear_tag);`
		5926	`exp i = getexp(f_bottom, list.last_id, 1, d, nilexp, 0, 0, ident_tag);`
		5927	`UNUSED(index);`
		5928	`set_tag(elem.tg, i);`
		5929	`if (list.id == nilexp)`
		5930	`list.id = i;`
		5931	`else`
		5932	`bro(list.last_def) = i;`
		5933	`list.last_def = d;`
		5934	`list.last_id = i;`
		5935	`if (elem.visible & (f_visible \| f_long_jump_access))`
		5936	`setvis(i);`
		5937	`if (elem.visible & f_out_par)`
		5938	`setoutpar(i);`
		5939	`setvar(i);`
		5940	`setparam(i);`
		5941	`return list;`
		5942	`}`
		5943
		5944	`version_list new_version_list`
		5945	`PROTO_N ( (n) )`
		5946	`PROTO_T ( int n )`
		5947	`{`
		5948	`UNUSED(n);`
		5949	`return 0;`
		5950	`}`
		5951
		5952	`static int version_printed = 0;`
		5953
		5954	`version_list add_version_list`
		5955	`PROTO_N ( (list, elem, index) )`
		5956	`PROTO_T ( version_list list X version elem X int index )`
		5957	`{`
		5958	`UNUSED(list); UNUSED(index);`
		5959	`if (global_version.major_version == 0)`
		5960	`global_version = elem;`
		5961
		5962	`if (elem.major_version != global_version.major_version) {`
		5963	`failer(WRONG_VERSION);`
		5964	`IGNORE fprintf(stderr, "This TDF has mixed versions\n");`
		5965	`};`
		5966
		5967	`if (report_versions) {`
		5968	`if (!version_printed) {`
		5969	`version_printed = 1;`
		5970	`IGNORE fprintf(stderr, "This TDF is composed from Capsules of the following versions:-\n");`
		5971	`};`
		5972	`IGNORE fprintf(stderr, "TDF Version %d.%d\n",`
		5973	`elem.major_version, elem.minor_version);`
		5974	`};`
		5975
		5976	`return 0;`
		5977	`}`
		5978
		5979	`version f_dummy_version;`
		5980
		5981	`access_option no_access_option = 0;`
		5982
		5983	`access_option yes_access_option`
		5984	`PROTO_N ( (acc) )`
		5985	`PROTO_T ( access acc )`
		5986	`{`
		5987	`return acc;`
		5988	`}`
		5989
		5990	`string_option no_string_option;`
		5991	`string_option yes_string_option`
		5992	`PROTO_N ( (s) )`
		5993	`PROTO_T ( string s )`
		5994	`{`
		5995	`string_option res;`
		5996	`res.val = s;`
		5997	`res.present = 1;`
		5998	`return res;`
		5999	`}`
		6000
		6001	`void init_string_option`
		6002	`PROTO_Z ()`
		6003	`{`
		6004	`no_string_option.present = 0;`
		6005	`}`
		6006
		6007
		6008	`tagacc_option no_tagacc_option;`
		6009	`tagacc_option yes_tagacc_option`
		6010	`PROTO_N ( (elem) )`
		6011	`PROTO_T ( tagacc elem )`
		6012	`{`
		6013	`tagacc_option res;`
		6014	`res.val = elem;`
		6015	`res.present = 1;`
		6016	`return res;`
		6017	`}`
		6018
		6019	`void init_tagacc_option`
		6020	`PROTO_Z ()`
		6021	`{`
		6022	`no_tagacc_option.present = 0;`
		6023	`return;`
		6024	`}`
		6025
		6026	`nat_option no_nat_option;`
		6027	`nat_option yes_nat_option`
		6028	`PROTO_N ( (n) )`
		6029	`PROTO_T ( nat n )`
		6030	`{`
		6031	`nat_option res;`
		6032	`res.val = n;`
		6033	`res.present = 1;`
		6034	`return res;`
		6035	`}`
		6036
		6037	`void init_nat_option`
		6038	`PROTO_Z ()`
		6039	`{`
		6040	`no_nat_option.present = 0;`
		6041	`return;`
		6042	`}`
		6043
		6044	`void init_tagacc`
		6045	`PROTO_Z ()`
		6046	`{`
		6047	`return;`
		6048	`}`
		6049
		6050	`tagacc f_make_tagacc`
		6051	`PROTO_N ( (tg, acc) )`
		6052	`PROTO_T ( tag tg X access_option acc )`
		6053	`{`
		6054	`tagacc res;`
		6055	`res.tg = tg;`
		6056	`res.visible = acc;`
		6057	`return res;`
		6058	`}`
		6059
		6060	`void init_transfer_mode`
		6061	`PROTO_Z ()`
		6062	`{`
		6063	`return;`
		6064	`}`
		6065
		6066	`void init_version_props`
		6067	`PROTO_Z ()`
		6068	`{`
		6069	`global_version.major_version = 0;`
		6070	`global_version.minor_version = 0;`
		6071	`return;`
		6072	`}`
		6073
		6074	`void init_version`
		6075	`PROTO_Z ()`
		6076	`{`
		6077	`return;`
		6078	`}`
		6079
		6080
		6081	`void init_access_option`
		6082	`PROTO_Z ()`
		6083	`{`
		6084	`return;`
		6085	`}`
		6086
		6087
		6088
		6089	`static int seq_n = 0;`
		6090
		6091	`char * init_NAME`
		6092	`PROTO_N ( (good_name) )`
		6093	`PROTO_T ( char * good_name )`
		6094	`{`
		6095	`char * prefix = "__I.TDF";`
		6096	`time_t t;`
		6097	`int i,j;`
		6098	`char * c;`
		6099	`char * res;`
		6100	`int sc; int sp; int sg;`
		6101	`t = time(NULL) + (time_t)(seq_n++);`
		6102	`c = asctime(localtime(&t));`
		6103	`sc = (int)strlen(c); sp = (int)strlen(prefix); sg = (int)strlen(good_name);`
		6104	`res = (char*)xcalloc(sc+sp+sg, sizeof(char));`
		6105	`for(i=0; i<sp; i++) res[i] = prefix[i];`
		6106	`for(j=0; j<sg; i++, j++) res[i] = good_name[j];`
		6107	`for(j=0; j<sc; j++) {`
		6108	`if(isalpha(c[j])\|\| isdigit(c[j]) ){ res[i] = c[j]; i++;}`
		6109	`}`
		6110	`res[i] = 0;`
		6111	`dynamic_init_proc = res;`
		6112	`return(res);`
		6113	`}`
		6114
		6115	`void start_initial_value`
		6116	`PROTO_Z ()`
		6117	`{`
		6118	`if (in_initial_value++ == 0) {`
		6119	`proc_props * real_pp = (proc_props*)0;`
		6120	`if (old_proc_props != (proc_props*)0) {`
		6121	`/* initial value in proc */`
		6122	`push_proc_props();`
		6123	`real_pp = old_proc_props;`
		6124	`}`
		6125	`old_proc_props = &initial_value_pp;`
		6126	`pop_proc_props();`
		6127	`old_proc_props = real_pp;`
		6128	`}`
		6129
		6130	`}`
		6131
		6132	`exp f_initial_value`
		6133	`PROTO_N ( (e) )`
		6134	`PROTO_T ( exp e )`
		6135	`{`
		6136	`if (--in_initial_value > 0) return e;`
		6137
		6138	`initial_value_pp.proc_struct_result = proc_struct_result;`
		6139	`initial_value_pp.has_alloca = has_alloca;`
		6140	`initial_value_pp.proc_is_recursive = proc_is_recursive;`
		6141	`initial_value_pp.uses_crt_env = uses_crt_env;`
		6142	`initial_value_pp.has_setjmp = has_setjmp;`
		6143	`initial_value_pp.uses_loc_address = uses_loc_address;`
		6144	`initial_value_pp.proc_label_count = proc_label_count;`
		6145	`initial_value_pp.proc_struct_res = proc_struct_res;`
		6146	`initial_value_pp.default_freq = default_freq;`
		6147	`initial_value_pp.proc_externs = proc_externs;`
		6148	`initial_value_pp.in_proc_def = in_proc_def;`
		6149	`initial_value_pp.pushed = old_proc_props;`
		6150	`initial_value_pp.rep_make_proc = rep_make_proc;`
		6151	`if (old_proc_props != (proc_props*)0) {`
		6152	`/* init was in a proc - must make new variable */`
		6153	`dec * my_def = make_extra_dec(make_local_name(), 1, 0,`
		6154	`me_u2(e, initial_value_tag), sh(e) );`
		6155	`exp crt_exp = my_def -> dec_u.dec_val.dec_exp;`
		6156	`pop_proc_props();`
		6157	`return f_contents(sh(e), me_obtain(crt_exp));`
		6158	`}`
		6159	`return me_u2(e, initial_value_tag);`
		6160	`}`
		6161
		6162	`void tidy_initial_values`
		6163	`PROTO_Z ()`
		6164	`{`
		6165	`dec * my_def = top_def;`
		6166	`exp_list initial_as;`
		6167	`exp_list prom_as;`
		6168	`char * good_name = (char*)0;`
		6169	`initial_as = new_exp_list(0);`
		6170	`prom_as = new_exp_list(0);`
		6171	`dynamic_init_proc = (char*) 0;`
		6172	`while (my_def != (dec*)0){`
		6173	`exp crt_exp = my_def -> dec_u.dec_val.dec_exp;`
		6174	`if (son(crt_exp) != nilexp && my_def -> dec_u.dec_val.extnamed) {`
		6175	`good_name = my_def -> dec_u.dec_val.dec_id;`
		6176	`}`
		6177	`if (son(crt_exp) != nilexp && name(son(crt_exp)) == initial_value_tag) {`
		6178	`/* accumulate assignments of initial values in one explist */`
		6179	`if (!(my_def -> dec_u.dec_val.dec_var)) { /* make sure its a variable */`
		6180	`exp p = pt(crt_exp);`
		6181	`setvar(crt_exp);`
		6182	`my_def -> dec_u.dec_val.dec_var = 1;`
		6183	`while(p != nilexp){`
		6184	`exp np = pt(p);`
		6185	`exp c =`
		6186	`hold_check(f_contents(sh(p), me_obtain(crt_exp)));`
		6187	`replace(p, c ,nilexp);`
		6188	`p = np;`
		6189	`}`
		6190	`}`
		6191	`{exp init = son(son(crt_exp));`
		6192	`exp new_init = f_make_value(sh(init));`
		6193	`if (good_name == (char*)0) {`
		6194	`good_name = my_def -> dec_u.dec_val.dec_id;`
		6195	`}`
		6196	`retcell(son(crt_exp));`
		6197	`son(crt_exp) = new_init;`
		6198	`bro(new_init) = crt_exp; setlast(new_init);`
		6199	`initial_as = add_exp_list(initial_as,`
		6200	`hold_check(f_assign(me_obtain(crt_exp), init)), 0);`
		6201	`}`
		6202	`}`
		6203	`if (do_prom && son(crt_exp) != nilexp && my_def -> dec_u.dec_val.dec_var`
		6204	`&& !is_comm (son(crt_exp))) {`
		6205	`/* accumulate assignments of non-zero initialisations in one explist */`
		6206	`exp init = son(crt_exp);`
		6207	`exp new_init = f_make_value(sh(init));`
		6208	`if (good_name == (char*)0) {`
		6209	`good_name = my_def -> dec_u.dec_val.dec_id;`
		6210	`}`
		6211	`if (name(init) == compound_tag \|\| name(init) == nof_tag \|\|`
		6212	`name(init) == concatnof_tag \|\| name(init) == ncopies_tag \|\|`
		6213	`name(init) == string_tag) {`
		6214	`dec * id_dec = make_extra_dec (make_local_name(), 0, 0, init, sh(init));`
		6215	`init = me_obtain(id_dec -> dec_u.dec_val.dec_exp);`
		6216	`}`
		6217	`son(crt_exp) = new_init;`
		6218	`no(new_init) = -1; /* we may need to distinguish for diags */`
		6219	`bro(new_init) = crt_exp; setlast(new_init);`
		6220	`prom_as = add_exp_list(prom_as,`
		6221	`hold_check(f_assign(me_obtain(crt_exp), init)), 0);`
		6222	`}`
		6223	`my_def = my_def->def_next;`
		6224	`}`
		6225	`if (initial_as.number != 0) { /* ie there are some dynamic initialisations */`
		6226	`exp prc;`
		6227	`dec * extra_dec;`
		6228	`tagshacc_list tsl;`
		6229
		6230	`exp ret = f_return(f_make_top());`
		6231	`exp seq = f_sequence(initial_as, ret);`
		6232	`tsl = new_tagshacc_list(0);`
		6233
		6234	`old_proc_props = &initial_value_pp; pop_proc_props();`
		6235	`old_proc_props = (proc_props*)0; rep_make_proc = 0; push_proc_props();`
		6236	`prc = f_make_proc(f_top, tsl, no_tagacc_option, seq);`
		6237	`/* prc has one visible param - hence looks like varargs */`
		6238	`if (do_prom) {`
		6239	`/* struct (proc, ptr) */`
		6240	`exp off_proc = hold_check (f_offset_zero (PROC_ALIGN));`
		6241	`exp off_ptr = hold_check (f_offset_pad (PTR_ALIGN,`
		6242	`hold_check (f_offset_add (copy (off_proc),`
		6243	`hold_check (f_shape_offset (f_proc))))));`
		6244	`shape str_sh = f_compound (hold_check (f_offset_add (copy (off_ptr),`
		6245	`hold_check (f_shape_offset (f_pointer (PROC_ALIGN))))));`
		6246	`dec * str_dec = make_extra_dec (make_local_name(), 1, 0,`
		6247	`f_make_value (str_sh), str_sh);`
		6248	`dec * prc_dec = make_extra_dec(make_local_name(), 0, 0, prc, f_proc);`
		6249	`exp prc_exp = prc_dec -> dec_u.dec_val.dec_exp;`
		6250	`exp str_exp = str_dec -> dec_u.dec_val.dec_exp;`
		6251	`exp list_exp = find_named_tg ("__PROM_init_list", f_pointer (f_alignment (str_sh)));`
		6252	`brog(list_exp) -> dec_u.dec_val.dec_var = 1;`
		6253	`setvar(list_exp);`
		6254	`prom_as = add_exp_list (prom_as,`
		6255	`hold_check (f_assign (f_add_to_ptr (me_obtain(str_exp), copy (off_proc)),`
		6256	`me_obtain(prc_exp))), 0);`
		6257	`prom_as = add_exp_list (prom_as,`
		6258	`hold_check (f_assign (f_add_to_ptr (me_obtain(str_exp), copy (off_ptr)),`
		6259	`f_contents (sh(list_exp), me_obtain(list_exp)))), 0);`
		6260	`prom_as = add_exp_list (prom_as,`
		6261	`hold_check (f_assign (me_obtain(list_exp), me_obtain(str_exp))), 0);`
		6262	`}`
		6263	`else`
		6264	`extra_dec = make_extra_dec(add_prefix(init_NAME(good_name)), 0, 1, prc, f_proc);`
		6265	`}`
		6266	`if (do_prom && prom_as.number != 0) { /* ie there are some prom initialisations */`
		6267	`exp prc;`
		6268	`dec * extra_dec;`
		6269	`tagshacc_list tsl;`
		6270
		6271	`exp ret = f_return(f_make_top());`
		6272	`exp seq = f_sequence(prom_as, ret);`
		6273	`tsl = new_tagshacc_list(0);`
		6274
		6275	`rep_make_proc = 0;`
		6276	`start_make_proc(f_top, tsl, no_tagacc_option);`
		6277	`prc = f_make_proc(f_top, tsl, no_tagacc_option, seq);`
		6278	`extra_dec = make_extra_dec(add_prefix(init_NAME(good_name)), 0, 1, prc, f_proc);`
		6279	`}`
		6280	`}`

Subversion Repositories tendra.SVN

(root)//branches/tendra5/src/installers/common/construct/install_fns.c – Rev 2