WebSVN – tendra.SVN – Blame – /trunk/src/installers/common/construct/flpt_fns.c

Rev	Author	Line No.	Line
2	7u83	1	`/*`
7	7u83	2	`* Copyright (c) 2002-2005 The TenDRA Project <http://www.tendra.org/>.`
		3	`* All rights reserved.`
		4	`*`
		5	`* Redistribution and use in source and binary forms, with or without`
		6	`* modification, are permitted provided that the following conditions are met:`
		7	`*`
		8	`* 1. Redistributions of source code must retain the above copyright notice,`
		9	`* this list of conditions and the following disclaimer.`
		10	`* 2. Redistributions in binary form must reproduce the above copyright notice,`
		11	`* this list of conditions and the following disclaimer in the documentation`
		12	`* and/or other materials provided with the distribution.`
		13	`* 3. Neither the name of The TenDRA Project nor the names of its contributors`
		14	`* may be used to endorse or promote products derived from this software`
		15	`* without specific, prior written permission.`
		16	`*`
		17	* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
		18	`* IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,`
		19	`* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR`
		20	`* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR`
		21	`* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,`
		22	`* EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,`
		23	`* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;`
		24	`* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,`
		25	`* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR`
		26	`* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF`
		27	`* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.`
		28	`*`
		29	`* $Id$`
		30	`*/`
		31	`/*`
2	7u83	32	`Crown Copyright (c) 1997`
		33
		34	`This TenDRA(r) Computer Program is subject to Copyright`
		35	`owned by the United Kingdom Secretary of State for Defence`
		36	`acting through the Defence Evaluation and Research Agency`
		37	`(DERA). It is made available to Recipients with a`
		38	`royalty-free licence for its use, reproduction, transfer`
		39	`to other parties and amendment for any purpose not excluding`
		40	`product development provided that any such use et cetera`
		41	`shall be deemed to be acceptance of the following conditions:-`
		42
		43	`(1) Its Recipients shall ensure that this Notice is`
		44	`reproduced upon any copies or amended versions of it;`
		45
		46	`(2) Any amended version of it shall be clearly marked to`
		47	`show both the nature of and the organisation responsible`
		48	`for the relevant amendment or amendments;`
		49
		50	`(3) Its onward transfer from a recipient to another`
		51	`party shall be deemed to be that party's acceptance of`
		52	`these conditions;`
		53
		54	`(4) DERA gives no warranty or assurance as to its`
		55	`quality or suitability for any purpose and DERA accepts`
		56	`no liability whatsoever in relation to any use to which`
		57	`it may be put.`
		58	`*/`
		59
		60
		61	`/**********************************************************************`
		62	$Author: release $
		63	$Date: 1998/01/17 15:55:47 $
		64	$Revision: 1.1.1.1 $
		65	$Log: flpt_fns.c,v $
		66	`* Revision 1.1.1.1 1998/01/17 15:55:47 release`
		67	`* First version to be checked into rolling release.`
		68	`*`
		69	`* Revision 1.1 1997/11/04 18:23:43 pwe`
		70	`* split install_fns with new flpt_fns`
		71	`*`
		72	`***********************************************************************/`
		73
		74
		75
7	7u83	76	`/* This file consists of the floating point and complex operations`
		77	`extracted from install_fns.c, to reduce compilation unit sizes */`
2	7u83	78
		79	`#include "config.h"`
		80	`#include <ctype.h>`
		81	`#include <time.h>`
		82	`#include "common_types.h"`
		83	`#include "basicread.h"`
		84	`#include "exp.h"`
		85	`#include "expmacs.h"`
		86	`#include "main_reads.h"`
		87	`#include "tags.h"`
		88	`#include "flags.h"`
		89	`#include "me_fns.h"`
		90	`#include "installglob.h"`
		91	`#include "readglob.h"`
		92	`#include "table_fns.h"`
		93	`#include "flpttypes.h"`
		94	`#include "flpt.h"`
		95	`#include "xalloc.h"`
		96	`#include "shapemacs.h"`
		97	`#include "read_fns.h"`
		98	`#include "sortmacs.h"`
		99	`#include "machine.h"`
		100	`#include "spec.h"`
		101	`#include "check_id.h"`
		102	`#include "check.h"`
		103	`#include "szs_als.h"`
		104	`#include "messages_c.h"`
		105	`#include "natmacs.h"`
		106	`#include "f64.h"`
		107	`#include "readglob.h"`
		108	`#include "case_opt.h"`
		109	`#include "install_fns.h"`
		110	`#include "externs.h"`
		111
		112
		113	`extern shape shcomplexsh;`
		114	`extern shape complexsh;`
		115	`extern shape complexdoublesh;`
7	7u83	116	`exp_list reorder_list(exp_list, int);`
		117	`exp me_contents(exp);`
		118	`extern int eq_et(error_treatment, error_treatment);`
		119	`extern exp TDFcallaux(error_treatment, exp, char *, shape);`
		120	`extern exp find_named_tg(char *, shape);`
2	7u83	121
7	7u83	122	`static exp me_complete_chain(exp, exp, exp);`
		123	`static exp push(exp, exp);`
		124	`static void square_x_iy(error_treatment, exp , exp , exp);`
		125	`static void mult_w_by_z(error_treatment, exp , exp , exp, exp, exp);`
		126	`static exp make_comp_1_z(floating_variety, error_treatment, exp, exp, exp, exp,`
		127	`exp, exp);`
		128	`static exp f_bin_floating_plus(error_treatment, exp, exp);`
		129	`static exp f_bin_floating_mult(error_treatment, exp, exp);`
		130	`static exp real_power(error_treatment, exp, exp);`
2	7u83	131
		132
		133
7	7u83	134	`exp`
		135	`f_change_floating_variety(error_treatment flpt_err, floating_variety r,`
		136	`exp arg1)`
2	7u83	137	`{`
7	7u83	138	`if (name(sh(arg1)) == bothd) {`
2	7u83	139	`return arg1;`
7	7u83	140	`}`
2	7u83	141
		142	`#if check_shape`
7	7u83	143	`if (!((is_complex(sh(arg1)) && is_complex(f_floating(r))) \|\|`
		144	`(is_float(sh(arg1)) && is_float(f_floating(r))))) {`
2	7u83	145	`failer(CHSH_CHFL);`
7	7u83	146	`}`
2	7u83	147	`#endif`
7	7u83	148	`if (eq_shape(f_floating(r), sh(arg1))) { /* i.e. does nothing */`
2	7u83	149	`return arg1; /* Discard the other bits ? */`
7	7u83	150	`}`
2	7u83	151
		152	`#if substitute_complex`
7	7u83	153	`if (is_complex(sh(arg1))) {`
2	7u83	154	`shape complex_shape = sh(arg1);`
7	7u83	155	`floating_variety real_fv = f_float_of_complex(f_floating(r));`
2	7u83	156
7	7u83	157	`exp c1 = me_startid(complex_shape, arg1, 0);`
2	7u83	158
		159	`exp obtain1_c1 = me_obtain(c1); /* contents of arg1 */`
		160	`exp obtain2_c1 = me_obtain(c1);`
		161
7	7u83	162	`exp x = f_real_part(obtain1_c1); /* re(arg1) */`
		163	`exp y = f_imaginary_part(obtain2_c1); /* im(arg1) */`
2	7u83	164
7	7u83	165	`exp new_x = f_change_floating_variety(flpt_err, real_fv, x);`
		166	`exp new_y = f_change_floating_variety(flpt_err, real_fv, y);`
2	7u83	167
7	7u83	168	`exp make_comp = f_make_complex(r, new_x, new_y);`
		169	`c1 = me_complete_id(c1, make_comp); /* Does a 'hold_check' */`
2	7u83	170
		171	`return c1;`
7	7u83	172	`}`
2	7u83	173	`#endif /* substitute complex */`
		174
		175	`#if ishppa`
		176	`{`
		177	`exp t = me_c1(f_floating(r), flpt_err, arg1, chfl_tag);`
7	7u83	178	`if (!optop(t) && name(sh(t)) == doublehd) {`
		179	`exp id = me_startid(sh(t), t, 0);`
		180	`exp tmp = me_complete_id(id, me_obtain(id));`
2	7u83	181	`return tmp;`
7	7u83	182	`} else {`
		183	`return t;`
2	7u83	184	`}`
		185	`}`
		186	`#endif`
		187	`return me_c1(f_floating(r), flpt_err, arg1, chfl_tag);`
		188	`}`
		189
		190
		191
7	7u83	192	`exp`
		193	`f_complex_conjugate(exp arg1)`
2	7u83	194	`{`
7	7u83	195	`if (name(sh(arg1)) == bothd) {`
2	7u83	196	`return arg1;`
7	7u83	197	`}`
2	7u83	198	`#if check_shape`
7	7u83	199	`if (!is_complex(sh(arg1))) {`
2	7u83	200	`failer(CHSH_CONJUGATE);`
7	7u83	201	`}`
2	7u83	202	`#endif`
		203
		204	`#if substitute_complex`
		205	`{`
7	7u83	206	`shape complex_shape = sh(arg1); /* shape of our complex numbers */`
2	7u83	207	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		208	`shape real_shape = f_floating(real_fv);`
		209	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		210
		211	`exp c1 = me_startid(complex_shape, arg1, 0);`
		212
7	7u83	213	`exp obtain1_c1 = hold_check(me_obtain(c1)); /* contents of arg1 */`
2	7u83	214	`exp obtain2_c1 = hold_check(me_obtain(c1));`
		215
7	7u83	216	`exp x1 = f_real_part(obtain1_c1); /* re(arg1) */`
		217	`exp y1 = f_imaginary_part(obtain2_c1); /* im(arg1) */`
2	7u83	218
7	7u83	219	`exp neg_im = f_floating_negate(f_impossible, y1); /* - im(arg1) */`
2	7u83	220	`exp make_comp = f_make_complex(complex_fv, x1, neg_im);`
		221
		222	`c1 = me_complete_id(c1, make_comp);`
		223
		224	`return c1;`
		225	`}`
		226	`#else`
		227	`return me_u3(sh(arg1), arg1, conj_tag);`
		228	`#endif`
		229	`}`
		230
		231
		232
7	7u83	233	`exp`
		234	`f_float_int(error_treatment flpt_err, floating_variety f, exp arg1)`
2	7u83	235	`{`
7	7u83	236	`if (name(sh(arg1)) == bothd) {`
2	7u83	237	`return arg1;`
7	7u83	238	`}`
2	7u83	239
		240	`#if check_shape`
7	7u83	241	`if (!is_integer(sh(arg1))) {`
2	7u83	242	`failer(CHSH_FLINT);`
7	7u83	243	`}`
2	7u83	244	`#endif`
		245
		246	`if (is_complex(f_floating(f))) {`
		247	`flpt fzero_copy = new_flpt();`
		248	`floating_variety fv = f_float_of_complex(f_floating(f));`
		249	`shape real_shape = f_floating(fv);`
		250	`exp zero;`
		251	`exp res = f_float_int(flpt_err, fv, arg1);`
		252	`res = hold_check(res);`
7	7u83	253	`flt_copy(flptnos[fzero_no], &flptnos[fzero_copy]);`
		254	`zero = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fzero_copy,`
		255	`real_tag);`
2	7u83	256	`return f_make_complex(f, res, zero);`
		257	`}`
		258	`#if !has64bits`
7	7u83	259	`if ((name(arg1) != val_tag \|\| flpt_err.err_code > 2) &&`
		260	`shape_size(sh(arg1)) > 32) {`
2	7u83	261	`#if use_long_double`
7	7u83	262	`exp z = TDFcallaux(flpt_err, arg1, (is_signed(sh(arg1)) ?`
		263	`"__TDFUs_float" : "__TDFUu_float"),`
		264	`doublesh);`
2	7u83	265	`z = hold_check(z);`
		266	`if (f != doublefv) {`
		267	`z = me_c1(f_floating(f), flpt_err, z, chfl_tag);`
		268	`}`
		269	`return z;`
		270	`#else`
7	7u83	271	`exp z = TDFcallaux(flpt_err, arg1, (is_signed(sh(arg1)) ?`
		272	`"__TDFUs_float" : "__TDFUu_float"),`
		273	`realsh);`
2	7u83	274	`z = hold_check(z);`
		275	`if (f != realfv) {`
		276	`z = me_c1(f_floating(f), flpt_err, z, chfl_tag);`
		277	`}`
		278	`return z;`
		279	`#endif`
		280	`}`
		281	`#endif`
		282	`return me_c1(f_floating(f), flpt_err, arg1, float_tag);`
		283	`}`
		284
		285
7	7u83	286	`exp`
		287	`f_floating_abs(error_treatment ov_err, exp arg1)`
2	7u83	288	`{`
7	7u83	289	`if (name(sh(arg1)) == bothd) {`
2	7u83	290	`return arg1;`
7	7u83	291	`}`
2	7u83	292
		293	`#if check_shape`
7	7u83	294	`if (!is_float(sh(arg1))) {`
2	7u83	295	`failer(CHSH_FLABS);`
7	7u83	296	`}`
2	7u83	297	`#endif`
		298
		299	`#if ishppa`
		300	`{`
		301	`exp r = me_u1(ov_err, arg1, fabs_tag);`
7	7u83	302	`if (!optop(r) && name(sh(r)) == doublehd) {`
		303	`exp id = me_startid(sh(r), r, 0);`
		304	`exp tmp = me_complete_id(id, me_obtain(id));`
2	7u83	305	`return tmp;`
7	7u83	306	`} else {`
		307	`return r;`
2	7u83	308	`}`
		309	`}`
		310	`#endif`
		311	`return me_u1(ov_err, arg1, fabs_tag);`
		312	`}`
		313
		314
7	7u83	315	`exp`
		316	`f_floating_div(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	317	`{`
7	7u83	318	`if (name(sh(arg1)) == bothd) {`
		319	`kill_exp(arg2, arg2);`
		320	`return arg1;`
		321	`}`
		322	`if (name(sh(arg2)) == bothd) {`
		323	`kill_exp(arg1, arg1);`
		324	`return arg2;`
		325	`}`
2	7u83	326
		327	`#if check_shape`
7	7u83	328	`if (!((is_float(sh(arg1)) \|\| is_complex(sh(arg1))) &&`
		329	`eq_shape(sh(arg1), sh(arg2)))) {`
2	7u83	330	`failer(CHSH_FLDIV);`
7	7u83	331	`}`
2	7u83	332	`#endif`
		333
		334	`/* PAB changes - 21 October 1994 */`
		335	`#if substitute_complex`
		336	`if (is_complex(sh(arg1))) {`
		337
7	7u83	338	`shape complex_shape = sh(arg1); /* shape of our complex numbers */`
2	7u83	339	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		340	`shape real_shape = f_floating(real_fv);`
		341	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		342
		343	`exp z1 = me_startid(complex_shape, arg1, 0);`
		344	`exp z2 = me_startid(complex_shape, arg2, 0);`
		345
7	7u83	346	`exp obtain1_z1 = hold_check(me_obtain(z1)); /* contents of arg1 */`
2	7u83	347	`exp obtain2_z1 = hold_check(me_obtain(z1));`
7	7u83	348	`exp obtain1_z2 = hold_check(me_obtain(z2)); /* contents of arg2 */`
2	7u83	349	`exp obtain2_z2 = hold_check(me_obtain(z2));`
		350
7	7u83	351	`exp z1_re = f_real_part(obtain1_z1); /* re(arg1) */`
		352	`exp z2_re = f_real_part(obtain1_z2); /* re(arg2) */`
		353	`exp z1_im = f_imaginary_part(obtain2_z1); /* im(arg1) */`
		354	`exp z2_im = f_imaginary_part(obtain2_z2); /* im(arg2) */`
2	7u83	355
		356	`exp x1 = me_startid(real_shape, z1_re, 0);`
		357	`exp x2 = me_startid(real_shape, z2_re, 0);`
		358	`exp y1 = me_startid(real_shape, z1_im, 0);`
		359	`exp y2 = me_startid(real_shape, z2_im, 0);`
		360
7	7u83	361	`exp obtain1_x1 = hold_check(me_obtain(x1)); /* x1 is used twice */`
2	7u83	362	`exp obtain2_x1 = hold_check(me_obtain(x1));`
7	7u83	363	`exp obtain1_y1 = hold_check(me_obtain(y1)); /* y1 is used twice */`
2	7u83	364	`exp obtain2_y1 = hold_check(me_obtain(y1));`
		365
7	7u83	366	`exp obtain1_x2 = hold_check(me_obtain(x2)); /* x2 is used four times */`
2	7u83	367	`exp obtain2_x2 = hold_check(me_obtain(x2));`
		368	`exp obtain3_x2 = hold_check(me_obtain(x2));`
		369	`exp obtain4_x2 = hold_check(me_obtain(x2));`
7	7u83	370	`exp obtain1_y2 = hold_check(me_obtain(y2)); /* y2 is used four times */`
2	7u83	371	`exp obtain2_y2 = hold_check(me_obtain(y2));`
		372	`exp obtain3_y2 = hold_check(me_obtain(y2));`
		373	`exp obtain4_y2 = hold_check(me_obtain(y2));`
		374
		375	`exp mult_x2_x2 = f_bin_floating_mult(ov_err, obtain1_x2, obtain2_x2);`
		376	`exp mult_y2_y2 = f_bin_floating_mult(ov_err, obtain1_y2, obtain2_y2);`
		377	`exp mult_x1_x2 = f_bin_floating_mult(ov_err, obtain1_x1, obtain3_x2);`
		378	`exp mult_y1_y2 = f_bin_floating_mult(ov_err, obtain1_y1, obtain3_y2);`
		379	`exp mult_y1_x2 = f_bin_floating_mult(ov_err, obtain2_y1, obtain4_x2);`
		380	`exp mult_x1_y2 = f_bin_floating_mult(ov_err, obtain2_x1, obtain4_y2);`
		381
7	7u83	382	`exp plus1 = f_bin_floating_plus(ov_err, mult_x2_x2, mult_y2_y2);`
		383	`exp plus2 = f_bin_floating_plus(ov_err, mult_x1_x2, mult_y1_y2);`
2	7u83	384	`exp minus1 = f_floating_minus(ov_err, mult_y1_x2, mult_x1_y2);`
		385
		386	`exp denom = me_startid(real_shape, plus1, 0);`
		387
		388	`exp obtain_denom1 = hold_check(me_obtain(denom));`
		389	`exp obtain_denom2 = hold_check(me_obtain(denom));`
		390
7	7u83	391	`exp answer_re = f_floating_div(ov_err, plus2, obtain_denom1);`
2	7u83	392	`exp answer_im = f_floating_div(ov_err, minus1, obtain_denom2);`
		393	`exp make_comp = f_make_complex(complex_fv, answer_re, answer_im);`
		394
		395	`denom = me_complete_id(denom, make_comp);`
		396	`y2 = me_complete_id(y2, denom);`
		397	`y1 = me_complete_id(y1, y2);`
		398	`x2 = me_complete_id(x2, y1);`
		399	`x1 = me_complete_id(x1, x2);`
		400	`z2 = me_complete_id(z2, x1);`
		401	`z1 = me_complete_id(z1, z2);`
		402
		403	`return z1;`
7	7u83	404	`}`
2	7u83	405	`#endif`
		406	`#if ishppa`
		407	`{`
		408	`exp r = hold_check(me_b1(ov_err, arg1, arg2, fdiv_tag));`
7	7u83	409	`if (!optop(r) && name(sh(r)) == doublehd) {`
		410	`exp id = me_startid(sh(r), r, 0);`
		411	`exp tmp = me_complete_id(id, me_obtain(id));`
2	7u83	412	`return tmp;`
7	7u83	413	`} else {`
		414	`return r;`
2	7u83	415	`}`
		416	`}`
		417	`#endif`
7	7u83	418	`return hold_check(me_b1(ov_err, arg1, arg2, fdiv_tag));`
2	7u83	419	`}`
		420
		421
7	7u83	422	`exp`
		423	`f_floating_maximum(error_treatment flpt_err, exp arg1, exp arg2)`
2	7u83	424	`{`
7	7u83	425	`if (name(sh(arg1)) == bothd) {`
		426	`kill_exp(arg2, arg2);`
		427	`return arg1;`
		428	`}`
		429	`if (name(sh(arg2)) == bothd) {`
		430	`kill_exp(arg1, arg1);`
		431	`return arg2;`
		432	`}`
2	7u83	433
		434	`#if check_shape`
7	7u83	435	`if (!is_float(sh(arg1)) \|\| !eq_shape(sh(arg1), sh(arg2))) {`
2	7u83	436	`failer(CHSH_FLMAX);`
7	7u83	437	`}`
2	7u83	438	`#endif`
7	7u83	439	`return hold_check(me_b1(flpt_err, arg1, arg2, fmax_tag));`
2	7u83	440	`}`
		441
		442
7	7u83	443	`exp`
		444	`f_floating_minimum(error_treatment flpt_err, exp arg1, exp arg2)`
2	7u83	445	`{`
7	7u83	446	`if (name(sh(arg1)) == bothd) {`
		447	`kill_exp(arg2, arg2);`
		448	`return arg1;`
		449	`}`
		450	`if (name(sh(arg2)) == bothd) {`
		451	`kill_exp(arg1, arg1);`
		452	`return arg2;`
		453	`}`
2	7u83	454
		455
		456	`#if check_shape`
7	7u83	457	`if (!is_float(sh(arg1)) \|\| !eq_shape(sh(arg1), sh(arg2))) {`
2	7u83	458	`failer(CHSH_FLMIN);`
7	7u83	459	`}`
2	7u83	460	`#endif`
7	7u83	461	`return hold_check(me_b1(flpt_err, arg1, arg2, fmin_tag));`
2	7u83	462	`}`
		463
		464
		465
		466
		467	`/****************************************************************/`
		468	`/* The following code needs to generate labels for use with */`
		469	`/* 'cond_tag'. This is currently implemented using the */`
		470	`/* knowledge that a label can be obtained by taking a pointer */`
		471	`/* to an EXP - a hack which was introduced because of the */`
		472	`/* need to use 'f_integer_test' with 64-bit integers. This */`
		473	`/* hack is performed exclusively by the MACRO 'make_label' */`
		474	`/****************************************************************/`
		475
		476	`#define make_label(EXP) &EXP`
		477
		478
		479	`/************************************************/`
		480	`/* 'is_constant_arg' checks to see if E1 is */`
		481	`/* a constant that will fit into type 'int'. */`
		482	`/************************************************/`
		483
7	7u83	484	`#define is_constant_arg(E1)\`
2	7u83	485	`((name(E1) == val_tag) && !isbigval(E1) && \`
		486	`(is_signed(sh(E1)) \|\| (no(E1) >> 31 == 0)))`
		487
		488
		489
7	7u83	490	`exp`
		491	`f_floating_power(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	492	`{`
7	7u83	493	`if (name(sh(arg1)) == bothd) {`
		494	`kill_exp(arg2,arg2);`
		495	`return arg1;`
		496	`}`
		497	`if (name(sh(arg2)) == bothd) {`
		498	`kill_exp(arg1,arg1);`
		499	`return arg2;`
		500	`}`
2	7u83	501
		502	`#if check_shape`
7	7u83	503	`if (!((is_float(sh(arg1)) \|\| is_complex(sh(arg1))) &&`
		504	`is_integer(sh(arg2)))) {`
2	7u83	505	`failer(CHSH_FLPOWER);`
7	7u83	506	`}`
2	7u83	507	`#endif`
		508
		509	`/* PAB changes - 31 October 1994 */`
		510
		511	`/* Gives shorter .s file if n<10 and arg1 is unknown */`
		512
		513	`if (is_complex(sh(arg1))) {`
		514
		515	`shape integer_shape = sh(arg2);`
7	7u83	516	`shape complex_shape = sh(arg1); /* shape of our complex numbers */`
2	7u83	517	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		518	`shape real_shape = f_floating(real_fv);`
		519	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		520
		521	`exp sn = me_startid(integer_shape, arg2, 0);`
		522
		523	`if (is_constant_arg(arg2) \|\|`
		524	`((name(arg2) == name_tag) && (name(son(arg2)) == ident_tag)`
7	7u83	525	`&& !isvar(son(arg2)) && is_constant_arg(son(son(arg2))))) {`
		526	`/* we know the power */`
2	7u83	527	`int n;`
		528	`int exponent;`
7	7u83	529	`exp z = push(sn, me_startid(complex_shape, arg1, 0));`
2	7u83	530
		531	`if (is_constant_arg(arg2)) {`
		532	`exponent = no(arg2); /* arg2 is a constant */`
7	7u83	533	`} else {`
2	7u83	534	`exponent = no(son(son(arg2)));`
7	7u83	535	`/* arg2 identifies a constant */`
2	7u83	536	`}`
		537
		538	`n = abs(exponent);`
		539	`if (n == 0) {`
7	7u83	540	`exp answer_re, answer_im, make_comp;`
2	7u83	541
		542	`flpt fzero_copy = new_flpt();`
7	7u83	543	`flpt fone_copy = new_flpt();`
2	7u83	544
7	7u83	545	`flt_copy(flptnos[fzero_no], &flptnos[fzero_copy]);`
		546	`flt_copy(flptnos[fone_no], &flptnos[fone_copy]);`
2	7u83	547
7	7u83	548	`answer_re = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0,`
		549	`fone_copy, real_tag);`
		550	`answer_im = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0,`
		551	`fzero_copy, real_tag);`
2	7u83	552
		553	`make_comp = f_make_complex(complex_fv, answer_re, answer_im);`
7	7u83	554	`return me_complete_chain(z, arg2, make_comp);`
2	7u83	555	`} else {`
		556	`exp link_next;`
		557
7	7u83	558	`exp z_re = f_real_part(me_obtain(z));`
2	7u83	559	`exp z_im = f_imaginary_part(me_obtain(z));`
		560
7	7u83	561	`exp x = push(z, me_startid(real_shape, z_re, 0));`
		562	`exp y = push(x, me_startid(real_shape, z_im, 0));`
2	7u83	563
		564	`exp u, v, mylast;;`
		565
		566	`while ((n % 2) == 0) {`
		567	`mylast = y;`
		568	`square_x_iy(ov_err, &x, &y, mylast);`
		569	`n = n / 2;`
		570	`}`
		571
7	7u83	572	`if (n == 1) {`
		573	`/* return z */`
2	7u83	574	`if (exponent < 0) {`
		575	`link_next = make_comp_1_z(complex_fv, ov_err,`
7	7u83	576	`me_obtain(x), me_obtain(x),`
		577	`me_obtain(x), me_obtain(y),`
		578	`me_obtain(y), me_obtain(y));`
2	7u83	579	`} else {`
7	7u83	580	`link_next = f_make_complex(complex_fv, me_obtain(x),`
		581	`me_obtain(y));`
2	7u83	582	`}`
		583
7	7u83	584	`return me_complete_chain(y, arg2, link_next); /* return z */`
		585	`} else {`
		586	`/* w = z */`
		587	`u = push(y, me_startid(real_shape, me_obtain(x), 0));`
		588	`v = push(u, me_startid(real_shape, me_obtain(y), 0));`
2	7u83	589	`mylast = v;`
		590	`}`
		591
		592	`while (n != 1) {`
7	7u83	593	`/* z = zz /`
		594	`square_x_iy(ov_err, &x, &y, mylast);`
2	7u83	595	`mylast = y;`
		596	`n = n / 2;`
		597	`if ((n % 2) == 1) {`
7	7u83	598	`/* w = wz /`
		599	`mult_w_by_z (ov_err, &u, &v, x, y, mylast);`
2	7u83	600	`mylast = v;`
		601	`}`
		602	`}`
		603
		604	`if (exponent < 0) {`
		605	`link_next = make_comp_1_z(complex_fv, ov_err,`
7	7u83	606	`me_obtain(u), me_obtain(u),`
		607	`me_obtain(u), me_obtain(v),`
		608	`me_obtain(v), me_obtain(v));`
2	7u83	609	`} else {`
		610	`link_next = f_make_complex(complex_fv, me_obtain(u), me_obtain(v));`
		611	`}`
7	7u83	612	`/* return w */`
		613	`return me_complete_chain(v, arg2, link_next);`
2	7u83	614	`}`
		615	`} else {`
7	7u83	616	`/* main building blocks */`
		617	`exp reinitialise_w, main_loop, make_comp;`
		618	`exp square_z, mult_z_w, half_n, update_w, repeat_body;`
		619	`exp seq, seq_zero, make_comp1, make_comp2;`
		620	`exp real0, real1, x, y, u, v;`
2	7u83	621
7	7u83	622	`exp z = me_startid(complex_shape, arg1, 0);`
2	7u83	623
		624	`exp abs_val_sn = f_abs(ov_err, me_obtain(sn));`
		625	`exp n = me_startid(sh(sn), abs_val_sn, 1);`
		626
7	7u83	627	`exp z_re = f_real_part(me_obtain(z));`
2	7u83	628	`exp z_im = f_imaginary_part(me_obtain(z));`
		629
		630	`flpt fzero_copy = new_flpt();`
7	7u83	631	`flpt fone_copy = new_flpt();`
2	7u83	632
7	7u83	633	`flt_copy(flptnos[fzero_no], &flptnos[fzero_copy]);`
		634	`flt_copy(flptnos[fone_no], &flptnos[fone_copy]);`
2	7u83	635
7	7u83	636	`real0 = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fzero_copy,`
		637	`real_tag);`
		638	`real1 = getexp(real_shape, nilexp, 1, nilexp, nilexp, 0, fone_copy,`
		639	`real_tag);`
2	7u83	640
7	7u83	641	`x = me_startid(real_shape, z_re, 1); /* re(arg1) */`
		642	`y = me_startid(real_shape, z_im, 1); /* re(arg2) */`
2	7u83	643
7	7u83	644	`u = me_startid(real_shape, real1, 1); /* re(w) = 1.0 */`
		645	`v = me_startid(real_shape, real0, 1); /* im(w) = 0.0 */`
2	7u83	646
		647
		648	`/* change value of w to z if n is odd */`
		649
		650	`{`
7	7u83	651	`exp constant1 = me_shint(integer_shape, 1);`
		652	`exp constant2 = me_shint(integer_shape, 2);`
2	7u83	653
7	7u83	654	`exp rem_n_2 = f_rem0(f_impossible, f_impossible, me_contents(n),`
		655	`constant2);`
2	7u83	656
7	7u83	657	`exp assign_u = hold_check(me_b3(f_top, me_obtain(u),`
		658	`me_contents(x), ass_tag));`
		659	`exp assign_v = hold_check(me_b3(f_top, me_obtain(v),`
		660	`me_contents(y), ass_tag));`
2	7u83	661
7	7u83	662	`exp top_cell = me_l1(f_top, top_tag);`
		663	`exp alt_labst = hold_check(me_b3(sh(top_cell),`
		664	`me_null(f_top, 0, clear_tag),`
2	7u83	665	`top_cell, labst_tag));`
		666
7	7u83	667	`exp is_n_odd = f_integer_test(no_nat_option, f_equal,`
		668	`make_label(alt_labst), rem_n_2,`
		669	`constant1);`
2	7u83	670
		671	`exp seq_zero = hold_check(me_b2(is_n_odd, assign_u, 0));`
7	7u83	672	`exp seq = hold_check(me_b3(sh(assign_v), seq_zero, assign_v,`
		673	`seq_tag));`
2	7u83	674
7	7u83	675	`reinitialise_w = hold_check(me_b3(lub_shape(sh(seq),`
		676	`sh(alt_labst)),`
2	7u83	677	`seq, alt_labst, cond_tag));`
		678	`}`
		679
		680
		681	`/* z=zz /`
		682
		683	`{`
7	7u83	684	`exp minus_x_y = f_floating_minus(ov_err, me_contents(x),`
		685	`me_contents(y));`
		686	`exp plus_x_y = f_bin_floating_plus(ov_err, me_contents(x),`
		687	`me_contents(y));`
		688	`exp mult_x_y = f_bin_floating_mult(ov_err, me_contents(x),`
		689	`me_contents(y));`
2	7u83	690
		691	`exp tmp = me_startid(real_shape, mult_x_y, 0);`
		692
7	7u83	693	`exp answer_re = f_bin_floating_mult(ov_err, minus_x_y, plus_x_y);`
		694	`exp answer_im = f_bin_floating_plus(ov_err, me_obtain(tmp),`
		695	`me_obtain(tmp));`
2	7u83	696
7	7u83	697	`exp assign_x = hold_check(me_b3(f_top, me_obtain(x), answer_re,`
		698	`ass_tag));`
		699	`exp assign_y = hold_check(me_b3(f_top, me_obtain(y), answer_im,`
		700	`ass_tag));`
2	7u83	701
		702	`exp seq_zero = hold_check(me_u2(assign_x, 0));`
7	7u83	703	`exp seq = hold_check(me_b3(sh(assign_y), seq_zero, assign_y,`
		704	`seq_tag));`
2	7u83	705
		706	`square_z = me_complete_id(tmp, seq);`
		707	`}`
		708
		709
		710	`/* w=zw /`
		711	`{`
7	7u83	712	`exp mult_x_u = f_bin_floating_mult(ov_err, me_contents(x),`
		713	`me_contents(u));`
		714	`exp mult_x_v = f_bin_floating_mult(ov_err, me_contents(x),`
		715	`me_contents(v));`
		716	`exp mult_y_u = f_bin_floating_mult(ov_err, me_contents(y),`
		717	`me_contents(u));`
		718	`exp mult_y_v = f_bin_floating_mult(ov_err, me_contents(y),`
		719	`me_contents(v));`
2	7u83	720
		721	`exp tmp = me_startid(real_shape, mult_y_u, 0);`
		722
7	7u83	723	`exp answer_re = f_floating_minus(ov_err, mult_x_u, mult_y_v);`
		724	`exp answer_im = f_bin_floating_plus(ov_err, mult_x_v,`
		725	`me_obtain(tmp));`
2	7u83	726
7	7u83	727	`exp assign_u = hold_check(me_b3(f_top, me_obtain(u), answer_re,`
		728	`ass_tag));`
		729	`exp assign_v = hold_check(me_b3(f_top, me_obtain(v), answer_im,`
		730	`ass_tag));`
2	7u83	731
		732	`exp seq_zero = hold_check(me_u2(assign_u, 0));`
7	7u83	733	`exp seq = hold_check(me_b3(sh(assign_v), seq_zero, assign_v,`
		734	`seq_tag));`
2	7u83	735
		736	`mult_z_w = me_complete_id(tmp, seq);`
		737	`}`
		738
		739
7	7u83	740	`/* n = n / 2 */`
2	7u83	741
		742	`{`
7	7u83	743	`exp constant2 = me_shint(integer_shape, 2);`
2	7u83	744
7	7u83	745	`exp answer = f_div0(f_impossible, f_impossible, me_contents(n),`
		746	`constant2);`
2	7u83	747	`half_n = hold_check(me_b3(f_top, me_obtain(n), answer, ass_tag));`
		748	`}`
		749
		750
7	7u83	751	`/* if n is odd then w = z * w */`
2	7u83	752
		753	`{`
7	7u83	754	`exp constant1 = me_shint(integer_shape, 1);`
		755	`exp constant2 = me_shint(integer_shape, 2);`
2	7u83	756
7	7u83	757	`exp rem_n_2 = f_rem0(f_impossible, f_impossible, me_contents(n),`
		758	`constant2);`
2	7u83	759
7	7u83	760	`exp top_cell = me_l1(f_top, top_tag);`
		761	`exp alt_labst = hold_check(me_b3(f_top, me_null(f_top, 0,`
		762	`clear_tag),`
2	7u83	763	`top_cell, labst_tag));`
		764
7	7u83	765	`exp is_n_odd = f_integer_test(no_nat_option, f_equal,`
		766	`make_label(alt_labst), rem_n_2,`
		767	`constant1);`
2	7u83	768	`exp seq_zero = hold_check(me_u2(is_n_odd, 0));`
7	7u83	769	`exp seq = hold_check(me_b3(sh(mult_z_w), seq_zero, mult_z_w,`
		770	`seq_tag));`
2	7u83	771
7	7u83	772	`update_w = hold_check(me_b3(lub_shape(sh(seq), sh(alt_labst)),`
2	7u83	773	`seq, alt_labst, cond_tag));`
		774	`}`
		775
		776
		777	`/* repeat + body */`
		778
		779	`{`
		780	`exp if_n_equals_1, seq_zero, seq, body_labst;`
		781
7	7u83	782	`exp constant1 = me_shint(integer_shape, 1);`
		783	`exp top_cell = me_l1(f_top, top_tag);`
2	7u83	784
7	7u83	785	`body_labst = hold_check(me_b3(sh(top_cell),`
		786	`me_null(f_top, 0, clear_tag),`
		787	`top_cell, labst_tag));`
2	7u83	788
7	7u83	789	`if_n_equals_1 = f_integer_test(no_nat_option, f_equal,`
		790	`make_label(body_labst),`
		791	`me_contents(n), constant1);`
2	7u83	792
		793	`seq_zero = me_b2(square_z, update_w, 0);`
7	7u83	794	`setbro(square_z, half_n); /* insert half_n between */`
		795	`setbro(half_n, update_w); /* square_x and update_w */`
		796	`clearlast(half_n);`
2	7u83	797	`seq_zero = hold_check(seq_zero);`
		798
7	7u83	799	`seq = hold_check(me_b3(sh(if_n_equals_1), seq_zero,`
		800	`if_n_equals_1, seq_tag));`
2	7u83	801
		802	`setbro(son(body_labst), seq);`
		803	`clearlast(son(body_labst));`
		804	`setfather(body_labst, seq);`
		805
7	7u83	806	`repeat_body = hold_check(me_b3(sh(seq), top_cell, body_labst,`
		807	`rep_tag));`
2	7u83	808	`note_repeat(repeat_body);`
		809	`}`
		810
		811
		812	`/* make loop - only done if mod(n) > 1 */`
		813
		814	`{`
7	7u83	815	`exp constant1 = me_shint(integer_shape, 1);`
2	7u83	816
7	7u83	817	`exp top_cell = me_l1(f_top, top_tag);`
		818	`exp alt_labst = hold_check(me_b3(f_top,`
		819	`me_null(f_top, 0, clear_tag),`
2	7u83	820	`top_cell, labst_tag));`
		821
7	7u83	822	`exp is_n_gt_1 = f_integer_test(no_nat_option, f_greater_than,`
		823	`make_label(alt_labst),`
		824	`me_contents(n), constant1);`
2	7u83	825
		826	`exp seq_zero = hold_check(me_u2(is_n_gt_1, 0));`
7	7u83	827	`exp seq = hold_check(me_b3(sh(repeat_body), seq_zero,`
		828	`repeat_body, seq_tag));`
2	7u83	829
		830	`main_loop = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),`
		831	`seq, alt_labst, cond_tag));`
		832	`}`
		833
7	7u83	834	`make_comp1 = f_make_complex(complex_fv, me_contents(u),`
		835	`me_contents(v));`
		836	`make_comp2 = make_comp_1_z(complex_fv, ov_err, me_contents(u),`
		837	`me_contents(u), me_contents(u),`
		838	`me_contents(v), me_contents(v),`
		839	`me_contents(v));`
2	7u83	840
		841
		842	`/* if arg2 is negative then make_comp2 else make_comp1 */`
		843
		844	`{`
		845	`exp constant0 = me_shint(integer_shape, 0);`
		846
		847	`exp alt_labst = hold_check(me_b3(sh(make_comp1),`
7	7u83	848	`me_null(f_top, 0, clear_tag),`
2	7u83	849	`make_comp1, labst_tag));`
		850
7	7u83	851	`exp is_arg2_negative = f_integer_test(no_nat_option, f_less_than,`
		852	`make_label(alt_labst),`
		853	`me_obtain(sn), constant0);`
2	7u83	854
		855	`exp seq_zero = hold_check(me_u2(is_arg2_negative, 0));`
7	7u83	856	`exp seq = hold_check(me_b3(sh(make_comp2), seq_zero, make_comp2,`
		857	`seq_tag));`
2	7u83	858
		859	`make_comp = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),`
		860	`seq, alt_labst, cond_tag));`
		861	`}`
		862
		863	`seq_zero = hold_check(me_b2(reinitialise_w, main_loop, 0));`
7	7u83	864	`seq = hold_check(me_b3(sh(make_comp), seq_zero, make_comp, seq_tag));`
2	7u83	865
		866
7	7u83	867	`v = me_complete_id(v, seq);`
		868	`u = me_complete_id(u, v);`
		869	`y = me_complete_id(y, u);`
		870	`x = me_complete_id(x, y);`
		871	`n = me_complete_id(n, x);`
2	7u83	872	`sn = me_complete_id(sn, n);`
7	7u83	873	`z = me_complete_id(z, sn);`
2	7u83	874
		875	`return z;`
		876	`}`
		877	`}`
		878
7	7u83	879	`return real_power(ov_err, arg1, arg2);`
2	7u83	880	`}`
		881
		882
7	7u83	883	`exp`
		884	`f_floating_minus(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	885	`{`
7	7u83	886	`if (name(sh(arg1)) == bothd) {`
		887	`kill_exp(arg2, arg2);`
		888	`return arg1;`
		889	`}`
		890	`if (name(sh(arg2)) == bothd) {`
		891	`kill_exp(arg1,arg1);`
		892	`return arg2;`
		893	`}`
2	7u83	894
		895	`#if check_shape`
7	7u83	896	`if (!((is_float(sh(arg1)) \|\| is_complex(sh(arg1))) &&`
		897	`eq_shape(sh(arg1), sh(arg2)))) {`
2	7u83	898	`failer(CHSH_FLMINUS);`
7	7u83	899	`}`
2	7u83	900	`#endif`
		901
		902	`/* PAB changes - 18 October 1994 */`
		903	`#if substitute_complex`
		904	`if (is_complex(sh(arg1))) {`
7	7u83	905	`shape complex_shape = sh(arg1); /* shape of our complex numbers */`
2	7u83	906	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		907	`shape real_shape = f_floating(real_fv);`
		908	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		909
		910	`exp z1 = me_startid(complex_shape, arg1, 0);`
		911	`exp z2 = me_startid(complex_shape, arg2, 0);`
		912
7	7u83	913	`exp x1 = f_real_part(me_obtain(z1)); /* re(arg1) */`
		914	`exp x2 = f_real_part(me_obtain(z2)); /* re(arg2) */`
		915	`exp y1 = f_imaginary_part(me_obtain(z1)); /* im(arg1) */`
		916	`exp y2 = f_imaginary_part(me_obtain(z2)); /* im(arg2) */`
2	7u83	917
7	7u83	918	`exp minus_re = f_floating_minus(ov_err, x1, x2);`
		919	`exp minus_im = f_floating_minus(ov_err, y1, y2);`
2	7u83	920	`exp make_comp = f_make_complex(complex_fv, minus_re, minus_im);`
		921
		922	`z2 = me_complete_id(z2, make_comp);`
		923	`z1 = me_complete_id(z1, z2);`
		924
		925	`return z1;`
7	7u83	926	`}`
2	7u83	927	`#endif`
		928	`#if ishppa`
		929	`{`
		930	`exp r = hold_check(me_b1(ov_err, arg1, arg2, fminus_tag));`
7	7u83	931	`if (!optop(r) && name(sh(r)) == doublehd) {`
		932	`exp id = me_startid(sh(r), r, 0);`
		933	`exp tmp = me_complete_id(id, me_obtain(id));`
2	7u83	934	`return tmp;`
7	7u83	935	`} else {`
2	7u83	936	`return r;`
7	7u83	937	`}`
2	7u83	938	`}`
		939	`#endif`
7	7u83	940	`return hold_check(me_b1(ov_err, arg1, arg2, fminus_tag));`
2	7u83	941	`}`
		942
		943
7	7u83	944	`exp`
		945	`f_floating_mult(error_treatment ov_err, exp_list arg1)`
2	7u83	946	`{`
		947	`exp first = arg1.start;`
7	7u83	948	`exp r = getexp(sh(first), nilexp, 0, first, nilexp, 0, 0, fmult_tag);`
		949	`if (name(sh(first)) == bothd \|\| arg1.number == 1) {`
2	7u83	950	`return first;`
7	7u83	951	`}`
2	7u83	952	`clear_exp_list(arg1);`
		953	`seterrhandle(r, ov_err.err_code);`
7	7u83	954	`if (isov(r)) {`
		955	`setjmp_dest(r, get_lab(ov_err.jmp_dest));`
		956	`}`
2	7u83	957
		958	`#if check_shape`
7	7u83	959	`{`
		960	`exp t = first;`
		961	`while (1) {`
		962	`if (!((is_float(sh(t)) \|\| is_complex(sh(t))) &&`
		963	`eq_shape(sh(t), sh(first)))) {`
2	7u83	964	`failer(CHSH_FLMULT);`
7	7u83	965	`}`
		966	`if (t == arg1.end) {`
		967	`break;`
		968	`}`
		969	`t = bro(t);`
		970	`if (name(sh(t)) == bothd) {`
		971	`return t;`
		972	`}`
		973	`}`
		974	`}`
2	7u83	975	`#endif`
		976
		977	`/* PAB changes - 19 October 1994 */`
		978	`#if substitute_complex`
		979	`if (is_complex(sh(arg1.start))) {`
7	7u83	980	`shape complex_shape = sh(arg1.start); /* shape of our complex numbers */`
2	7u83	981	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		982	`shape real_shape = f_floating(real_fv);`
		983	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		984
7	7u83	985	`exp x1, y1, x2, y2, z1, z1_re, z1_im, t, link_next, prod_re, prod_im;`
2	7u83	986
		987	`#if 0`
7	7u83	988	`arg1 = reorder_list(arg1, 1); /* reorder so constants are at the front */`
2	7u83	989	`#endif`
		990
		991	`z1 = me_startid(complex_shape, arg1.start, 0);`
		992
7	7u83	993	`z1_re = f_real_part(me_obtain(z1)); /* re(arg1.first) */`
		994	`z1_im = f_imaginary_part(me_obtain(z1)); /* im(arg1.first) */`
2	7u83	995
		996	`x1 = push(z1, me_startid(real_shape, z1_re, 0));`
		997	`y1 = push(x1, me_startid(real_shape, z1_im, 0));`
		998
		999	`t = arg1.start;`
		1000
		1001	`while (t != arg1.end) {`
		1002	`t = bro(t);`
		1003	`z1 = push(y1, me_startid(complex_shape, t, 0));`
		1004
7	7u83	1005	`z1_re = f_real_part(me_obtain(z1)); /* contents of next */`
		1006	`z1_im = f_imaginary_part(me_obtain(z1)); /* list element */`
2	7u83	1007
		1008	`x2 = push(z1, me_startid(real_shape, z1_re, 0));`
		1009	`y2 = push(x2, me_startid(real_shape, z1_im, 0));`
		1010
		1011	`if (eq_exp(x1,x2) && eq_exp(y1,y2)) {`
7	7u83	1012	`exp minus_x1_x2 = f_floating_minus(ov_err, me_obtain(x1),`
		1013	`me_obtain(x2));`
		1014	`exp plus_x1_x2 = f_bin_floating_plus(ov_err, me_obtain(x1),`
		1015	`me_obtain(x2));`
		1016	`exp mult_x1_y1 = f_bin_floating_mult(ov_err, me_obtain(x1),`
		1017	`me_obtain(y1));`
2	7u83	1018
		1019	`prod_re = f_bin_floating_mult(ov_err, minus_x1_x2, plus_x1_x2);`
7	7u83	1020	`prod_im = f_bin_floating_plus(ov_err, mult_x1_y1, mult_x1_y1);`
		1021	`} else {`
		1022	`exp mult_x1_x2 = f_bin_floating_mult(ov_err, me_obtain(x1),`
		1023	`me_obtain(x2));`
		1024	`exp mult_y1_y2 = f_bin_floating_mult(ov_err, me_obtain(y1),`
		1025	`me_obtain(y2));`
		1026	`exp mult_x1_y2 = f_bin_floating_mult(ov_err, me_obtain(x1),`
		1027	`me_obtain(y2));`
		1028	`exp mult_x2_y1 = f_bin_floating_mult(ov_err, me_obtain(x2),`
		1029	`me_obtain(y1));`
2	7u83	1030
		1031	`prod_re = f_floating_minus(ov_err, mult_x1_x2, mult_y1_y2);`
		1032	`prod_im = f_bin_floating_plus(ov_err, mult_x1_y2, mult_x2_y1);`
		1033	`}`
		1034
		1035	`x1 = push(y2, me_startid(real_shape, prod_re, 0));`
		1036	`y1 = push(x1, me_startid(real_shape, prod_im, 0));`
		1037	`}`
		1038
		1039	`link_next = f_make_complex(complex_fv, me_obtain(x1), me_obtain(y1));`
		1040
7	7u83	1041	`return me_complete_chain(y1, arg1.start, link_next);`
2	7u83	1042	`}`
		1043	`#endif`
7	7u83	1044	`setfather(r, arg1.end);`
2	7u83	1045	`#if ishppa`
7	7u83	1046	`if (!optop(r) && name(sh(r)) == doublehd) {`
		1047	`exp id = me_startid(sh(r), r, 0);`
		1048	`exp tmp = me_complete_id(id, me_obtain(id));`
2	7u83	1049	`return tmp;`
7	7u83	1050	`} else`
2	7u83	1051	`#endif`
		1052	`return r;`
		1053	`}`
		1054
		1055
7	7u83	1056	`exp`
		1057	`f_floating_negate(error_treatment ov_err, exp arg1)`
2	7u83	1058	`{`
7	7u83	1059	`if (name(sh(arg1)) == bothd) {`
2	7u83	1060	`return arg1;`
7	7u83	1061	`}`
2	7u83	1062
		1063	`#if check_shape`
7	7u83	1064	`if (!is_float(sh(arg1)) && !is_complex(sh(arg1))) {`
2	7u83	1065	`failer(CHSH_FLNEGATE);`
7	7u83	1066	`}`
2	7u83	1067	`#endif`
		1068
		1069	`/* PAB changes - 18 October 1994 */`
		1070	`#if substitute_complex`
		1071	`if (is_complex(sh(arg1))) {`
7	7u83	1072	`shape complex_shape = sh(arg1); /* shape of our complex numbers */`
2	7u83	1073	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		1074	`shape real_shape = f_floating(real_fv);`
		1075	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		1076
		1077	`exp c1 = me_startid(complex_shape, arg1, 0);`
		1078
7	7u83	1079	`exp obtain1_c1 = hold_check(me_obtain(c1)); /* contents of arg1 */`
2	7u83	1080	`exp obtain2_c1 = hold_check(me_obtain(c1));`
		1081
7	7u83	1082	`exp x1 = f_real_part(obtain1_c1); /* re(arg1) */`
		1083	`exp y1 = f_imaginary_part(obtain2_c1); /* im(arg1) */`
2	7u83	1084
7	7u83	1085	`exp neg_re = f_floating_negate(ov_err, x1); /* - re(arg1) */`
		1086	`exp neg_im = f_floating_negate(ov_err, y1); /* - im(arg1) */`
2	7u83	1087	`exp make_comp = f_make_complex(complex_fv, neg_re, neg_im);`
		1088
		1089	`c1 = me_complete_id(c1, make_comp);`
		1090
		1091	`return c1;`
7	7u83	1092	`}`
2	7u83	1093	`#endif`
		1094	`#if ishppa`
		1095	`{`
		1096	`exp r = hold_check(me_u1(ov_err, arg1, fneg_tag));`
7	7u83	1097	`if (!optop(r) && name(sh(r)) == doublehd) {`
		1098	`exp id = me_startid(sh(r), r, 0);`
2	7u83	1099	`exp tmp = me_complete_id(id,me_obtain(id));`
		1100	`return tmp;`
7	7u83	1101	`} else {`
2	7u83	1102	`return r;`
7	7u83	1103	`}`
2	7u83	1104	`}`
		1105	`#endif`
7	7u83	1106	`return hold_check(me_u1(ov_err, arg1, fneg_tag));`
2	7u83	1107	`}`
		1108
		1109
7	7u83	1110	`exp`
		1111	`f_floating_plus(error_treatment ov_err, exp_list arg1)`
2	7u83	1112	`{`
		1113	`exp first = arg1.start;`
7	7u83	1114	`exp r = getexp(sh(first), nilexp, 0, first, nilexp, 0, 0, fplus_tag);`
		1115	`if (name(sh(first)) == bothd \|\| arg1.number == 1) {`
2	7u83	1116	`return first;`
7	7u83	1117	`}`
2	7u83	1118	`clear_exp_list(arg1);`
		1119	`seterrhandle(r, ov_err.err_code);`
7	7u83	1120	`if (isov(r)) {`
2	7u83	1121	`setjmp_dest(r, get_lab(ov_err.jmp_dest));`
7	7u83	1122	`}`
2	7u83	1123
		1124	`#if check_shape`
7	7u83	1125	`{`
		1126	`exp t = first;`
		1127	`while (1) {`
		1128	`if (!((is_float(sh(t)) \|\| is_complex(sh(t))) &&`
		1129	`eq_shape(sh(t), sh(first)))) {`
2	7u83	1130	`failer(CHSH_FLPLUS);`
7	7u83	1131	`}`
		1132	`if (t == arg1.end) {`
2	7u83	1133	`break;`
7	7u83	1134	`}`
		1135	`t = bro(t);`
		1136	`if (name(sh(t)) == bothd) {`
		1137	`return t;`
		1138	`}`
		1139	`}`
		1140	`}`
2	7u83	1141	`#endif`
		1142
		1143	`/* PAB changes - 18 October 1994 */`
		1144	`#if substitute_complex`
		1145	`if (is_complex(sh(arg1.start))) {`
		1146	`exp z1, z2, x1, y1, x2, y2, make_comp, t;`
		1147
7	7u83	1148	`shape complex_shape = sh(arg1.start); /* shape of our complex numbers */`
2	7u83	1149	`floating_variety real_fv = f_float_of_complex(complex_shape);`
		1150	`shape real_shape = f_floating(real_fv);`
		1151	`floating_variety complex_fv = f_complex_of_float(real_shape);`
		1152
		1153	`#if 0`
7	7u83	1154	`arg1 = reorder_list(arg1, 1); /* reorder so constants are at the front */`
2	7u83	1155	`#endif`
		1156
		1157	`z1 = me_startid(complex_shape, arg1.start, 0);`
		1158
7	7u83	1159	`x1 = f_real_part(me_obtain(z1)); /* re(arg1.first) */`
		1160	`y1 = f_imaginary_part(me_obtain(z1)); /* im(arg1.first) */`
2	7u83	1161
		1162	`t=arg1.start;`
7	7u83	1163	`z2 = z1; /* start chain of idents */`
2	7u83	1164
		1165	`while (t != arg1.end) {`
		1166	`t = bro(t);`
		1167	`z2 = push(z2, me_startid(complex_shape, t, 0));`
		1168
7	7u83	1169	`x2 = f_real_part(me_obtain(z2)); /* contents of next */`
		1170	`y2 = f_imaginary_part(me_obtain(z2)); /* list element */`
2	7u83	1171
7	7u83	1172	`x1 = f_bin_floating_plus(ov_err, x1, x2); /* pass it this on */`
		1173	`y1 = f_bin_floating_plus(ov_err, y1, y2); /* as new result */`
2	7u83	1174	`}`
		1175
		1176	`make_comp = f_make_complex(complex_fv, x1, y1);`
		1177
		1178	`return me_complete_chain(z2, arg1.start, make_comp);`
		1179	`}`
		1180	`#endif`
7	7u83	1181	`setfather(r, arg1.end);`
2	7u83	1182	`#if ishppa`
7	7u83	1183	`if (!optop(r) && name(sh(r)) == doublehd) {`
		1184	`exp id = me_startid(sh(r), r, 0);`
		1185	`exp tmp = me_complete_id(id, me_obtain(id));`
2	7u83	1186	`return tmp;`
7	7u83	1187	`} else`
2	7u83	1188	`#endif`
		1189	`return r;`
		1190	`}`
		1191
		1192
7	7u83	1193	`exp`
		1194	`f_floating_test(nat_option prob, error_treatment flpt_err, ntest nt,`
		1195	`label dest, exp arg1, exp arg2)`
2	7u83	1196	`{`
7	7u83	1197	`if (name(sh(arg1)) == bothd) {`
		1198	`kill_exp(arg2, arg2);`
		1199	`return arg1;`
		1200	`}`
		1201	`if (name(sh(arg2)) == bothd) {`
		1202	`kill_exp(arg1,arg1);`
		1203	`return arg2;`
		1204	`}`
2	7u83	1205
		1206	`#if check_shape`
7	7u83	1207	`if (!((is_float(sh(arg1)) \|\| is_complex(sh(arg1))) &&`
		1208	`eq_shape(sh(arg1), sh(arg2)))) {`
2	7u83	1209	`failer(CHSH_FLTEST);`
7	7u83	1210	`}`
2	7u83	1211	`#endif`
		1212
		1213	`/* PAB changes - 18 October 1994 */`
		1214	`#if substitute_complex`
7	7u83	1215	`if (is_complex(sh(arg1))) { /* is arg1 a complex number ? */`
2	7u83	1216
7	7u83	1217	`shape complex_shape = sh(arg1); /* shape of our complex numbers */`
2	7u83	1218	`exp z1 = me_startid(complex_shape, arg1, 0);`
		1219	`exp z2 = me_startid(complex_shape, arg2, 0);`
		1220
7	7u83	1221	`exp obtain1_z1 = hold_check(me_obtain(z1)); /* contents of arg1 */`
2	7u83	1222	`exp obtain2_z1 = hold_check(me_obtain(z1));`
7	7u83	1223	`exp obtain1_z2 = hold_check(me_obtain(z2)); /* contents of arg2 */`
2	7u83	1224	`exp obtain2_z2 = hold_check(me_obtain(z2));`
		1225
7	7u83	1226	`exp x1 = f_real_part(obtain1_z1); /* re(arg1) */`
		1227	`exp x2 = f_real_part(obtain1_z2); /* re(arg2) */`
		1228	`exp y1 = f_imaginary_part(obtain2_z1); /* im(arg1) */`
		1229	`exp y2 = f_imaginary_part(obtain2_z2); /* im(arg2) */`
2	7u83	1230
		1231	`#if check_shape`
		1232	`if ((nt != f_equal) && (nt != f_not_equal))`
		1233	`failer(CHSH_FLTEST);`
		1234	`#endif`
		1235
7	7u83	1236	`if (nt == f_equal) {`
		1237	`/* equality of z1 and z2 */`
		1238	`exp test1 = f_floating_test(prob, flpt_err, f_equal, dest, x1, x2);`
		1239	`exp test2 = f_floating_test(prob, flpt_err, f_equal, dest, y1, y2);`
2	7u83	1240
		1241	`exp seq_zero = hold_check(me_u2(test1, 0));`
7	7u83	1242	`exp seq = hold_check(me_b3(sh(test2), seq_zero, test2, seq_tag));`
		1243	`z2 = me_complete_id(z2, seq);`
		1244	`} else {`
		1245	`/* inequality of z1 and z2 */`
2	7u83	1246	`exp seq, conditional;`
		1247
		1248	`exp top_cell = me_l1(f_top, top_tag);`
7	7u83	1249	`exp alt_labst = hold_check(me_b3(f_top, me_null(f_top, 0, clear_tag),`
		1250	`top_cell, labst_tag));`
2	7u83	1251
7	7u83	1252	`exp test1 = f_floating_test(prob, flpt_err, f_equal,`
		1253	`make_label(alt_labst), x1, x2);`
		1254	`exp test2 = f_floating_test(prob, flpt_err, f_not_equal, dest, y1,`
		1255	`y2);`
2	7u83	1256	`exp seq_zero = hold_check(me_b2(test1, test2, 0));`
		1257
		1258	`seq = hold_check(me_b3(f_bottom, seq_zero, f_make_top(), seq_tag));`
		1259
7	7u83	1260	`conditional = hold_check(me_b3(f_top, seq, alt_labst, cond_tag));`
2	7u83	1261
		1262	`z2 = me_complete_id(z2, conditional);`
		1263	`}`
		1264	`z1 = me_complete_id(z1, z2);`
		1265
		1266	`return z1;`
		1267	`}`
		1268	`#endif`
		1269	`return me_q2(prob, flpt_err, nt, dest, arg1, arg2, test_tag);`
		1270	`}`
		1271
		1272
		1273
7	7u83	1274	`exp`
		1275	`f_imaginary_part(exp arg1)`
2	7u83	1276	`{`
		1277	`shape real_shape;`
		1278
7	7u83	1279	`if (name(sh(arg1)) == bothd) {`
2	7u83	1280	`return arg1;`
7	7u83	1281	`}`
2	7u83	1282	`#if check_shape`
7	7u83	1283	`if (!is_complex(sh(arg1))) {`
2	7u83	1284	`failer(CHSH_IMAG);`
7	7u83	1285	`}`
2	7u83	1286	`#endif`
		1287
		1288	`/* PAB changes - 25 May 1995 */`
		1289	`real_shape = f_floating(f_float_of_complex(sh(arg1)));`
		1290	`#if substitute_complex`
		1291	`{`
		1292	`exp t = me_u3(real_shape, arg1, field_tag);`
		1293	`no(t) = shape_size(real_shape);`
		1294	`return hold_check(t);`
		1295	`}`
		1296	`#else`
		1297	`return me_u3(real_shape, arg1, imag_tag);`
		1298	`#endif`
		1299	`}`
		1300
		1301
7	7u83	1302	`exp`
		1303	`f_real_part(exp arg1)`
2	7u83	1304	`{`
		1305	`shape real_shape;`
		1306
7	7u83	1307	`if (name(sh(arg1)) == bothd) {`
2	7u83	1308	`return arg1;`
7	7u83	1309	`}`
2	7u83	1310	`#if check_shape`
7	7u83	1311	`if (!is_complex(sh(arg1))) {`
2	7u83	1312	`failer(CHSH_REAL);`
7	7u83	1313	`}`
2	7u83	1314	`#endif`
		1315
		1316	`/* PAB changes - 25 May 1995 */`
		1317	`real_shape = f_floating(f_float_of_complex(sh(arg1)));`
		1318	`#if substitute_complex`
		1319	`{`
		1320	`exp t = me_u3(real_shape, arg1, field_tag);`
		1321	`no(t) = 0;`
		1322	`return hold_check(t);`
		1323	`}`
		1324	`#else`
		1325	`return me_u3(real_shape, arg1, realpart_tag);`
		1326	`#endif`
		1327	`}`
		1328
		1329
		1330
7	7u83	1331	`exp`
		1332	`f_make_complex(floating_variety f, exp arg1, exp arg2)`
2	7u83	1333	`{`
7	7u83	1334	`if (name(sh(arg1)) == bothd) {`
		1335	`kill_exp(arg2, arg2);`
		1336	`return arg1;`
		1337	`}`
		1338	`if (name(sh(arg2)) == bothd) {`
		1339	`kill_exp(arg1, arg1);`
		1340	`return arg2;`
		1341	`}`
2	7u83	1342
		1343	`#if check_shape`
		1344	`if (!is_float(sh(arg1)) \|\| !is_float(sh(arg2)) \|\|`
7	7u83	1345	`!eq_shape(sh(arg1), sh(arg2)) \|\| f != f_complex_of_float(sh(arg1))) {`
2	7u83	1346	`failer(CHSH_MAKE_COMPLEX);`
7	7u83	1347	`}`
2	7u83	1348	`#endif`
		1349
		1350
		1351	`/* PAB changes - 19 October 1994 */`
		1352	`#if substitute_complex`
		1353	`switch (f) {`
		1354	`case shcomplexfv:`
		1355	`{`
		1356	`shape off_set = f_offset(SHREAL_ALIGN, SHREAL_ALIGN);`
		1357	`exp val1 = me_shint(off_set, 0);`
		1358	`exp val2 = me_shint(off_set, SHREAL_SZ);`
		1359	`exp sz = me_shint(off_set, SHREAL_SZ + SHREAL_SZ);`
7	7u83	1360	`exp r = getexp(f_compound(sz), nilexp, 0, val1, nilexp, 0, 0,`
		1361	`compound_tag);`
2	7u83	1362
		1363	`setbro(val1, arg1);`
		1364	`clearlast(val1);`
		1365	`setbro(arg1, val2);`
		1366	`clearlast(arg1);`
		1367	`setbro(val2, arg2);`
		1368	`clearlast(val2);`
		1369	`setfather(r, arg2);`
		1370	`return hold_check(r);`
		1371	`}`
		1372	`case complexfv:`
		1373	`{`
		1374	`shape off_set = f_offset(REAL_ALIGN, REAL_ALIGN);`
		1375	`exp val1 = me_shint(off_set, 0);`
		1376	`exp val2 = me_shint(off_set, REAL_SZ);`
		1377	`exp sz = me_shint(off_set, REAL_SZ + REAL_SZ);`
7	7u83	1378	`exp r = getexp(f_compound(sz), nilexp, 0, val1, nilexp, 0, 0,`
		1379	`compound_tag);`
2	7u83	1380
		1381	`setbro(val1, arg1);`
		1382	`clearlast(val1);`
		1383	`setbro(arg1, val2);`
		1384	`clearlast(arg1);`
		1385	`setbro(val2, arg2);`
		1386	`clearlast(val2);`
		1387	`setfather(r, arg2);`
		1388	`return hold_check(r);`
		1389	`}`
		1390	`case complexdoublefv:`
		1391	`{`
		1392	`shape off_set = f_offset(DOUBLE_ALIGN, DOUBLE_ALIGN);`
		1393	`exp val1 = me_shint(off_set, 0);`
		1394	`exp val2 = me_shint(off_set, DOUBLE_SZ);`
		1395	`exp sz = me_shint(off_set, DOUBLE_SZ + DOUBLE_SZ);`
7	7u83	1396	`exp r = getexp(f_compound(sz), nilexp, 0, val1, nilexp, 0, 0,`
		1397	`compound_tag);`
2	7u83	1398
		1399	`setbro(val1, arg1);`
		1400	`clearlast(val1);`
		1401	`setbro(arg1, val2);`
		1402	`clearlast(arg1);`
		1403	`setbro(val2, arg2);`
		1404	`clearlast(val2);`
		1405	`setfather(r, arg2);`
		1406	`return hold_check(r);`
		1407	`}`
		1408	`default:`
		1409	`{`
		1410	`failer("Illegal floating_variety for make_complex_tag\n");`
		1411	`}`
		1412	`}`
		1413	`#endif`
7	7u83	1414	`return me_b3(f_floating(f), arg1, arg2, make_complex_tag);`
2	7u83	1415	`}`
		1416
		1417
		1418	`#if FBASE == 10`
		1419
7	7u83	1420	`exp`
		1421	`f_make_floating(floating_variety fv, rounding_mode rm, bool sign,`
		1422	`string mantissa, nat base, signed_nat expo)`
2	7u83	1423	`{`
		1424	`int ignore_zero = 1;`
		1425	`int lg = mantissa.number;`
7	7u83	1426	`flpt f = new_flpt();`
		1427	`int sig_digs = 0;`
		1428	`int i;`
2	7u83	1429	`int point = 0;`
		1430	`char ch;`
		1431	`int exponent = snatint(expo);`
		1432
7	7u83	1433	`if (PIC_code) {`
2	7u83	1434	`proc_externs = 1;`
7	7u83	1435	`}`
2	7u83	1436
7	7u83	1437	`if (snatneg(expo)) {`
2	7u83	1438	`exponent = - exponent;`
7	7u83	1439	`}`
2	7u83	1440
7	7u83	1441	`if (natint(base) != 10) {`
		1442	`failer(BASE_NOT_10);`
		1443	`}`
		1444	`for (i = 0; i < MANT_SIZE; ++i) {`
2	7u83	1445	`(flptnos[f].mant)[i] = 0;`
7	7u83	1446	`}`
2	7u83	1447
		1448	`for (i = 0; i < lg; ++i) {`
		1449	`ch = mantissa.ints.chars[i];`
		1450	`if (ch == '0' && ignore_zero) {`
7	7u83	1451	`if (point) {`
2	7u83	1452	`--exponent;`
7	7u83	1453	`}`
		1454	`} else {`
		1455	`if (ch == '.') {`
2	7u83	1456	`point = 1;`
7	7u83	1457	`} else {`
2	7u83	1458	`ignore_zero = 0;`
7	7u83	1459	`if (!point) {`
2	7u83	1460	`++exponent;`
7	7u83	1461	`}`
		1462	`if (sig_digs < MANT_SIZE) {`
		1463	`(flptnos[f].mant)[sig_digs++] = ch - '0';`
		1464	`}`
		1465	`}`
		1466	`}`
		1467	`}`
2	7u83	1468
		1469	`if (ignore_zero) {`
		1470	`flptnos[f].exp = 0;`
		1471	`flptnos[f].sign = 0;`
7	7u83	1472	`} else {`
2	7u83	1473	`flptnos[f].exp = exponent - 1;`
		1474	`flptnos[f].sign = (sign ? -1 : 1);`
7	7u83	1475	`}`
2	7u83	1476
7	7u83	1477	`if (flptnos[f].exp > target_dbl_maxexp) {`
		1478	`failer(BIG_FLPT);`
		1479	`}`
2	7u83	1480
7	7u83	1481	`return(getexp(f_floating(fv), nilexp, 0, nilexp, nilexp, 0, f, real_tag));`
2	7u83	1482
		1483	`}`
		1484
		1485	`#else`
		1486
7	7u83	1487	`exp`
		1488	`f_make_floating(floating_variety fv, rounding_mode rm, bool sign,`
		1489	`string mantissa, nat natbase, signed_nat expo)`
2	7u83	1490	`{`
		1491	`int ignore_zero = 1;`
		1492	`int lg = mantissa.number;`
7	7u83	1493	`flpt f = new_flpt();`
		1494	`int has_sig_digs = 0;`
		1495	`int i;`
2	7u83	1496	`int point = 0;`
		1497	`int exponent = snatint(expo);`
		1498	`flt fr;`
		1499	`int base = natint(natbase);`
		1500
		1501
		1502	`flt_zero(&fr);`
		1503
7	7u83	1504	`if (PIC_code) {`
2	7u83	1505	`proc_externs = 1;`
7	7u83	1506	`}`
2	7u83	1507
7	7u83	1508	`if (base != 10 && base != 16 && base !=8 && base != 2 && base != 4) {`
		1509	`failer(BAD_BASE);`
		1510	`}`
2	7u83	1511
7	7u83	1512	`if (snatneg(expo)) {`
		1513	`exponent =- exponent;`
		1514	`}`
2	7u83	1515
		1516	`for (i = 0; i < lg; ++i) {`
		1517	`char c = mantissa.ints.chars[i];`
		1518	`if (c != '0' \|\| !ignore_zero) {`
		1519	`ignore_zero = 0;`
7	7u83	1520	`if (c == '.') {`
2	7u83	1521	`point = 1;`
7	7u83	1522	`} else {`
2	7u83	1523	`c = c - '0';`
7	7u83	1524	`if (c != 0) {`
2	7u83	1525	`has_sig_digs = 1;`
7	7u83	1526	`}`
2	7u83	1527	`exponent -= point;`
		1528	`flpt_newdig((unsigned int)c, &fr, base);`
7	7u83	1529	`}`
		1530	`}`
		1531	`}`
2	7u83	1532
		1533	`if (ignore_zero) {`
		1534	`fr.exp = 0;`
		1535	`fr.sign = 0;`
7	7u83	1536	`} else {`
		1537	`if (has_sig_digs) {`
2	7u83	1538	`fr.sign = (sign ? -1 : 1);`
7	7u83	1539	`} else {`
2	7u83	1540	`fr.sign = 0;`
7	7u83	1541	`}`
2	7u83	1542	`flpt_scale(exponent, &fr, base);`
7	7u83	1543	`}`
2	7u83	1544
		1545
		1546	`flpt_round((int)rm, flpt_bits((floating_variety)fv), &fr);`
		1547
		1548	`if (flpt_const_overflow_fail) {`
		1549	`r2l r;`
		1550	`r = real2longs_IEEE(&fr, fv);`
		1551	`UNUSED(r);`
7	7u83	1552	`}`
2	7u83	1553
		1554	`flptnos[f] = fr;`
		1555
7	7u83	1556	`return(getexp(f_floating(fv), nilexp, 0, nilexp, nilexp, 0, f, real_tag));`
2	7u83	1557	`}`
		1558
		1559	`#endif`
		1560
		1561
		1562
7	7u83	1563	`exp`
		1564	`f_power(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	1565	`{`
7	7u83	1566	`if (name(sh(arg1)) == bothd) {`
		1567	`kill_exp(arg2,arg2);`
		1568	`return arg1;`
		1569	`}`
		1570	`if (name(sh(arg2)) == bothd) {`
		1571	`kill_exp(arg1,arg1);`
		1572	`return arg2;`
		1573	`}`
2	7u83	1574	`#if check_shape`
7	7u83	1575	`if (!is_integer(sh(arg1)) \|\| !is_integer(sh(arg2))) {`
2	7u83	1576	`failer(CHSH_POWER);`
7	7u83	1577	`}`
2	7u83	1578	`#endif`
		1579
7	7u83	1580	`return real_power(ov_err, arg1, arg2);`
2	7u83	1581	`}`
		1582
		1583
7	7u83	1584	`exp`
		1585	`f_round_with_mode(error_treatment flpt_err, rounding_mode mode, variety r,`
		1586	`exp arg1)`
2	7u83	1587	`{`
		1588	`exp res;`
7	7u83	1589	`if (name(sh(arg1)) == bothd) {`
2	7u83	1590	`return arg1;`
7	7u83	1591	`}`
2	7u83	1592	`if (is_complex(sh(arg1))) {`
		1593	`arg1 = f_real_part(arg1);`
		1594	`}`
		1595	`#if check_shape`
7	7u83	1596	`if (!is_float(sh(arg1))) {`
2	7u83	1597	`failer(CHSH_ROUND);`
7	7u83	1598	`}`
2	7u83	1599	`#endif`
		1600	`#if !has64bits`
7	7u83	1601	`if (shape_size(r) >32 &&`
		1602	`(name(arg1) != real_tag \|\| flpt_err.err_code >= 4)) {`
2	7u83	1603	`int s = is_signed(r);`
7	7u83	1604	`char *fn;`
2	7u83	1605	`exp e;`
		1606	`#if use_long_double`
7	7u83	1607	`arg1 = hold_check(f_change_floating_variety(f_impossible, 2,`
		1608	`arg1));`
2	7u83	1609	`#else`
7	7u83	1610	`arg1 = hold_check(f_change_floating_variety(f_impossible, 1,`
		1611	`arg1));`
2	7u83	1612	`#endif`
7	7u83	1613	`switch (mode) {`
		1614	`case R2NEAR:`
		1615	`fn = (s) ? "__TDFUs_R2NEAR" : "__TDFUu_R2NEAR";`
		1616	`break;`
		1617	`case R2PINF:`
		1618	`fn = (s) ? "__TDFUs_R2PINF" : "__TDFUu_R2PINF";`
		1619	`break;`
		1620	`case R2NINF:`
		1621	`fn = (s) ? "__TDFUs_R2NINF" : "__TDFUu_R2NINF";`
		1622	`break;`
		1623	`case R2ZERO:`
		1624	`fn = (s) ? "__TDFUs_R2ZERO" : "__TDFUu_R2ZERO";`
		1625	`break;`
		1626	`default:`
		1627	`fn = (s) ? "__TDFUs_ASSTATE" : "__TDFUu_R2ASSTATE";`
2	7u83	1628	`}`
		1629	`e = TDFcallaux(flpt_err, arg1, fn, r);`
7	7u83	1630	`return(hold_check(e));`
2	7u83	1631	`}`
		1632	`#endif`
		1633	`#if ismips`
		1634	`/* mips does not seem to get float->unsigned long right -`
7	7u83	1635	`so convert to signed long and adjust if too big*/`
		1636	`else if (name(arg1) != real_tag && shape_size(r) == 32 &&`
		1637	`!is_signed(r)) {`
		1638	`floating_variety fa = (shape_size(sh(arg1)) == 32) ? 0 : 1;`
2	7u83	1639	`exp_list st;`
		1640	`exp z;`
		1641	`exp d1 = me_startid(r, arg1, 0);`
		1642	`exp hldr = getexp(f_top, nilexp, 0, nilexp, nilexp, 0, 0, 0);`
7	7u83	1643	`exp lb = getexp(f_top, nilexp, 0, hldr, nilexp, 0, 0,`
		1644	`labst_tag);`
2	7u83	1645
		1646	`exp fmax = hold_check(f_float_int(f_impossible, fa,`
7	7u83	1647	`me_shint(ulongsh,`
		1648	`0x80000000)));`
2	7u83	1649	`exp d2 = me_startid(r, fmax, 0);`
7	7u83	1650	`exp tst = f_floating_test(no_nat_option, f_impossible,`
		1651	`f_less_than, &lb, me_obtain(d1),`
		1652	`me_obtain(d2));`
2	7u83	1653	`exp nconv = f_round_with_mode(flpt_err, mode, slongsh,`
7	7u83	1654	`me_obtain(d1));`
		1655	`exp first;`
		1656	`exp alt;`
		1657	`exp cnd;`
2	7u83	1658	`st = new_exp_list(1);`
		1659	`st = add_exp_list(st, tst, 0);`
		1660	`first = f_sequence(st, f_change_variety(flpt_err, r, nconv));`
		1661	`z = f_round_with_mode(flpt_err, mode, slongsh,`
7	7u83	1662	`f_floating_minus(f_impossible,`
		1663	`me_obtain(d1),`
		1664	`me_obtain(d2)));`
		1665	`alt = f_plus(f_impossible, f_change_variety(f_impossible, r, z),`
		1666	`me_shint(r, 0x80000000));`
2	7u83	1667	`cnd = f_conditional(&lb, first, alt);`
		1668	`return me_complete_id(d1, me_complete_id(d2, cnd));`
		1669
		1670	`}`
		1671	`#endif`
		1672	`#if ispower`
7	7u83	1673	`if (name(arg1) != real_tag \|\| flpt_err.err_code > 2) {`
		1674	`if (architecture != POWERPC_CODE) {`
		1675	`exp id;`
		1676	`exp apply1;`
		1677	`exp apply2;`
		1678	`long shp_sze = shape_size(f_integer(r));`
		1679	`bool sgned = is_signed(f_integer(r));`
		1680	`bool err = (flpt_err.err_code > 2);`
		1681	`char *nm;`
		1682	`char *nm_err;`
		1683	`int power_mode;`
		1684
		1685	`/* Set up ident to hold arg1 */`
		1686	`if (name(sh(arg1)) == shrealhd) {`
		1687	`arg1 = f_change_floating_variety(f_impossible, realfv, arg1);`
		1688	`}`
		1689	`id = me_startid(f_top, arg1, 0);`
		1690
		1691	`/* Set up power_mode */`
		1692	`switch (mode) {`
		1693	`case R2ZERO:`
		1694	`power_mode = 0;`
		1695	`break;`
		1696	`case R2NEAR:`
		1697	`power_mode = 1;`
		1698	`break;`
		1699	`case R2PINF:`
		1700	`power_mode = 2;`
		1701	`break;`
		1702	`case R2NINF:`
		1703	`power_mode = 3;`
		1704	`break;`
		1705	`default:`
		1706	`power_mode = 1;`
		1707	`break;`
		1708	`}`
		1709
		1710	`/* Work out which functions to call */`
		1711	`if (sgned) {`
		1712	`nm = "__TDFrnd_sgned";`
		1713	`nm_err = "__TDFerr_rnd_sgned";`
		1714	`} else {`
		1715	`nm = "__TDFrnd_unsgned";`
		1716	`nm_err = "__TDFerr_rnd_unsgned";`
		1717	`}`
		1718
		1719	`{`
		1720	`exp_list pars2;`
		1721	`exp_option no_var;`
		1722	`pars2 = new_exp_list(2);`
		1723	`no_var.present = 0;`
		1724	`pars2 = add_exp_list(pars2, me_obtain(id), 0);`
		1725	`pars2 = add_exp_list(pars2, me_shint(uwordsh, power_mode), 1);`
		1726	`apply2 = f_apply_proc(sgned ? slongsh : ulongsh,`
		1727	`me_obtain(find_named_tg(nm, f_proc)), pars2,`
		1728	`no_var);`
		1729	`}`
		1730
		1731	`if (err) {`
		1732	`exp_list st;`
		1733	`exp seq;`
		1734	`exp pl;`
		1735	`exp_list pars1;`
		1736	`exp_option no_var;`
		1737	`no_var.present = 0;`
		1738
		1739	`pars1 = new_exp_list(2);`
		1740	`pars1 = add_exp_list(pars1, me_obtain(id), 0);`
		1741	`pars1 = add_exp_list(pars1, me_shint(uwordsh, power_mode), 1);`
		1742	`apply1 = f_apply_proc(f_top, me_obtain(find_named_tg(nm_err, f_proc)),`
		1743	`pars1, no_var);`
		1744
		1745	`pl = f_plus(flpt_err, me_shint(slongsh, INT_MAX),`
		1746	`me_obtain(find_named_tg("__TDFrnd_error", slongsh)));`
		1747	`st = new_exp_list(2);`
		1748	`st = add_exp_list(st, apply1, 0);`
		1749	`st = add_exp_list(st, pl, 1);`
		1750	`seq = f_sequence(st, apply2);`
		1751	`id = me_complete_id(id, seq);`
		1752	`} else {`
		1753	`id = me_complete_id(id, apply2);`
		1754	`}`
		1755	`if (shp_sze < 32) {`
		1756	`id = f_change_variety(flpt_err, f_integer(r), id);`
		1757	`}`
		1758	`return id;`
		1759	`}/end ispower /`
2	7u83	1760	`}`
		1761	`/* FALL THROUGH */`
		1762	`#endif`
		1763
7	7u83	1764	`res = getexp(f_integer(r), nilexp, 0, arg1, nilexp, 0, 0, round_tag);`
2	7u83	1765	`setround_number(res, mode);`
		1766	`seterrhandle(res, flpt_err.err_code);`
7	7u83	1767	`if (flpt_err.err_code == 4) {`
2	7u83	1768	`setjmp_dest(res, get_lab(flpt_err.jmp_dest));`
7	7u83	1769	`}`
		1770	`setfather(res, arg1);`
2	7u83	1771	`return res;`
		1772	`}`
		1773
		1774
		1775
7	7u83	1776	`floating_variety`
		1777	`f_flvar_parms(nat base, nat mantissa_digits, nat minimum_exponent,`
		1778	`nat maximum_exponent)`
2	7u83	1779	`{`
		1780	`int b = natint(base);`
		1781	`int mantdig = natint(mantissa_digits);`
		1782	`int neg_minexp = natint(minimum_exponent);`
		1783	`int maxexp = natint(maximum_exponent);`
		1784
		1785	`while (b !=2) {`
		1786	`if ((b & 1) != 0) {`
		1787	`failer("base in flvar_parms must be a power of 2");`
		1788	`}`
		1789	`mantdig+=mantdig;`
		1790	`neg_minexp+=neg_minexp;`
		1791	`maxexp+=maxexp;`
7	7u83	1792	`b = (b >> 1);`
2	7u83	1793	`}`
		1794
7	7u83	1795	`if (mantdig <= 24 && neg_minexp <= 126 && maxexp <= 127) {`
		1796	`return(0);`
		1797	`}`
		1798	`if (mantdig <= 53 && neg_minexp <= 1022 && maxexp <= 1023) {`
		1799	`return(1);`
		1800	`}`
2	7u83	1801
		1802	`#if use_long_double`
7	7u83	1803	`if (mantdig <= 64 && neg_minexp <= 16382 && maxexp <= 16383) {`
		1804	`return(2);`
		1805	`}`
		1806	`return(2);`
2	7u83	1807	`#else`
		1808	`return 1;`
		1809	`#endif`
		1810	`}`
		1811
		1812
7	7u83	1813	`floating_variety`
		1814	`f_complex_parms(nat base, nat mantissa_digits, nat minimum_exponent,`
		1815	`nat maximum_exponent)`
2	7u83	1816	`{`
		1817	`return float_to_complex_var(f_flvar_parms(base, mantissa_digits,`
7	7u83	1818	`minimum_exponent,`
		1819	`maximum_exponent));`
2	7u83	1820	`}`
		1821
		1822
7	7u83	1823	`void`
		1824	`init_floating_variety(void)`
2	7u83	1825	`{`
7	7u83	1826	`shrealsh = getshape(0, const_al1, const_al1, SHREAL_ALIGN, SHREAL_SZ,`
		1827	`shrealhd);`
2	7u83	1828	`realsh = getshape(0, const_al1, const_al1, REAL_ALIGN, REAL_SZ, realhd);`
7	7u83	1829	`doublesh = getshape(0, const_al1, const_al1, DOUBLE_ALIGN, DOUBLE_SZ,`
		1830	`doublehd);`
2	7u83	1831	`#if substitute_complex`
7	7u83	1832	`shcomplexsh = getshape(0, const_al1, const_al1, SHREAL_ALIGN, 2 * SHREAL_SZ,`
		1833	`cpdhd);`
		1834	`complexsh = getshape(0, const_al1, const_al1, REAL_ALIGN, 2 * REAL_SZ, cpdhd);`
2	7u83	1835	`complexdoublesh = getshape(0, const_al1, const_al1, DOUBLE_ALIGN,`
7	7u83	1836	`2 * DOUBLE_SZ, cpdhd);`
2	7u83	1837	`#else`
7	7u83	1838	`shcomplexsh = getshape(0, const_al1, const_al1, SHREAL_ALIGN, 2 * SHREAL_SZ,`
		1839	`shcomplexhd);`
		1840	`complexsh = getshape(0, const_al1, const_al1, REAL_ALIGN, 2 * REAL_SZ,`
		1841	`complexhd);`
2	7u83	1842	`complexdoublesh = getshape(0, const_al1, const_al1, DOUBLE_ALIGN,`
7	7u83	1843	`2 * DOUBLE_SZ, complexdoublehd);`
2	7u83	1844	`#endif`
		1845	`return;`
		1846	`}`
		1847
		1848
		1849
		1850	`floating_variety f_dummy_floating_variety;`
		1851
7	7u83	1852	`floating_variety`
		1853	`f_float_of_complex(shape sha)`
2	7u83	1854	`{`
7	7u83	1855	`int s = shape_size(sha) / 2;`
		1856	`if (s == SHREAL_SZ) {`
		1857	`return shrealfv;`
		1858	`}`
		1859	`if (s == REAL_SZ) {`
		1860	`return realfv;`
		1861	`}`
		1862	`if (s == DOUBLE_SZ) {`
		1863	`return doublefv;`
		1864	`}`
2	7u83	1865	`failer("Expecting a complex shape");`
		1866
		1867	`return f_dummy_floating_variety;`
		1868	`}`
		1869
7	7u83	1870	`floating_variety`
		1871	`f_complex_of_float(shape sha)`
2	7u83	1872	`{`
		1873	`int s = shape_size(sha);`
7	7u83	1874	`if (s == SHREAL_SZ) {`
		1875	`return shcomplexfv;`
		1876	`}`
		1877	`if (s == REAL_SZ) {`
		1878	`return complexfv;`
		1879	`}`
		1880	`if (s == DOUBLE_SZ) {`
		1881	`return complexdoublefv;`
		1882	`}`
2	7u83	1883	`failer("Expecting a floating shape");`
		1884	`return f_dummy_floating_variety;`
		1885	`}`
		1886
7	7u83	1887	`floating_variety`
		1888	`fv_of_shape(shape sha)`
2	7u83	1889	`{`
		1890	`int s = shape_size(sha);`
7	7u83	1891	`if (s == SHREAL_SZ) {`
		1892	`return shrealfv;`
		1893	`}`
		1894	`if (s == REAL_SZ) {`
		1895	`return realfv;`
		1896	`}`
		1897	`if (s == DOUBLE_SZ) {`
		1898	`return doublefv;`
		1899	`}`
2	7u83	1900	`failer("Expecting a complex shape");`
		1901
		1902	`return f_dummy_floating_variety;`
		1903	`}`
		1904
		1905
		1906
7	7u83	1907	`static`
		1908	`void square_x_iy(error_treatment ov_err, exp arg1, exp arg2, exp arg3)`
2	7u83	1909	`{`
		1910	`exp x = *arg1;`
		1911	`exp y = *arg2;`
		1912
		1913	`exp obtain1_x = me_obtain(x);`
		1914	`exp obtain2_x = me_obtain(x);`
		1915	`exp obtain3_x = me_obtain(x);`
		1916	`exp obtain1_y = me_obtain(y);`
		1917	`exp obtain2_y = me_obtain(y);`
		1918	`exp obtain3_y = me_obtain(y);`
		1919
		1920	`exp minus_x_y = f_floating_minus(ov_err, obtain1_x, obtain1_y);`
7	7u83	1921	`exp plus_x_y = f_bin_floating_plus(ov_err, obtain2_x, obtain2_y);`
		1922	`exp mult_x_y = f_bin_floating_mult(ov_err, obtain3_x, obtain3_y);`
2	7u83	1923
		1924	`exp tmp = push(arg3, me_startid(sh(x), mult_x_y, 0));`
		1925
		1926	`exp obtain1_tmp = hold_check(me_obtain(tmp));`
		1927	`exp obtain2_tmp = hold_check(me_obtain(tmp));`
		1928
7	7u83	1929	`exp answer_re = f_bin_floating_mult(ov_err, minus_x_y, plus_x_y);`
		1930	`exp answer_im = f_bin_floating_plus(ov_err, obtain1_tmp, obtain2_tmp);`
2	7u83	1931
		1932	`x = push(tmp, me_startid(sh(x), answer_re, 0));`
		1933	`y = push(x, me_startid(sh(x), answer_im, 0));`
		1934
		1935	`*arg1 = x;`
		1936	`*arg2 = y;`
		1937
		1938	`return;`
		1939	`}`
		1940
		1941
7	7u83	1942	`static`
		1943	`void mult_w_by_z(error_treatment ov_err, exp arg1, exp arg2, exp arg3,`
		1944	`exp arg4, exp arg5)`
2	7u83	1945	`{`
		1946	`exp u = *arg1;`
		1947	`exp v = *arg2;`
		1948	`exp x = arg3;`
		1949	`exp y = arg4;`
		1950
		1951	`exp obtain1_x = me_obtain(x);`
		1952	`exp obtain2_x = me_obtain(x);`
		1953	`exp obtain1_y = me_obtain(y);`
		1954	`exp obtain2_y = me_obtain(y);`
		1955
		1956	`exp obtain1_u = me_obtain(u);`
		1957	`exp obtain2_u = me_obtain(u);`
		1958	`exp obtain1_v = me_obtain(v);`
		1959	`exp obtain2_v = me_obtain(v);`
		1960
		1961	`exp mult_x_u = f_bin_floating_mult(ov_err, obtain1_x, obtain1_u);`
		1962	`exp mult_x_v = f_bin_floating_mult(ov_err, obtain2_x, obtain1_v);`
		1963	`exp mult_y_u = f_bin_floating_mult(ov_err, obtain1_y, obtain2_u);`
		1964	`exp mult_y_v = f_bin_floating_mult(ov_err, obtain2_y, obtain2_v);`
		1965
		1966	`exp tmp = push(arg5, me_startid(sh(x), mult_y_u, 0));`
		1967	`exp obtain_tmp = hold_check(me_obtain(tmp));`
		1968
7	7u83	1969	`exp answer_re = f_floating_minus(ov_err, mult_x_u, mult_y_v);`
		1970	`exp answer_im = f_bin_floating_plus(ov_err, mult_x_v, obtain_tmp);`
2	7u83	1971
		1972	`u = push(tmp, me_startid(sh(x), answer_re, 0));`
		1973	`v = push(u, me_startid(sh(x), answer_im, 0));`
		1974
		1975	`*arg1 = u;`
		1976	`*arg2 = v;`
		1977
		1978	`return;`
		1979	`}`
		1980
		1981
7	7u83	1982	`static exp`
		1983	`make_comp_1_z(floating_variety complex_fv, error_treatment ov_err,`
		1984	`exp contents1_u, exp contents2_u, exp contents3_u,`
		1985	`exp contents1_v, exp contents2_v, exp contents3_v)`
2	7u83	1986	`{`
7	7u83	1987	`exp mult_u_u = f_bin_floating_mult(ov_err, contents1_u, contents2_u);`
		1988	`exp mult_v_v = f_bin_floating_mult(ov_err, contents1_v, contents2_v);`
2	7u83	1989	`exp mod_squared = f_bin_floating_plus(ov_err, mult_u_u, mult_v_v);`
7	7u83	1990	`exp mod_sq = me_startid(sh(contents1_u), mod_squared, 0);`
2	7u83	1991
		1992	`exp obtain1_mod_sq = me_obtain(mod_sq);`
		1993	`exp obtain2_mod_sq = me_obtain(mod_sq);`
		1994
		1995	`exp v_div_mod_sq = f_floating_div(ov_err, contents3_v, obtain2_mod_sq);`
		1996
		1997	`exp answer_re = f_floating_div(ov_err, contents3_u, obtain1_mod_sq);`
		1998	`exp answer_im = f_floating_negate(ov_err, v_div_mod_sq);`
		1999
		2000	`exp make_comp = f_make_complex(complex_fv, answer_re, answer_im);`
7	7u83	2001	`return me_complete_id(mod_sq, make_comp);`
2	7u83	2002	`}`
		2003
		2004
7	7u83	2005	`#define is_const(X) (name(X) != ident_tag)`
2	7u83	2006
7	7u83	2007	`exp_list`
		2008	`reorder_list(exp_list arg1, int consts_first)`
2	7u83	2009	`{`
		2010	`exp type1_start, type1_end, type2_start, type2_end, t;`
		2011
		2012	`type1_start = type1_end = type2_start = type2_end = nilexp;`
		2013	`setbro(arg1.end, nilexp);`
		2014	`for (t = arg1.start; t != arg1.end; t=bro(t)) {`
		2015	`if ((is_const(t) && consts_first) \|\| !(is_const(t) \|\| consts_first)) {`
		2016	`if (type1_start == nilexp) {`
7	7u83	2017	`type1_start = type1_end = t; /* first of type 1 */`
2	7u83	2018	`} else {`
7	7u83	2019	`setbro(type1_end, t); /* add to existing type 1's */`
2	7u83	2020	`type1_end = t;`
		2021	`}`
		2022	`} else {`
		2023	`if (type2_start == nilexp) {`
7	7u83	2024	`type2_start = type2_end = t; /* first of type 2 */`
2	7u83	2025	`} else {`
7	7u83	2026	`setbro(type2_end, t); /* add to existing type 2's */`
2	7u83	2027	`type2_end = t;`
		2028	`}`
		2029	`}`
		2030	`}`
		2031
		2032	`if ((type1_start != nilexp) && (type2_start != nilexp)) {`
		2033	`arg1.start = type1_start;`
7	7u83	2034	`setbro(type1_end, type2_start); /* if list is not a mixture */`
		2035	`arg1.end = type2_end; /* no reordering has to be done */`
2	7u83	2036	`}`
		2037
		2038	`return arg1;`
		2039	`}`
		2040
		2041
7	7u83	2042	`exp`
		2043	`me_contents(exp arg1)`
2	7u83	2044	`{`
		2045	`exp r = me_u3(sh(arg1), me_obtain(arg1), cont_tag);`
		2046
		2047	`return hold_check(r);`
		2048	`}`
		2049
		2050
		2051
		2052	`/* Used in conjunction with the function "me_complete_chain",`
		2053	`this function is used to push "ident_tag" declarations`
		2054	`onto a "stack" so that they can be linked up later. It is`
		2055	`used in loops where the number of "ident_tag"s is unknown`
		2056	`and they need to be bound together in a "first-used last-`
		2057	`bound" order - hence the stack.`
		2058
		2059	`arg1 is the new element`
		2060	`arg2 is the top element on the stack`
		2061	`*/`
		2062
7	7u83	2063	`static exp`
		2064	`push(exp arg1, exp arg2)`
2	7u83	2065	`{`
		2066	`setbro(arg2, arg1);`
		2067	`return arg2;`
		2068	`}`
		2069
		2070
		2071	`/* Take the stack full of "ident_tag" declarations and link them`
		2072	`together with the last element in the list being "last_link"`
		2073	`and the body around which the declarations are put be "link_to".`
		2074	`*/`
		2075
7	7u83	2076	`static exp`
		2077	`me_complete_chain(exp ident_chain, exp last_link, exp link_to)`
2	7u83	2078	`{`
		2079	`exp remove_link;`
		2080
		2081	`while (son(ident_chain) != last_link) {`
		2082	`remove_link = bro(ident_chain);`
		2083	`link_to = me_complete_id(ident_chain, link_to);`
		2084	`ident_chain = remove_link;`
7	7u83	2085	`}`
2	7u83	2086
		2087	`return me_complete_id(ident_chain, link_to);`
		2088	`}`
		2089
		2090
		2091
		2092	`/* Binary version of 'f_floating_plus' */`
		2093
7	7u83	2094	`static exp`
		2095	`f_bin_floating_plus(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	2096	`{`
		2097	`exp_list el;`
		2098	`el = new_exp_list(2);`
		2099	`el = add_exp_list(el, arg1, 0);`
		2100	`el = add_exp_list(el, arg2, 1);`
7	7u83	2101	`return f_floating_plus(ov_err, el);`
2	7u83	2102	`}`
		2103
		2104
		2105	`/* Binary version of 'f_floating_mult' */`
		2106
7	7u83	2107	`static exp`
		2108	`f_bin_floating_mult(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	2109	`{`
		2110	`exp_list el;`
		2111	`el = new_exp_list(2);`
		2112	`el = add_exp_list(el, arg1, 0);`
		2113	`el = add_exp_list(el, arg2, 1);`
7	7u83	2114	`return f_floating_mult(ov_err, el);`
2	7u83	2115	`}`
		2116
7	7u83	2117	`static exp`
		2118	`optimise_with_wrap(exp arg, shape shape1, shape shape2)`
2	7u83	2119	`{`
7	7u83	2120	`if (!eq_shape(shape1, shape2)) {`
		2121	`return f_change_variety(f_wrap, shape2, arg);`
		2122	`}`
2	7u83	2123
7	7u83	2124	`return(arg);`
2	7u83	2125	`}`
		2126
7	7u83	2127	`static exp`
		2128	`real_power(error_treatment ov_err, exp arg1, exp arg2)`
2	7u83	2129	`{`
		2130
		2131	`/* Gives shorter .s file if n<10 and arg1 is unknown */`
		2132
		2133	`exp real1, sn;`
7	7u83	2134	`exp(*f_real_mult)(error_treatment, exp, exp);`
2	7u83	2135	`shape real_shape, integer_shape, tmp_shape;`
		2136
		2137
		2138	`/* With wrap, we may as well work with 'int's and change back after */`
		2139
		2140	`tmp_shape = sh(arg1);`
		2141	`if (is_integer(tmp_shape) && !is_signed(tmp_shape) &&`
7	7u83	2142	`shape_size(sh(arg1)) < 32 && eq_et(ov_err, f_wrap)) {`
		2143	`arg1 = hold_check(f_change_variety(f_impossible, ulongsh, arg1));`
2	7u83	2144	`}`
		2145
		2146
		2147	`/* Widen to 'int' if necessary - guarantees negate will work */`
		2148
		2149	`if (shape_size(sh(arg2)) < 32) {`
7	7u83	2150	`arg2 = hold_check(f_change_variety(f_impossible, slongsh, arg2));`
2	7u83	2151	`}`
		2152
7	7u83	2153	`real_shape = sh(arg1); /* shape of the result */`
2	7u83	2154	`integer_shape = sh(arg2);`
		2155	`sn = me_startid(integer_shape, arg2, 0);`
		2156
		2157
		2158	`/* Identify an exp which represents the value 1 (or 1.0) */`
		2159
		2160	`if (is_integer(real_shape)) {`
		2161	`real1 = me_shint(real_shape,1);`
7	7u83	2162	`} else {`
2	7u83	2163	`real1 = me_shint(integer_shape,1);`
7	7u83	2164	`real1 = f_float_int(f_impossible, fv_of_shape(real_shape), real1);`
		2165	`real1 = hold_check (real1); /* This should be reduced to 1.0 */`
2	7u83	2166	`}`
7	7u83	2167	`real1 = push(sn, me_startid(real_shape, real1, 0));`
2	7u83	2168
		2169
		2170	`/* Decide which is the suitable function for multiplying two numbers */`
		2171
7	7u83	2172	`f_real_mult = (is_integer(real_shape)? f_mult : f_bin_floating_mult);`
2	7u83	2173
		2174	`if (is_constant_arg(arg2) \|\|`
7	7u83	2175	`((name(arg2) == name_tag) && (name(son(arg2)) == ident_tag) &&`
		2176	`!isvar(son(arg2)) && is_constant_arg(son(son(arg2))))) {`
		2177	`/* we know the power */`
2	7u83	2178	`int exponent;`
		2179	`exp x;`
		2180
		2181	`if (is_constant_arg(arg2)) {`
		2182	`exponent = no(arg2); /* arg2 is a constant */`
7	7u83	2183	`} else {`
2	7u83	2184	`exponent = no(son(son(arg2)));`
		2185	`/* arg2 identifies a constant */`
		2186	`}`
		2187
		2188	`if (exponent < 0) {`
		2189	`if (is_integer(real_shape)) {`
		2190	`failer("constant value out of range: power: must be non-negative");`
7	7u83	2191	`} else {`
		2192	`/* take reciprocal */`
		2193	`arg1 = hold_check(f_floating_div(ov_err, me_obtain(real1),`
		2194	`arg1));`
2	7u83	2195	`}`
		2196	`}`
7	7u83	2197	`x = push(real1, me_startid(real_shape, arg1, 0));`
2	7u83	2198
		2199	`if (exponent == 0) {`
7	7u83	2200	`return me_complete_chain(x, arg2,`
		2201	`optimise_with_wrap(me_obtain(real1),`
		2202	`real_shape, tmp_shape));`
2	7u83	2203	`}`
		2204
		2205	`{`
7	7u83	2206	`exp w, mylast = x;`
2	7u83	2207	`int n = abs(exponent);`
		2208
		2209	`while ((n % 2) == 0) {`
		2210	`exp mult_x_x;`
		2211	`mult_x_x = (*f_real_mult)(ov_err, me_obtain(x), me_obtain(x));`
7	7u83	2212	`mylast = x = push(mylast, me_startid(real_shape,`
		2213	`hold_check(mult_x_x), 0));`
2	7u83	2214	`n = n / 2;`
		2215	`}`
		2216
		2217	`if (n == 1) {`
7	7u83	2218	`/* return x */`
		2219	`return me_complete_chain(x, arg2,`
		2220	`optimise_with_wrap(me_obtain(x),`
		2221	`real_shape,`
		2222	`tmp_shape));`
2	7u83	2223	`}`
7	7u83	2224	`else {`
		2225	`/* w = x */`
		2226	`mylast = w = push(x, me_startid(real_shape, me_obtain(x), 0));`
2	7u83	2227	`}`
		2228
		2229	`while (n != 1) {`
		2230	`exp mult_x_x;`
		2231	`mult_x_x = (*f_real_mult)(ov_err, me_obtain(x), me_obtain(x));`
7	7u83	2232	`mylast = x = push(mylast, me_startid(real_shape,`
		2233	`hold_check(mult_x_x), 0));`
2	7u83	2234	`n = n / 2;`
		2235	`if ((n % 2) == 1) {`
		2236	`exp mult_w_x;`
7	7u83	2237	`mult_w_x = (*f_real_mult)(ov_err, me_obtain(w),`
		2238	`me_obtain(x));`
		2239	`mylast = w = push(mylast, me_startid(real_shape,`
		2240	`hold_check(mult_w_x),`
		2241	`0));`
2	7u83	2242	`}`
		2243	`}`
		2244
7	7u83	2245	`/* return w */`
		2246	`return me_complete_chain(w, arg2, optimise_with_wrap(me_obtain(w),`
		2247	`real_shape,`
		2248	`tmp_shape));`
2	7u83	2249	`}`
		2250	`} else {`
7	7u83	2251	`exp reinitialise_w, main_loop, make_comp; /* main building blocks */`
		2252	`exp square_x, mult_x_w, half_n, update_w, repeat_body;`
		2253	`exp seq, w, x, n;`
2	7u83	2254
		2255	`n = me_obtain(sn);`
7	7u83	2256	`if (!is_integer(real_shape)) { /* Must be positive for integer powers */`
		2257	`n = f_abs(f_impossible, n);`
2	7u83	2258	`}`
		2259
7	7u83	2260	`n = push(real1, me_startid(integer_shape, n, 1));`
		2261	`w = push(n, me_startid(real_shape, me_obtain(real1), 1));`
		2262	`x = push(w, me_startid(real_shape, arg1, 1));`
2	7u83	2263
		2264	`/* change value of w to z if n is odd */`
		2265	`{`
7	7u83	2266	`exp rem_n_2 = f_and(me_contents(n), me_shint(integer_shape, 1));`
		2267	`exp assign_w = f_assign(me_obtain(w), me_contents(x));`
2	7u83	2268	`exp alt_labst = hold_check(me_b3(f_top, f_make_value(f_top),`
7	7u83	2269	`f_make_top(), labst_tag));`
		2270	`exp is_n_odd = f_integer_test(no_nat_option, f_equal,`
		2271	`make_label(alt_labst), rem_n_2,`
		2272	`me_shint(integer_shape, 1));`
		2273	`exp seq = f_sequence(add_exp_list(new_exp_list(1), is_n_odd, 0),`
		2274	`assign_w);`
2	7u83	2275	`reinitialise_w = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),`
		2276	`seq, alt_labst, cond_tag));`
		2277	`}`
		2278
		2279	`/* x=xx /`
		2280	`{`
		2281	`exp mult_x_x;`
7	7u83	2282	`mult_x_x = (*f_real_mult)(ov_err, me_contents(x), me_contents(x));`
		2283	`square_x = f_assign(me_obtain(x), mult_x_x);`
2	7u83	2284	`}`
		2285
		2286	`/* w=xw /`
		2287	`{`
		2288	`exp answer;`
		2289	`answer = (*f_real_mult)(ov_err, me_contents(x), me_contents(w));`
7	7u83	2290	`mult_x_w = f_assign(me_obtain(w), answer);`
2	7u83	2291	`}`
		2292
7	7u83	2293	`/* n = n / 2 */`
2	7u83	2294	`{`
7	7u83	2295	`exp answer = f_shift_right(me_contents(n),`
		2296	`me_shint(integer_shape, 1));`
		2297	`half_n = f_assign(me_obtain(n), answer);`
2	7u83	2298	`}`
		2299
7	7u83	2300	`/* if n is odd then w = z * w */`
2	7u83	2301	`{`
7	7u83	2302	`exp rem_n_2 = f_and(me_contents(n), me_shint(integer_shape, 1));`
2	7u83	2303	`exp alt_labst = hold_check(me_b3(f_top, f_make_value(f_top),`
		2304	`f_make_top(), labst_tag));`
7	7u83	2305	`exp is_n_odd = f_integer_test(no_nat_option, f_equal,`
		2306	`make_label(alt_labst),`
		2307	`rem_n_2, me_shint(integer_shape, 1));`
		2308	`exp seq = f_sequence(add_exp_list(new_exp_list(1),`
		2309	`is_n_odd, 0), mult_x_w);`
2	7u83	2310	`update_w = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),`
		2311	`seq, alt_labst, cond_tag));`
		2312	`}`
		2313
		2314	`/* repeat + body */`
		2315	`{`
		2316	`exp body_labst, if_n_equals_1;`
		2317	`exp_list st;`
		2318
7	7u83	2319	`body_labst = hold_check(me_b3(f_top, f_make_value(f_top),`
		2320	`f_make_top(), labst_tag));`
2	7u83	2321
7	7u83	2322	`if_n_equals_1 = f_integer_test(no_nat_option, f_equal,`
		2323	`make_label(body_labst),`
		2324	`me_contents(n),`
		2325	`me_shint(integer_shape, 1));`
2	7u83	2326
		2327	`st = new_exp_list(1);`
		2328	`st = add_exp_list(st, square_x, 0);`
		2329	`st = add_exp_list(st, half_n, 1);`
		2330	`st = add_exp_list(st, update_w, 2);`
7	7u83	2331	`seq = f_sequence(st, if_n_equals_1);`
2	7u83	2332
7	7u83	2333	`setbro(son(body_labst), seq);`
		2334	`setsh (body_labst, sh (seq)); /* put seq into the body */`
		2335	`clearlast (son(body_labst)); /* of the labst */`
		2336	`setfather(body_labst, seq);`
2	7u83	2337
7	7u83	2338	`repeat_body = hold_check(me_b3(sh(body_labst), f_make_top(),`
		2339	`body_labst, rep_tag));`
2	7u83	2340	`note_repeat(repeat_body);`
		2341	`}`
		2342
		2343	`/* make loop - only done if mod(n) > 1 */`
		2344	`{`
		2345	`exp alt_labst = hold_check(me_b3(f_top, f_make_value(f_top),`
7	7u83	2346	`f_make_top(), labst_tag));`
		2347	`exp is_n_gt_1 = f_integer_test(no_nat_option, f_greater_than,`
		2348	`make_label(alt_labst),`
		2349	`me_contents(n),`
		2350	`me_shint(integer_shape, 1));`
		2351	`exp seq = f_sequence(add_exp_list(new_exp_list(1),`
		2352	`is_n_gt_1, 0), repeat_body);`
2	7u83	2353	`main_loop = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)),`
		2354	`seq, alt_labst, cond_tag));`
		2355	`}`
		2356
		2357	`if (is_integer(real_shape)) {`
		2358	`make_comp = me_contents(w);`
7	7u83	2359	`} else {`
		2360	`exp make_comp2 = f_floating_div(ov_err, me_obtain(real1),`
		2361	`me_contents(w));`
2	7u83	2362	`exp alt_labst = hold_check(me_b3(real_shape, f_make_value(f_top),`
		2363	`make_comp2, labst_tag));`
7	7u83	2364	`exp is_arg2_positive = f_integer_test(no_nat_option,`
		2365	`f_greater_than_or_equal,`
		2366	`make_label(alt_labst),`
		2367	`me_obtain(sn),`
		2368	`me_shint(integer_shape, 0));`
		2369	`exp seq = f_sequence(add_exp_list(new_exp_list(1),`
		2370	`is_arg2_positive, 0),`
		2371	`me_contents(w));`
2	7u83	2372
7	7u83	2373	`make_comp = hold_check(me_b3(lub_shape(sh(seq),sh(alt_labst)), seq,`
		2374	`alt_labst, cond_tag));`
2	7u83	2375	`}`
		2376
7	7u83	2377	`seq = f_sequence(add_exp_list(add_exp_list(new_exp_list(1),`
		2378	`reinitialise_w, 0),`
		2379	`main_loop, 1), make_comp);`
		2380	`seq = optimise_with_wrap(seq, real_shape, tmp_shape);`
2	7u83	2381	`return me_complete_chain(x, arg2, seq);`
		2382	`}`
		2383	`}`

Subversion Repositories tendra.SVN

(root)/trunk/src/installers/common/construct/flpt_fns.c – Rev 7