WebSVN – tendra.SVN – Blame – /branches/algol60/src/producers/common/output/shape.c

Rev	Author	Line No.	Line
2	7u83	1	`/*`
7	7u83	2	`* Copyright (c) 2002-2006 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, 1998`
7	7u83	33
2	7u83	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:-`
7	7u83	42
2	7u83	43	`(1) Its Recipients shall ensure that this Notice is`
		44	`reproduced upon any copies or amended versions of it;`
7	7u83	45
2	7u83	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;`
7	7u83	49
2	7u83	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;`
7	7u83	53
2	7u83	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	`#include "config.h"`
		62	`#include "version.h"`
		63	`#include "c_types.h"`
		64	`#include "ctype_ops.h"`
		65	`#include "etype_ops.h"`
		66	`#include "exp_ops.h"`
		67	`#include "flt_ops.h"`
		68	`#include "ftype_ops.h"`
		69	`#include "graph_ops.h"`
		70	`#include "id_ops.h"`
		71	`#include "itype_ops.h"`
		72	`#include "nat_ops.h"`
		73	`#include "off_ops.h"`
		74	`#include "str_ops.h"`
		75	`#include "type_ops.h"`
		76	`#include "error.h"`
		77	`#include "tdf.h"`
		78	`#include "basetype.h"`
		79	`#include "capsule.h"`
		80	`#include "char.h"`
		81	`#include "check.h"`
		82	`#include "chktype.h"`
		83	`#include "compile.h"`
		84	`#include "constant.h"`
		85	`#include "convert.h"`
		86	`#include "copy.h"`
		87	`#include "derive.h"`
		88	`#include "encode.h"`
		89	`#include "exp.h"`
		90	`#include "init.h"`
		91	`#include "interface.h"`
		92	`#include "inttype.h"`
		93	`#include "literal.h"`
		94	`#include "mangle.h"`
		95	`#include "shape.h"`
		96	`#include "struct.h"`
		97	`#include "tok.h"`
		98	`#include "ustring.h"`
		99	`#if TDF_OUTPUT`
		100
		101
		102	`/*`
		103	`ENCODE A TDF INT`
		104
		105	`This routine adds the simple integer constant n to the bitstream bs`
		106	`as a TDF INT. The argument e is true if this is the last sequence of`
		107	`digits in a value.`
		108	`*/`
		109
7	7u83	110	`static BITSTREAM *`
		111	`enc_tdfint(BITSTREAM *bs, NAT n, int e)`
2	7u83	112	`{`
7	7u83	113	`unsigned np;`
		114	`LIST(unsigned)p;`
		115	`if (IS_nat_small(n)) {`
		116	`p = NULL_list(unsigned);`
		117	`np = 1;`
2	7u83	118	`} else {`
7	7u83	119	`p = DEREF_list(nat_large_values(n));`
		120	`np = LENGTH_list(p);`
2	7u83	121	`}`
7	7u83	122	`if (np <= 2) {`
		123	`/* Small values */`
		124	`unsigned long v = get_nat_value(n);`
		125	`if (e) {`
		126	`bs = enc_int(bs, v);`
		127	`} else {`
		128	`bs = enc_int_aux(bs, v);`
		129	`}`
		130	`} else {`
		131	`/* Really large values */`
		132	`unsigned u = DEREF_unsigned(HEAD_list(p));`
		133	`n = binary_nat_op(exp_rshift_tag, n, small_nat[3]);`
		134	`bs = enc_tdfint(bs, n, 0);`
		135	`u &= 0x7;`
		136	`if (e) {`
		137	`u \|= 0x8;`
		138	`}`
		139	`bs = enc_bits(bs,(unsigned)4, u);`
		140	`}`
		141	`return (bs);`
2	7u83	142	`}`
		143
		144
		145	`/*`
		146	`ENCODE A TDF BOOL`
		147
		148	`This routine adds the value n to the bitstream bs as a TDF BOOL,`
		149	`nonzero values map to true, zero to false.`
		150	`*/`
		151
7	7u83	152	`BITSTREAM *`
		153	`enc_bool(BITSTREAM *bs, int n)`
2	7u83	154	`{`
7	7u83	155	`if (n) {`
		156	`ENC_true(bs);`
		157	`} else {`
		158	`ENC_false(bs);`
		159	`}`
		160	`return (bs);`
2	7u83	161	`}`
		162
		163
		164	`/*`
		165	`ENCODE A CALCULATED INTEGRAL EXPRESSION`
		166
		167	`This routine adds the calculated integral expression n to the`
		168	`bitstream bs. The value is negated if sgn is true and a token is`
		169	`introduced to represent the value if intro is true. The value is`
		170	`encoded as a NAT if sort is 0, a SIGNED NAT if sort is 1, an`
		171	`EXP if sort is 2 and a constant EXP if sort is 3.`
		172	`*/`
		173
7	7u83	174	`static BITSTREAM *`
		175	`enc_calc(BITSTREAM *bs, NAT n, int sgn, int intro, int sort)`
2	7u83	176	`{`
7	7u83	177	`static int suppress_calc = 0;`
		178	`NAT n1 = n;`
		179	`ulong m = DEREF_ulong(nat_calc_tok(n));`
		180	`EXP e = DEREF_exp(nat_calc_value(n));`
		181	`TYPE t = DEREF_type(exp_type(e));`
		182	`if (m == LINK_NONE && !suppress_calc) {`
		183	`EXP f = eval_exp(e, 1);`
		184	`if (!EQ_exp(f, e) && IS_exp_int_lit(f)) {`
		185	`e = f;`
		186	`t = DEREF_type(exp_type(e));`
		187	`n = DEREF_nat(exp_int_lit_nat(e));`
		188	`if (!IS_nat_calc(n)) {`
		189	`/* Value evaluates to a literal constant */`
		190	`if (sort == 0) {`
		191	`bs = enc_nat(bs, n, 0);`
		192	`} else {`
		193	`if (sort >= 2) {`
		194	`ENC_make_int(bs);`
		195	`bs = enc_variety(bs, t);`
		196	`}`
		197	`bs = enc_snat(bs, n, sgn, 0);`
		198	`}`
		199	`return (bs);`
		200	`}`
2	7u83	201	`}`
		202	`}`
		203
7	7u83	204	`/* Encode calculated value */`
		205	`suppress_calc++;`
		206	`if (sort == 0) {`
		207	`ENC_computed_nat(bs);`
		208	`sort = 2;`
		209	`} else if (sort == 1) {`
		210	`ENC_computed_signed_nat(bs);`
		211	`sort = 2;`
		212	`}`
		213	`if (sgn) {`
		214	`/* Negated value */`
		215	`ENC_negate(bs);`
		216	`bs = enc_error_treatment(bs, t);`
		217	`bs = enc_calc(bs, n, 0, intro, sort);`
		218	`} else {`
		219	`if (intro && m == LINK_NONE) {`
		220	`/* Introduce token for value */`
		221	`while (!IS_NULL_exp(e) && IS_exp_int_lit(e)) {`
		222	`NAT n2 = DEREF_nat(exp_int_lit_nat(e));`
		223	`if (!IS_nat_calc(n2)) {`
		224	`break;`
		225	`}`
		226	`m = DEREF_ulong(nat_calc_tok(n2));`
		227	`if (m != LINK_NONE) {`
		228	`break;`
		229	`}`
		230	`e = DEREF_exp(nat_calc_value(n2));`
		231	`}`
		232	`if (!IS_NULL_exp(e) && IS_exp_token(e)) {`
		233	`LIST(TOKEN)args;`
		234	`args = DEREF_list(exp_token_args(e));`
		235	`if (IS_NULL_list(args)) {`
		236	`/* Use existing token */`
		237	`IDENTIFIER tok =`
		238	`DEREF_id(exp_token_tok(e));`
		239	`IGNORE capsule_id(tok, VAR_token);`
		240	`m = DEREF_ulong(id_no(tok));`
		241	`}`
		242	`}`
		243	`if (m == LINK_NONE) {`
		244	`/* Introduce token for value */`
		245	`BITSTREAM *ts;`
		246	`m = capsule_no(NULL_string, VAR_token);`
		247	`ts = enc_tokdef_start(m, "E", NIL(ulong), 1);`
		248	`if (sort == 3) {`
		249	`/* Force constant evaluation */`
		250	`ENC_make_int(ts);`
		251	`ts = enc_variety(ts, t);`
		252	`ENC_computed_signed_nat(ts);`
		253	`}`
		254	`ts = enc_exp(ts, e);`
		255	`enc_tokdef_end(m, ts);`
		256	`}`
		257	`COPY_ulong(nat_calc_tok(n1), m);`
		258	`COPY_ulong(nat_calc_tok(n), m);`
2	7u83	259	`}`
7	7u83	260	`if (m == LINK_NONE) {`
		261	`/* Calculated value */`
		262	`if (sort == 3) {`
		263	`/* Force constant evaluation */`
		264	`ENC_make_int(bs);`
		265	`bs = enc_variety(bs, t);`
		266	`ENC_computed_signed_nat(bs);`
		267	`}`
		268	`bs = enc_exp(bs, e);`
		269	`} else {`
		270	`/* Tokenised value */`
		271	`m = link_no(bs, m, VAR_token);`
		272	`ENC_exp_apply_token(bs);`
		273	`ENC_make_tok(bs, m);`
		274	`ENC_LEN_SMALL(bs, 0);`
2	7u83	275	`}`
		276	`}`
7	7u83	277	`suppress_calc--;`
		278	`return (bs);`
2	7u83	279	`}`
		280
		281
		282	`/*`
		283	`ENCODE A TDF NAT`
		284
		285	`This routine adds the integer constant n to the bitstream bs as a`
		286	`TDF NAT.`
		287	`*/`
		288
7	7u83	289	`BITSTREAM *`
		290	`enc_nat(BITSTREAM *bs, NAT n, int intro)`
2	7u83	291	`{`
7	7u83	292	`if (IS_NULL_nat(n)) {`
		293	`/* Null constant maps to zero */`
		294	`ENC_make_nat(bs);`
		295	`ENC_INT_SMALL(bs, 0);`
		296	`} else {`
		297	`ASSERT(ORDER_nat == 5);`
		298	`switch (TAG_nat(n)) {`
		299	`case nat_small_tag: {`
		300	`unsigned v = DEREF_unsigned(nat_small_value(n));`
		301	`ENC_make_nat(bs);`
		302	`ENC_INT(bs, v);`
		303	`break;`
2	7u83	304	`}`
7	7u83	305	`case nat_large_tag: {`
		306	`ENC_make_nat(bs);`
		307	`bs = enc_tdfint(bs, n, 1);`
		308	`break;`
		309	`}`
		310	`case nat_calc_tag: {`
		311	`bs = enc_calc(bs, n, 0, intro, 0);`
		312	`break;`
		313	`}`
		314	`case nat_neg_tag: {`
		315	`/* This case shouldn't occur */`
		316	`ENC_make_nat(bs);`
		317	`ENC_INT_SMALL(bs, 0);`
		318	`break;`
		319	`}`
		320	`case nat_token_tag: {`
		321	`/* Token applications */`
		322	`IDENTIFIER tok = DEREF_id(nat_token_tok(n));`
		323	`LIST(TOKEN)args = DEREF_list(nat_token_args(n));`
		324	`TOKEN sort = DEREF_tok(id_token_sort(tok));`
		325	`int s = token_code(sort);`
		326	`if (s == 'Z') {`
		327	`/* Signed nat token */`
		328	`TYPE t = type_sint;`
		329	`ENC_computed_nat(bs);`
		330	`ENC_make_int(bs);`
		331	`bs = enc_variety(bs, t);`
		332	`}`
		333	`bs = enc_token(bs, tok, args);`
		334	`break;`
		335	`}`
		336	`}`
2	7u83	337	`}`
7	7u83	338	`return (bs);`
2	7u83	339	`}`
		340
		341
		342	`/*`
		343	`ENCODE A TDF SIGNED NAT`
		344
		345	`This routine adds the integer constant n to the bitstream bs as a`
		346	`TDF SIGNED NAT. sgn is true if the value is to be negated and intro`
		347	`is true if a token is to be introduced for a calculated value.`
		348	`*/`
		349
7	7u83	350	`BITSTREAM *`
		351	`enc_snat(BITSTREAM *bs, NAT n, int sgn, int intro)`
2	7u83	352	`{`
7	7u83	353	`if (IS_NULL_nat(n)) {`
		354	`/* Null constant maps to zero */`
		355	`ENC_make_signed_nat(bs);`
		356	`ENC_OFF(bs);`
		357	`ENC_INT_SMALL(bs, 0);`
		358	`} else {`
		359	`ASSERT(ORDER_nat == 5);`
		360	`switch (TAG_nat(n)) {`
		361	`case nat_small_tag: {`
		362	`unsigned v = DEREF_unsigned(nat_small_value(n));`
		363	`if (v == 0) {`
		364	`sgn = 0;`
		365	`}`
		366	`ENC_make_signed_nat(bs);`
		367	`ENC_BOOL(bs, sgn);`
		368	`ENC_INT(bs, v);`
		369	`break;`
2	7u83	370	`}`
7	7u83	371	`case nat_large_tag: {`
		372	`ENC_make_signed_nat(bs);`
		373	`ENC_BOOL(bs, sgn);`
		374	`bs = enc_tdfint(bs, n, 1);`
		375	`break;`
		376	`}`
		377	`case nat_calc_tag: {`
		378	`bs = enc_calc(bs, n, sgn, intro, 1);`
		379	`break;`
		380	`}`
		381	`case nat_neg_tag: {`
		382	`NAT m = DEREF_nat(nat_neg_arg(n));`
		383	`bs = enc_snat(bs, m, !sgn, intro);`
		384	`break;`
		385	`}`
		386	`case nat_token_tag: {`
		387	`/* Token applications */`
		388	`IDENTIFIER tok = DEREF_id(nat_token_tok(n));`
		389	`LIST(TOKEN)args = DEREF_list(nat_token_args(n));`
		390	`TOKEN sort = DEREF_tok(id_token_sort(tok));`
		391	`int s = token_code(sort);`
		392	`if (s == 'Z') {`
		393	`/* Signed nat token */`
		394	`if (sgn) {`
		395	`/* Negate signed nat */`
		396	`TYPE t = type_sint;`
		397	`ENC_computed_signed_nat(bs);`
		398	`ENC_negate(bs);`
		399	`bs = enc_error_treatment(bs, t);`
		400	`ENC_make_int(bs);`
		401	`bs = enc_variety(bs, t);`
		402	`}`
		403	`} else {`
		404	`/* Nat token */`
		405	`ENC_snat_from_nat(bs);`
		406	`bs = enc_bool(bs, sgn);`
		407	`}`
		408	`bs = enc_token(bs, tok, args);`
		409	`break;`
		410	`}`
		411	`}`
2	7u83	412	`}`
7	7u83	413	`return (bs);`
2	7u83	414	`}`
		415
		416
		417	`/*`
		418	`ENCODE AN INTEGER LITERAL EXPRESSION`
		419
		420	`This routine adds the integer constant expression n of type t to the`
		421	`bitstream bs. etag gives the expression tag which is used to`
		422	`determine whether a token should be introduced for the value.`
		423	`*/`
		424
7	7u83	425	`BITSTREAM *`
		426	`enc_int_lit(BITSTREAM *bs, NAT n, TYPE t, unsigned etag)`
2	7u83	427	`{`
7	7u83	428	`if (IS_nat_calc(n)) {`
		429	`if (etag == exp_identifier_tag) {`
		430	`/* Enumerator value */`
		431	`bs = enc_calc(bs, n, 0, 1, 3);`
		432	`} else {`
		433	`/* Other calculated value */`
		434	`bs = enc_calc(bs, n, 0, 0, 2);`
		435	`}`
2	7u83	436	`} else {`
7	7u83	437	`/* Simple value */`
		438	`ENC_make_int(bs);`
		439	`bs = enc_variety(bs, t);`
		440	`bs = enc_snat(bs, n, 0, 0);`
2	7u83	441	`}`
7	7u83	442	`return (bs);`
2	7u83	443	`}`
		444
		445
		446	`/*`
		447	`ENCODE A TDF FLOATING LITERAL`
		448
		449	`This routine adds the floating literal flt of type t to the bitstream`
		450	`bs as a TDF EXP.`
		451	`*/`
		452
7	7u83	453	`BITSTREAM *`
		454	`enc_float(BITSTREAM *bs, FLOAT flt, TYPE t)`
2	7u83	455	`{`
7	7u83	456	`ulong n = DEREF_ulong(flt_tok(flt));`
		457	`if (n == LINK_NONE) {`
		458	`/* Decompose literal */`
		459	`BITSTREAM *ts;`
		460	`string i = DEREF_string(flt_simple_int_part(flt));`
		461	`string f = DEREF_string(flt_simple_frac_part(flt));`
		462	`unsigned long ni = (unsigned long)ustrlen(i);`
		463	`unsigned long nf = (unsigned long)ustrlen(f);`
		464	`unsigned long nt = ni + nf + 1;`
		465	`NAT e = DEREF_nat(flt_simple_exponent(flt));`
2	7u83	466
7	7u83	467	`/* Map to canonical form */`
		468	`if (ni == 0) {`
		469	`/* Introduce leading zero */`
		470	`i = small_number[0];`
		471	`ni = 1;`
		472	`nt = nf + 2;`
		473	`}`
		474	`if (nf == 0) {`
		475	`/* No decimal part */`
		476	`nt = ni;`
		477	`}`
		478	`if (nf == 1 && f[0] == '0') {`
		479	`/* Ignore trivial decimal part */`
		480	`nf = 0;`
		481	`nt = ni;`
		482	`}`
2	7u83	483
7	7u83	484	`/* Encode expression */`
		485	`n = capsule_no(NULL_string, VAR_token);`
		486	`ts = enc_tokdef_start(n, "E", NIL(ulong), 1);`
		487	`ENC_make_floating(ts);`
		488	`ts = enc_flvar(ts, t);`
		489	`ENC_to_nearest(ts);`
		490	`ENC_false(ts);`
		491	`ENC_make_string(ts);`
		492	`ENC_INT(ts, BYTE_SIZE);`
		493	`ENC_INT(ts, nt);`
		494	`ts = enc_ascii(ts, ni, i);`
		495	`if (nf) {`
		496	`ENC_BITS(ts, BYTE_SIZE, '.');`
		497	`ts = enc_ascii(ts, nf, f);`
		498	`}`
		499	`ENC_make_nat(ts);`
		500	`ENC_INT(ts, 10);`
		501	`ts = enc_snat(ts, e, 0, 0);`
		502	`enc_tokdef_end(n, ts);`
		503	`COPY_ulong(flt_tok(flt), n);`
2	7u83	504	`}`
7	7u83	505	`n = link_no(bs, n, VAR_token);`
		506	`ENC_exp_apply_token(bs);`
		507	`ENC_make_tok(bs, n);`
		508	`ENC_LEN_SMALL(bs, 0);`
		509	`return (bs);`
2	7u83	510	`}`
		511
		512
		513	`/*`
		514	`ENCODE A SMALL TDF FLOATING LITERAL`
		515
		516	`This routine adds the small floating literal given by the value v of`
		517	`type t to the bitstream bs as a TDF EXP.`
		518	`*/`
		519
7	7u83	520	`BITSTREAM *`
		521	`enc_float_int(BITSTREAM *bs, int v, TYPE t)`
2	7u83	522	`{`
7	7u83	523	`FLOAT flt = get_float(t, v);`
		524	`if (!IS_NULL_flt(flt)) {`
		525	`bs = enc_float(bs, flt, t);`
		526	`} else {`
		527	`char s[20];`
		528	`sprintf_v(s, "%d", v);`
		529	`ENC_make_floating(bs);`
		530	`bs = enc_flvar(bs, t);`
		531	`ENC_to_nearest(bs);`
		532	`ENC_false(bs);`
		533	`ENC_make_string(bs);`
		534	`bs = enc_ustring(bs, ustrlit(s));`
		535	`ENC_make_nat(bs);`
		536	`ENC_INT(bs, 10);`
		537	`bs = enc_snat(bs, NULL_nat, 0, 0);`
		538	`}`
		539	`return (bs);`
2	7u83	540	`}`
		541
		542
		543	`/*`
		544	`ENCODE A STRING LITERAL EXPRESSION`
		545
		546	`This routine adds the string literal str of type t to the bitstream`
		547	`bs. Note that the type determines the string length - the string`
		548	`is truncated or padded with zeros as necessary (this includes the`
		549	`normal terminal zero for a string).`
		550	`*/`
		551
7	7u83	552	`BITSTREAM *`
		553	`enc_string(BITSTREAM *bs, STRING str, TYPE t)`
2	7u83	554	`{`
7	7u83	555	`unsigned long i, m;`
		556	`unsigned long d = 0;`
		557	`string s = DEREF_string(str_simple_text(str));`
		558	`unsigned long n = DEREF_ulong(str_simple_len(str));`
		559	`unsigned kind = DEREF_unsigned(str_simple_kind(str));`
		560	`if (n == 0) {`
		561	`/* Allow for empty strings */`
		562	`bs = enc_null_exp(bs, t);`
		563	`return (bs);`
		564	`}`
		565	`if (IS_type_array(t)) {`
		566	`/* Find array size */`
		567	`NAT sz = DEREF_nat(type_array_size(t));`
		568	`m = get_nat_value(sz);`
		569	`if (m < n) {`
		570	`/* String truncation */`
		571	`n = m;`
		572	`} else {`
		573	`d = m - n;`
		574	`if (d <= STRING_PADDING) {`
		575	`/* Small padding */`
		576	`d = 0;`
		577	`} else {`
		578	`/* Large padding */`
		579	`ENC_concat_nof(bs);`
		580	`m = n;`
		581	`}`
		582	`}`
		583	`t = DEREF_type(type_array_sub(t));`
2	7u83	584	`} else {`
7	7u83	585	`m = n + 1;`
2	7u83	586	`}`
7	7u83	587	`if (kind & STRING_FAT) {`
		588	`/* Fat character strings */`
		589	`unsigned mbits = 0;`
		590	`unsigned long maxc = 1;`
		591	`BASE_TYPE sign = btype_none;`
		592	`unsigned bits = find_type_size(t, &mbits, &sign);`
		593	`if (sign != btype_unsigned) {`
		594	`bits--;`
		595	`}`
		596	`maxc <<= bits;`
		597	`ENC_make_nof(bs);`
		598	`ENC_LIST(bs, m);`
		599	`for (i = 0; i < n; i++) {`
		600	`TYPE u = t;`
		601	`int ch = CHAR_SIMPLE;`
		602	`unsigned long c = get_multi_char(s, &ch);`
		603	`if (ch == CHAR_SIMPLE) {`
		604	`c = to_ascii(c, &ch);`
		605	`}`
		606	`if (maxc && c >= maxc) {`
		607	`/* Character doesn't fit into type */`
		608	`ENC_change_variety(bs);`
		609	`bs = enc_error_treatment(bs, u);`
		610	`bs = enc_variety(bs, u);`
		611	`u = type_ulong;`
		612	`}`
		613	`ENC_make_int(bs);`
		614	`bs = enc_variety(bs, u);`
		615	`ENC_make_signed_nat(bs);`
		616	`ENC_OFF(bs);`
		617	`ENC_INT(bs, c);`
		618	`s += MULTI_WIDTH;`
		619	`}`
		620	`for (; i < m; i++) {`
		621	`/* Terminal zeros */`
		622	`bs = enc_make_int(bs, t, 0);`
		623	`}`
2	7u83	624	`} else {`
7	7u83	625	`ENC_make_nof_int(bs);`
		626	`bs = enc_variety(bs, t);`
		627	`ENC_make_string(bs);`
		628	`ENC_INT(bs, BYTE_SIZE);`
		629	`ENC_INT(bs, m);`
		630	`if (kind & STRING_MULTI) {`
		631	`for (i = 0; i < n; i++) {`
		632	`int ch = CHAR_SIMPLE;`
		633	`unsigned long c = get_multi_char(s, &ch);`
		634	`if (ch == CHAR_SIMPLE) {`
		635	`c = to_ascii(c, &ch);`
		636	`}`
		637	`ENC_BITS(bs, BYTE_SIZE, c);`
		638	`s += MULTI_WIDTH;`
		639	`}`
		640	`} else {`
		641	`/* Simple string */`
		642	`bs = enc_ascii(bs, n, s);`
		643	`}`
		644	`for (i = n; i < m; i++) {`
		645	`/* Terminal zeros */`
		646	`ENC_BITS(bs, BYTE_SIZE, 0);`
		647	`}`
2	7u83	648	`}`
7	7u83	649	`if (d) {`
		650	`/* Large padding */`
		651	`ENC_n_copies(bs);`
		652	`ENC_make_nat(bs);`
		653	`ENC_INT(bs, d);`
		654	`bs = enc_make_int(bs, t, 0);`
2	7u83	655	`}`
7	7u83	656	`return (bs);`
2	7u83	657	`}`
		658
		659
		660	`/*`
		661	`ENCODE A STRING LITERAL`
		662
		663	`This routine adds the string literal str to the bitstream bs.`
		664	`*/`
		665
7	7u83	666	`BITSTREAM *`
		667	`enc_strlit(BITSTREAM *bs, STRING str)`
2	7u83	668	`{`
7	7u83	669	`string s = DEREF_string(str_simple_text(str));`
		670	`unsigned long n = DEREF_ulong(str_simple_len(str));`
		671	`unsigned kind = DEREF_unsigned(str_simple_kind(str));`
		672	`ENC_make_string(bs);`
		673	`ENC_INT(bs, BYTE_SIZE);`
		674	`ENC_INT(bs, n);`
		675	`if (kind & STRING_MULTI) {`
		676	`unsigned long i;`
		677	`for (i = 0; i < n; i++) {`
		678	`int ch = CHAR_SIMPLE;`
		679	`unsigned long c = get_multi_char(s, &ch);`
		680	`if (ch == CHAR_SIMPLE) {`
		681	`c = to_ascii(c, &ch);`
		682	`}`
		683	`ENC_BITS(bs, BYTE_SIZE, c);`
		684	`s += MULTI_WIDTH;`
		685	`}`
		686	`} else {`
		687	`bs = enc_ascii(bs, n, s);`
2	7u83	688	`}`
7	7u83	689	`return (bs);`
2	7u83	690	`}`
		691
		692
		693	`/*`
		694	`ENCODE A CHARACTER LITERAL EXPRESSION`
		695
		696	`This routine adds the character literal str of type t to the bitstream`
		697	`bs. u gives the actual literal type, from which it is cast to t. Note`
		698	`that it is possible that str does not fit into u.`
		699	`*/`
		700
7	7u83	701	`BITSTREAM *`
		702	`enc_char(BITSTREAM *bs, STRING str, TYPE t, TYPE u)`
2	7u83	703	`{`
7	7u83	704	`NAT n;`
		705	`TYPE w;`
		706	`int convert_to_t;`
		707	`int convert_to_u;`
		708	`unsigned long v = DEREF_ulong(str_simple_tok(str));`
		709	`if (v == LINK_NONE) {`
		710	`/* Evaluate literal */`
		711	`n = eval_char_lit(str);`
		712	`v = DEREF_ulong(str_simple_tok(str));`
		713	`if (v < 128) {`
		714	`/* Small values are easy */`
		715	`bs = enc_make_int(bs, t,(int)v);`
		716	`return (bs);`
		717	`}`
		718	`} else {`
		719	`if (v < 128) {`
		720	`/* Small values are easy */`
		721	`bs = enc_make_int(bs, t,(int)v);`
		722	`return (bs);`
		723	`}`
		724	`n = make_nat_value(v);`
2	7u83	725	`}`
7	7u83	726	`if (check_nat_range(u, n) == 0) {`
		727	`if (EQ_type(t, u) \|\| check_nat_range(t, n) == 0) {`
		728	`/* Fits into both t and u */`
		729	`w = t;`
		730	`convert_to_t = 0;`
		731	`convert_to_u = 0;`
		732	`} else {`
		733	`/* Fits into u but not t */`
		734	`w = u;`
		735	`convert_to_t = 1;`
		736	`convert_to_u = 0;`
		737	`}`
2	7u83	738	`} else {`
7	7u83	739	`/* Doesn't fit into u */`
		740	`w = find_char_type(n);`
		741	`convert_to_t = 1;`
		742	`convert_to_u = 1;`
2	7u83	743	`}`
7	7u83	744	`if (convert_to_t) {`
		745	`ENC_change_variety(bs);`
		746	`bs = enc_error_treatment(bs, t);`
		747	`bs = enc_variety(bs, t);`
		748	`}`
		749	`if (convert_to_u && !EQ_type(u, t)) {`
		750	`ENC_change_variety(bs);`
		751	`bs = enc_error_treatment(bs, u);`
		752	`bs = enc_variety(bs, u);`
		753	`}`
		754	`ENC_make_int(bs);`
		755	`bs = enc_variety(bs, w);`
		756	`ENC_make_signed_nat(bs);`
		757	`ENC_OFF(bs);`
		758	`bs = enc_tdfint(bs, n, 1);`
		759	`return (bs);`
2	7u83	760	`}`
		761
		762
		763	`/*`
		764	`FIND AN INTEGRAL TYPE`
		765
		766	`This routine returns the integral type corresponding to the type t.`
		767	`*/`
		768
7	7u83	769	`static INT_TYPE`
		770	`find_itype(TYPE t)`
2	7u83	771	`{`
7	7u83	772	`INT_TYPE it;`
		773	`unsigned tag = TAG_type(t);`
		774	`if (tag == type_bitfield_tag) {`
		775	`it = DEREF_itype(type_bitfield_defn(t));`
		776	`} else {`
		777	`if (tag == type_enumerate_tag) {`
		778	`/* Allow for enumeration types */`
		779	`ENUM_TYPE et = DEREF_etype(type_enumerate_defn(t));`
		780	`t = DEREF_type(etype_rep(et));`
		781	`tag = TAG_type(t);`
		782	`}`
		783	`if (tag != type_integer_tag) {`
		784	`t = type_sint;`
		785	`}`
		786	`it = DEREF_itype(type_integer_rep(t));`
2	7u83	787	`}`
7	7u83	788	`return (it);`
2	7u83	789	`}`
		790
		791
		792	`/*`
		793	`ENCODE A TDF VARIETY NUMBER`
		794
		795	`This routine adds the code number of the integral type it to the`
		796	`bitstream bs as a TDF SIGNED NAT.`
		797	`*/`
		798
7	7u83	799	`static BITSTREAM *`
		800	`enc_var_no(BITSTREAM *bs, INT_TYPE it, int alt)`
2	7u83	801	`{`
7	7u83	802	`ulong tok;`
		803	`unsigned tag = TAG_itype(it);`
		804	`ASSERT(ORDER_itype == 6);`
		805	`switch (tag) {`
		806	`case itype_basic_tag: {`
		807	`/* Built-in integral types */`
		808	`BUILTIN_TYPE n = DEREF_ntype(itype_basic_no(it));`
		809	`unsigned m = base_token[n].no;`
		810	`if (alt) {`
		811	`m = base_token[n].alt;`
		812	`}`
		813	`if (m != ARITH_none) {`
		814	`/* Basic types are easy */`
		815	`bs = enc_make_snat(bs,(int)m);`
		816	`return (bs);`
		817	`}`
		818	`break;`
2	7u83	819	`}`
7	7u83	820	`case itype_bitfield_tag: {`
		821	`/* Bitfield types */`
		822	`TYPE s = DEREF_type(itype_bitfield_sub(it));`
		823	`INT_TYPE is = find_itype(s);`
		824	`bs = enc_var_no(bs, is, alt);`
		825	`return (bs);`
2	7u83	826	`}`
7	7u83	827	`case itype_token_tag: {`
		828	`/* Tokenised types */`
		829	`IDENTIFIER tk = DEREF_id(itype_token_tok(it));`
		830	`LIST(TOKEN)args = DEREF_list(itype_token_args(it));`
		831	`bs = enc_token(bs, tk, args);`
		832	`return (bs);`
2	7u83	833	`}`
7	7u83	834	`}`
2	7u83	835
7	7u83	836	`/* Find the token number */`
		837	`tok = DEREF_ulong(itype_ntok(it));`
		838	`if (tok == LINK_NONE) {`
		839	`if (tag == itype_basic_tag) {`
		840	`/* Look up special token number */`
		841	`BUILTIN_TYPE n = DEREF_ntype(itype_basic_no(it));`
		842	`int tn = base_token[n].tok;`
		843	`tok = special_no(tn);`
		844	`COPY_ulong(itype_ntok(it), tok);`
		845	`} else {`
		846	`/* Compound integral types */`
		847	`string s = NULL;`
		848	`BITSTREAM ts, us;`
		849	`if (output_all) {`
		850	`TYPE t = make_itype(it, it);`
		851	`s = mangle_tname("~cpp.itype_no.", t);`
		852	`}`
		853	`tok = capsule_no(s, VAR_token);`
		854	`COPY_ulong(itype_ntok(it), tok);`
		855	`ts = enc_tokdef_start(tok, "Z", NIL(ulong), 1);`
		856	`us = start_bitstream(NIL(FILE), ts->link);`
		857	`switch (tag) {`
		858	`case itype_promote_tag: {`
		859	`/* Promoted integral types */`
		860	`INT_TYPE is =`
		861	`DEREF_itype(itype_promote_arg(it));`
		862	`ts = enc_special(ts, TOK_promote);`
		863	`us = enc_var_no(us, is, 0);`
		864	`break;`
		865	`}`
		866	`case itype_arith_tag: {`
		867	`/* Arithmetic integral types */`
		868	`INT_TYPE is = DEREF_itype(itype_arith_arg1(it));`
		869	`INT_TYPE ir = DEREF_itype(itype_arith_arg2(it));`
		870	`ts = enc_special(ts, TOK_arith_type);`
		871	`us = enc_var_no(us, is, 0);`
		872	`us = enc_var_no(us, ir, 0);`
		873	`break;`
		874	`}`
		875	`case itype_literal_tag: {`
		876	`/* Literal integral types */`
		877	`NAT n = DEREF_nat(itype_literal_nat(it));`
		878	`IDENTIFIER tid =`
		879	`DEREF_id(itype_literal_tok(it));`
		880	`if (!IS_NULL_id(tid)) {`
		881	`ulong tn;`
		882	`IGNORE enc_tokdef(tid, 0);`
		883	`tn = unit_no(ts, tid, VAR_token, 0);`
		884	`ENC_signed_nat_apply_token(ts);`
		885	`ENC_make_tok(ts, tn);`
		886	`} else {`
		887	`int spec = DEREF_int(itype_literal_spec(it));`
		888	`ts = enc_special(ts, spec);`
		889	`}`
		890	`us = enc_snat(us, n, 0, 0);`
		891	`break;`
		892	`}`
		893	`}`
		894	`ts = enc_bitstream(ts, us);`
		895	`enc_tokdef_end(tok, ts);`
2	7u83	896	`}`
		897	`}`
		898
7	7u83	899	`/* Encode the token application */`
		900	`tok = link_no(bs, tok, VAR_token);`
		901	`ENC_signed_nat_apply_token(bs);`
		902	`ENC_make_tok(bs, tok);`
		903	`ENC_LEN_SMALL(bs, 0);`
		904	`return (bs);`
2	7u83	905	`}`
		906
		907
		908	`/*`
		909	`ENCODE A TDF VARIETY`
		910
		911	`This routine adds the integral type t to the bitstream bs as a`
		912	`TDF VARIETY. Note that all integral types are tokenised.`
		913	`*/`
		914
7	7u83	915	`BITSTREAM *`
		916	`enc_variety(BITSTREAM *bs, TYPE t)`
2	7u83	917	`{`
7	7u83	918	`/* Find the token number */`
		919	`INT_TYPE it = find_itype(t);`
		920	`unsigned tag = TAG_itype(it);`
		921	`ulong tok = DEREF_ulong(itype_itok(it));`
		922	`if (tok == LINK_NONE) {`
		923	`ASSERT(ORDER_itype == 6);`
		924	`switch (tag) {`
		925	`case itype_basic_tag: {`
		926	`/* Built-in integral types */`
		927	`BUILTIN_TYPE n = DEREF_ntype(itype_basic_no(it));`
		928	`unsigned m = base_token[n].no;`
		929	`if (m != ARITH_none) {`
		930	`/* Look up special token number */`
		931	`int tn = base_token[n].tok;`
		932	`tok = special_no(tn);`
		933	`COPY_ulong(itype_itok(it), tok);`
		934	`}`
		935	`break;`
2	7u83	936	`}`
7	7u83	937	`case itype_token_tag: {`
		938	`/* Tokenised integral types */`
		939	`IDENTIFIER tk = DEREF_id(itype_token_tok(it));`
		940	`DECL_SPEC ds = DEREF_dspec(id_storage(tk));`
		941	`if (ds & dspec_auto) {`
		942	`/* Integral token parameters */`
		943	`BITSTREAM *ts;`
		944	`bs = enc_special(bs, TOK_convert);`
		945	`ts = start_bitstream(NIL(FILE), bs->link);`
		946	`ts = enc_var_no(ts, it, 0);`
		947	`bs = enc_bitstream(bs, ts);`
		948	`return (bs);`
		949	`}`
		950	`break;`
2	7u83	951	`}`
		952	`}`
7	7u83	953	`if (tok == LINK_NONE) {`
		954	`/* Define the variety token */`
		955	`string s = NULL;`
		956	`if (output_all) {`
		957	`t = qualify_type(t, cv_none, 0);`
		958	`s = mangle_tname("~cpp.itype.", t);`
		959	`}`
		960	`tok = capsule_no(s, VAR_token);`
		961	`COPY_ulong(itype_itok(it), tok);`
		962	`if (tag == itype_bitfield_tag) {`
		963	`/* Bitfield types */`
		964	`BITSTREAM *ts;`
		965	`NAT n = DEREF_nat(itype_bitfield_size(it));`
		966	`BASE_TYPE bt =`
		967	`DEREF_btype(itype_bitfield_rep(it));`
		968	`ts = enc_tokdef_start(tok, "U", NIL(ulong), 1);`
		969	`ENC_bfvar_bits(ts);`
		970	`if (bt & btype_signed) {`
		971	`ENC_true(ts);`
		972	`} else if (bt & btype_unsigned) {`
		973	`ENC_false(ts);`
		974	`} else {`
		975	`BITSTREAM *us;`
		976	`ts = enc_special(ts, TOK_bitf_sign);`
		977	`us = start_bitstream(NIL(FILE),`
		978	`ts->link);`
		979	`us = enc_var_no(us, it, 0);`
		980	`ts = enc_bitstream(ts, us);`
		981	`}`
		982	`ts = enc_nat(ts, n, 1);`
		983	`enc_tokdef_end(tok, ts);`
		984	`} else {`
		985	`/* Integral types */`
		986	`BITSTREAM ts, us;`
		987	`ts = enc_tokdef_start(tok, "V", NIL(ulong), 1);`
		988	`ts = enc_special(ts, TOK_convert);`
		989	`us = start_bitstream(NIL(FILE), ts->link);`
		990	`us = enc_var_no(us, it, 0);`
		991	`ts = enc_bitstream(ts, us);`
		992	`enc_tokdef_end(tok, ts);`
		993	`}`
		994	`}`
2	7u83	995	`}`
		996
7	7u83	997	`/* Encode the token application */`
		998	`tok = link_no(bs, tok, VAR_token);`
		999	`if (tag == itype_bitfield_tag) {`
		1000	`ENC_bfvar_apply_token(bs);`
		1001	`} else {`
		1002	`ENC_var_apply_token(bs);`
		1003	`}`
		1004	`ENC_make_tok(bs, tok);`
		1005	`ENC_LEN_SMALL(bs, 0);`
		1006	`return (bs);`
2	7u83	1007	`}`
		1008
		1009
		1010	`/*`
		1011	`ENCODE A TDF FLOATING VARIETY NUMBER`
		1012
		1013	`This routine adds the code number of the floating point type ft to`
		1014	`the bitstream bs as a TDF SIGNED NAT.`
		1015	`*/`
		1016
7	7u83	1017	`static BITSTREAM *`
		1018	`enc_flvar_no(BITSTREAM *bs, FLOAT_TYPE ft)`
2	7u83	1019	`{`
7	7u83	1020	`ulong tok;`
		1021	`unsigned tag = TAG_ftype(ft);`
		1022	`ASSERT(ORDER_ftype == 4);`
		1023	`switch (tag) {`
		1024	`case ftype_basic_tag: {`
		1025	`/* Built-in floating types */`
		1026	`BUILTIN_TYPE n = DEREF_ntype(ftype_basic_no(ft));`
		1027	`unsigned m = base_token[n].no;`
		1028	`if (m != ARITH_none) {`
		1029	`/* Basic types are easy */`
		1030	`bs = enc_make_snat(bs,(int)m);`
		1031	`return (bs);`
		1032	`}`
		1033	`break;`
2	7u83	1034	`}`
7	7u83	1035	`case ftype_token_tag: {`
		1036	`/* Tokenised types */`
		1037	`IDENTIFIER tk = DEREF_id(ftype_token_tok(ft));`
		1038	`LIST(TOKEN)args = DEREF_list(ftype_token_args(ft));`
		1039	`bs = enc_token(bs, tk, args);`
		1040	`return (bs);`
2	7u83	1041	`}`
7	7u83	1042	`}`
2	7u83	1043
7	7u83	1044	`/* Find the token number */`
		1045	`tok = DEREF_ulong(ftype_ntok(ft));`
		1046	`if (tok == LINK_NONE) {`
		1047	`if (tag == ftype_basic_tag) {`
		1048	`/* Look up special token number */`
		1049	`BUILTIN_TYPE n = DEREF_ntype(ftype_basic_no(ft));`
		1050	`int tn = base_token[n].tok;`
		1051	`tok = special_no(tn);`
		1052	`COPY_ulong(ftype_ntok(ft), tok);`
		1053	`} else {`
		1054	`/* Compound floating types */`
		1055	`string s = NULL;`
		1056	`BITSTREAM ts, us;`
		1057	`if (output_all) {`
		1058	`TYPE t = make_ftype(ft, NULL_ftype);`
		1059	`s = mangle_tname("~cpp.ftype_no.", t);`
		1060	`}`
		1061	`tok = capsule_no(s, VAR_token);`
		1062	`COPY_ulong(ftype_ntok(ft), tok);`
		1063	`ts = enc_tokdef_start(tok, "Z", NIL(ulong), 1);`
		1064	`us = start_bitstream(NIL(FILE), ts->link);`
		1065	`switch (tag) {`
		1066	`case ftype_arg_promote_tag: {`
		1067	`/* Promoted floating types */`
		1068	`FLOAT_TYPE fs;`
		1069	`fs = DEREF_ftype(ftype_arg_promote_arg(ft));`
		1070	`ts = enc_special(ts, TOK_promote);`
		1071	`us = enc_flvar_no(us, fs);`
		1072	`break;`
		1073	`}`
		1074	`case ftype_arith_tag: {`
		1075	`/* Arithmetic floating types */`
		1076	`FLOAT_TYPE fs =`
		1077	`DEREF_ftype(ftype_arith_arg1(ft));`
		1078	`FLOAT_TYPE fr =`
		1079	`DEREF_ftype(ftype_arith_arg2(ft));`
		1080	`ts = enc_special(ts, TOK_arith_type);`
		1081	`us = enc_flvar_no(us, fs);`
		1082	`us = enc_flvar_no(us, fr);`
		1083	`break;`
		1084	`}`
		1085	`}`
		1086	`ts = enc_bitstream(ts, us);`
		1087	`enc_tokdef_end(tok, ts);`
2	7u83	1088	`}`
		1089	`}`
		1090
7	7u83	1091	`/* Encode the token application */`
		1092	`tok = link_no(bs, tok, VAR_token);`
		1093	`ENC_signed_nat_apply_token(bs);`
		1094	`ENC_make_tok(bs, tok);`
		1095	`ENC_LEN_SMALL(bs, 0);`
		1096	`return (bs);`
2	7u83	1097	`}`
		1098
		1099
		1100	`/*`
		1101	`ENCODE A TDF FLOATING VARIETY`
		1102
		1103	`This routine adds the floating point type t to the bitstream bs as`
		1104	`a TDF FLOATING VARIETY. Note that all floating point types are`
		1105	`tokenised.`
		1106	`*/`
		1107
7	7u83	1108	`BITSTREAM *`
		1109	`enc_flvar(BITSTREAM *bs, TYPE t)`
2	7u83	1110	`{`
7	7u83	1111	`ulong tok;`
		1112	`FLOAT_TYPE ft;`
		1113	`if (!IS_type_floating(t)) {`
		1114	`t = type_double;`
		1115	`}`
		1116	`ft = DEREF_ftype(type_floating_rep(t));`
2	7u83	1117
7	7u83	1118	`/* Find the token number */`
		1119	`tok = DEREF_ulong(ftype_ftok(ft));`
		1120	`if (tok == LINK_NONE) {`
		1121	`if (IS_ftype_basic(ft)) {`
		1122	`/* Built-in floating point types */`
		1123	`BUILTIN_TYPE n = DEREF_ntype(ftype_basic_no(ft));`
		1124	`unsigned m = base_token[n].no;`
		1125	`if (m != ARITH_none) {`
		1126	`/* Look up special token number */`
		1127	`int tn = base_token[n].tok;`
		1128	`tok = special_no(tn);`
		1129	`COPY_ulong(ftype_ftok(ft), tok);`
		1130	`}`
		1131	`} else if (IS_ftype_token(ft)) {`
		1132	`/* Tokenised floating point types */`
		1133	`IDENTIFIER tk = DEREF_id(ftype_token_tok(ft));`
		1134	`DECL_SPEC ds = DEREF_dspec(id_storage(tk));`
		1135	`if (ds & dspec_auto) {`
		1136	`/* Floating point token parameters */`
		1137	`BITSTREAM *ts;`
		1138	`bs = enc_special(bs, TOK_convert);`
		1139	`ts = start_bitstream(NIL(FILE), bs->link);`
		1140	`ts = enc_flvar_no(ts, ft);`
		1141	`bs = enc_bitstream(bs, ts);`
		1142	`return (bs);`
		1143	`}`
		1144	`}`
		1145	`if (tok == LINK_NONE) {`
		1146	`/* Define the variety token */`
		1147	`string s = NULL;`
		1148	`BITSTREAM ts, us;`
		1149	`if (output_all) {`
		1150	`t = qualify_type(t, cv_none, 0);`
		1151	`s = mangle_tname("~cpp.ftype.", t);`
		1152	`}`
		1153	`tok = capsule_no(s, VAR_token);`
		1154	`COPY_ulong(ftype_ftok(ft), tok);`
		1155	`ts = enc_tokdef_start(tok, "F", NIL(ulong), 1);`
		1156	`ts = enc_special(ts, TOK_convert);`
		1157	`us = start_bitstream(NIL(FILE), ts->link);`
		1158	`us = enc_flvar_no(us, ft);`
		1159	`ts = enc_bitstream(ts, us);`
		1160	`enc_tokdef_end(tok, ts);`
		1161	`}`
2	7u83	1162	`}`
		1163
7	7u83	1164	`/* Encode the token application */`
		1165	`tok = link_no(bs, tok, VAR_token);`
		1166	`ENC_flvar_apply_token(bs);`
		1167	`ENC_make_tok(bs, tok);`
		1168	`ENC_LEN_SMALL(bs, 0);`
		1169	`return (bs);`
2	7u83	1170	`}`
		1171
		1172
		1173	`/*`
		1174	`ENCODE A TDF BITFIELD VARIETY`
		1175
		1176	`This routine adds the bitfield type t to the bitstream bs as a TDF`
		1177	`FLOATING BITFIELD.`
		1178	`*/`
		1179
7	7u83	1180	`BITSTREAM *`
		1181	`enc_bfvar(BITSTREAM *bs, TYPE t)`
2	7u83	1182	`{`
7	7u83	1183	`INT_TYPE it = DEREF_itype(type_bitfield_defn(t));`
		1184	`ulong m = DEREF_ulong(itype_itok(it));`
		1185	`if (m == LINK_NONE) {`
		1186	`static LIST(INT_TYPE)bftypes = NULL_list(INT_TYPE);`
		1187	`LIST(INT_TYPE)p = bftypes;`
		1188	`while (!IS_NULL_list(p)) {`
		1189	`INT_TYPE is = DEREF_itype(HEAD_list(p));`
		1190	`if (eq_itype(it, is)) {`
		1191	`m = DEREF_ulong(itype_itok(is));`
		1192	`COPY_ulong(itype_itok(it), m);`
		1193	`break;`
		1194	`}`
		1195	`p = TAIL_list(p);`
		1196	`}`
		1197	`if (IS_NULL_list(p)) {`
		1198	`/* Add bitfield type to list */`
		1199	`CONS_itype(it, bftypes, bftypes);`
		1200	`}`
2	7u83	1201	`}`
7	7u83	1202	`bs = enc_variety(bs, t);`
		1203	`return (bs);`
2	7u83	1204	`}`
		1205
		1206
		1207	`/*`
		1208	`ENCODE AN ARITHMETIC TYPE`
		1209
		1210	`This routine adds the code number for the integral or floating point`
		1211	`type t to the bitstream bs.`
		1212	`*/`
		1213
7	7u83	1214	`BITSTREAM *`
		1215	`enc_arith(BITSTREAM *bs, TYPE t, int alt)`
2	7u83	1216	`{`
7	7u83	1217	`unsigned n;`
		1218	`BUILTIN_TYPE bt;`
		1219	`if (!IS_NULL_type(t)) {`
		1220	`switch (TAG_type(t)) {`
		1221	`case type_integer_tag:`
		1222	`case type_enumerate_tag: {`
		1223	`/* Integral and enumeration types */`
		1224	`INT_TYPE it = find_itype(t);`
		1225	`bs = enc_var_no(bs, it, alt);`
		1226	`return (bs);`
		1227	`}`
		1228	`case type_floating_tag: {`
		1229	`/* Floating point types */`
		1230	`FLOAT_TYPE ft = DEREF_ftype(type_floating_rep(t));`
		1231	`bs = enc_flvar_no(bs, ft);`
		1232	`return (bs);`
		1233	`}`
		1234	`case type_ptr_tag:`
		1235	`case type_ref_tag: {`
		1236	`/* Pointer types */`
		1237	`bs = enc_special(bs, TOK_ptr_rep);`
		1238	`return (bs);`
		1239	`}`
		1240	`}`
2	7u83	1241	`}`
7	7u83	1242	`bt = is_builtin_type(t, 0);`
		1243	`if (alt) {`
		1244	`n = base_token[bt].alt;`
		1245	`} else {`
		1246	`n = base_token[bt].no;`
		1247	`}`
		1248	`bs = enc_make_snat(bs,(int)n);`
		1249	`return (bs);`
2	7u83	1250	`}`
		1251
		1252
		1253	`/*`
		1254	`IS A TYPE A TOKEN APPLICATION?`
		1255
		1256	`This routine checks whether the class t represents a token application.`
		1257	`*/`
		1258
7	7u83	1259	`int`
		1260	`is_tokenised_class(TYPE t)`
2	7u83	1261	`{`
7	7u83	1262	`if (!IS_NULL_type(t) && IS_type_token(t)) {`
		1263	`IDENTIFIER id = DEREF_id(type_token_tok(t));`
		1264	`if (IS_id_token(id)) {`
		1265	`return (1);`
		1266	`}`
		1267	`}`
		1268	`return (0);`
2	7u83	1269	`}`
		1270
		1271
		1272	`/*`
		1273	`ENCODE A TDF ALIGNMENT`
		1274
		1275	`This routine adds the alignment of the type t to the bitstream bs`
		1276	`as a TDF ALIGNMENT.`
		1277	`*/`
		1278
7	7u83	1279	`BITSTREAM *`
		1280	`enc_alignment(BITSTREAM *bs, TYPE t)`
2	7u83	1281	`{`
7	7u83	1282	`if (IS_NULL_type(t)) {`
		1283	`/* This shouldn't happen */`
		1284	`t = type_sint;`
		1285	`}`
		1286	`switch (TAG_type(t)) {`
		1287	`case type_ptr_tag:`
		1288	`case type_ref_tag: {`
		1289	`/* Pointer alignment */`
		1290	`TYPE s = DEREF_type(type_ptr_etc_sub(t));`
		1291	`switch (TAG_type(s)) {`
		1292	`case type_top_tag:`
		1293	`case type_bottom_tag: {`
		1294	`/* Generic pointer */`
		1295	`ENC_alignment(bs);`
		1296	`bs = enc_special(bs, TOK_ptr_void);`
		1297	`break;`
2	7u83	1298	`}`
7	7u83	1299	`case type_func_tag: {`
		1300	`/* Function pointer */`
		1301	`ENC_alignment(bs);`
		1302	`ENC_proc(bs);`
		1303	`break;`
2	7u83	1304	`}`
		1305	`default : {`
7	7u83	1306	`/* Simple pointers */`
		1307	`ENC_alignment(bs);`
		1308	`ENC_pointer(bs);`
		1309	`ENC_alignment(bs);`
		1310	`ENC_top(bs);`
		1311	`break;`
2	7u83	1312	`}`
7	7u83	1313	`}`
		1314	`break;`
2	7u83	1315	`}`
7	7u83	1316	`case type_array_tag: {`
		1317	`/* Array types */`
		1318	`TYPE s = DEREF_type(type_array_sub(t));`
		1319	`bs = enc_alignment(bs, s);`
		1320	`break;`
2	7u83	1321	`}`
7	7u83	1322	`case type_compound_tag: {`
		1323	`/* Compound types */`
		1324	`CLASS_TYPE ct = DEREF_ctype(type_compound_defn(t));`
		1325	`TYPE s = DEREF_type(ctype_form(ct));`
		1326	`if (is_tokenised_class(s)) {`
		1327	`ENC_alignment(bs);`
		1328	`bs = enc_shape(bs, s);`
		1329	`} else {`
		1330	`bs = enc_al_ctype(bs, ct);`
		1331	`}`
		1332	`break;`
2	7u83	1333	`}`
7	7u83	1334	`case type_token_tag: {`
		1335	`/* Tokenised types */`
		1336	`IDENTIFIER id = DEREF_id(type_token_tok(t));`
		1337	`ulong n = DEREF_ulong(id_no(id));`
		1338	`if (n == LINK_TOKDEF) {`
		1339	`/* Allow for recursive tokenised types */`
		1340	`bs = enc_special(bs, TOK_empty_align);`
		1341	`} else {`
		1342	`ENC_alignment(bs);`
		1343	`bs = enc_shape(bs, t);`
		1344	`}`
		1345	`break;`
2	7u83	1346	`}`
7	7u83	1347	`default: {`
		1348	`/* Other types are simple */`
		1349	`ENC_alignment(bs);`
		1350	`bs = enc_shape(bs, t);`
		1351	`break;`
2	7u83	1352	`}`
7	7u83	1353	`}`
		1354	`return (bs);`
2	7u83	1355	`}`
		1356
		1357
		1358	`/*`
		1359	`DOES A TYPE HAVE A SIMPLE ALIGNMENT?`
		1360
		1361	`This routine checks whether the alignment of the type t is of the`
		1362	`simple form 'alignment ( t )'.`
		1363	`*/`
		1364
7	7u83	1365	`static int`
		1366	`simple_alignment(TYPE t)`
2	7u83	1367	`{`
7	7u83	1368	`if (!IS_NULL_type(t)) {`
		1369	`switch (TAG_type(t)) {`
		1370	`case type_array_tag: {`
		1371	`/* Array types */`
		1372	`TYPE s = DEREF_type(type_array_sub(t));`
		1373	`return (simple_alignment(s));`
2	7u83	1374	`}`
7	7u83	1375	`case type_compound_tag: {`
		1376	`/* Compound types */`
		1377	`CLASS_TYPE ct = DEREF_ctype(type_compound_defn(t));`
		1378	`TYPE s = DEREF_type(ctype_form(ct));`
		1379	`if (!is_tokenised_class(s)) {`
		1380	`CLASS_INFO ci = DEREF_cinfo(ctype_info(ct));`
		1381	`if (!(ci & cinfo_complete)) {`
		1382	`return (0);`
		1383	`}`
		1384	`if (!(ci & cinfo_defined)) {`
		1385	`return (0);`
		1386	`}`
		1387	`if (ci & cinfo_recursive) {`
		1388	`return (0);`
		1389	`}`
		1390	`}`
		1391	`break;`
		1392	`}`
		1393	`case type_token_tag: {`
		1394	`/* Tokenised types */`
		1395	`IDENTIFIER id = DEREF_id(type_token_tok(t));`
		1396	`ulong n = DEREF_ulong(id_no(id));`
		1397	`if (n == LINK_TOKDEF) {`
		1398	`return (0);`
		1399	`}`
		1400	`break;`
		1401	`}`
		1402	`}`
2	7u83	1403	`}`
7	7u83	1404	`return (1);`
2	7u83	1405	`}`
		1406
		1407
		1408	`/*`
		1409	`ENCODE A TDF SHAPE OFFSET`
		1410
		1411	`This routine adds the offset of the type t to the bitstream bs.`
		1412	`*/`
		1413
7	7u83	1414	`BITSTREAM *`
		1415	`enc_shape_offset(BITSTREAM *bs, TYPE t)`
2	7u83	1416	`{`
7	7u83	1417	`if (!IS_NULL_type(t) && IS_type_array(t)) {`
		1418	`/* Allow for variable-sized arrays */`
		1419	`NAT n = DEREF_nat(type_array_size(t));`
		1420	`if (!IS_NULL_nat(n) && IS_nat_calc(n)) {`
		1421	`EXP e = DEREF_exp(nat_calc_value(n));`
		1422	`TYPE s = DEREF_type(type_array_sub(t));`
		1423	`ENC_offset_mult(bs);`
		1424	`bs = enc_shape_offset(bs, s);`
		1425	`bs = enc_exp(bs, e);`
		1426	`return (bs);`
		1427	`}`
2	7u83	1428	`}`
7	7u83	1429	`if (simple_alignment(t)) {`
		1430	`/* Use token as shorthand */`
		1431	`if (EQ_type(t, type_char)) {`
		1432	`bs = enc_special(bs, TOK_char_offset);`
		1433	`} else {`
		1434	`BITSTREAM *ts = start_bitstream(NIL(FILE), bs->link);`
		1435	`bs = enc_special(bs, TOK_shape_offset);`
		1436	`ts = enc_shape(ts, t);`
		1437	`bs = enc_bitstream(bs, ts);`
		1438	`}`
2	7u83	1439	`} else {`
7	7u83	1440	`/* Output explicit instructions */`
		1441	`ENC_offset_pad(bs);`
		1442	`bs = enc_alignment(bs, t);`
		1443	`ENC_shape_offset(bs);`
		1444	`bs = enc_shape(bs, t);`
2	7u83	1445	`}`
7	7u83	1446	`return (bs);`
2	7u83	1447	`}`
		1448
		1449
		1450	`/*`
		1451	`ENCODE A TDF OFFSET`
		1452
		1453	`This routine adds the offset off to the bitstream bs as a TDF EXP.`
		1454	`*/`
		1455
7	7u83	1456	`BITSTREAM *`
		1457	`enc_offset(BITSTREAM *bs, OFFSET off)`
2	7u83	1458	`{`
7	7u83	1459	`if (IS_NULL_off(off)) {`
		1460	`ENC_offset_zero(bs);`
		1461	`bs = enc_alignment(bs, type_sint);`
		1462	`return (bs);`
2	7u83	1463	`}`
7	7u83	1464	`ASSERT(ORDER_off == 13);`
		1465	`switch (TAG_off(off)) {`
		1466	`case off_zero_tag: {`
		1467	`/* Zero offsets */`
		1468	`TYPE t = DEREF_type(off_zero_type(off));`
		1469	`ENC_offset_zero(bs);`
		1470	`bs = enc_alignment(bs, t);`
		1471	`break;`
2	7u83	1472	`}`
7	7u83	1473	`case off_type_tag: {`
		1474	`/* Type offsets */`
		1475	`TYPE t = DEREF_type(off_type_type(off));`
		1476	`bs = enc_shape_offset(bs, t);`
		1477	`break;`
2	7u83	1478	`}`
7	7u83	1479	`case off_extra_tag: {`
		1480	`/* Extra allocator offset */`
		1481	`TYPE t = DEREF_type(off_extra_type(off));`
		1482	`int n = DEREF_int(off_extra_scale(off));`
		1483	`bs = enc_extra_offset(bs, t, off_size_t, n);`
		1484	`break;`
2	7u83	1485	`}`
7	7u83	1486	`case off_array_tag: {`
		1487	`/* Array offsets */`
		1488	`TYPE t = DEREF_type(off_array_type(off));`
		1489	`unsigned n = DEREF_unsigned(off_array_arg(off));`
		1490	`if (n == 0) {`
		1491	`ENC_offset_zero(bs);`
		1492	`bs = enc_alignment(bs, t);`
		1493	`} else if (n == 1) {`
		1494	`bs = enc_shape_offset(bs, t);`
		1495	`} else {`
		1496	`ENC_offset_mult(bs);`
		1497	`bs = enc_shape_offset(bs, t);`
		1498	`ENC_make_int(bs);`
		1499	`bs = enc_variety(bs, type_sint);`
		1500	`ENC_make_signed_nat(bs);`
		1501	`ENC_OFF(bs);`
		1502	`ENC_INT(bs, n);`
		1503	`}`
		1504	`break;`
2	7u83	1505	`}`
7	7u83	1506	`case off_base_tag: {`
		1507	`/* Base class offsets */`
		1508	`GRAPH gr = DEREF_graph(off_base_graph(off));`
		1509	`bs = enc_base(bs, gr, 0);`
		1510	`break;`
2	7u83	1511	`}`
7	7u83	1512	`case off_deriv_tag: {`
		1513	`/* Derived class offsets */`
		1514	`GRAPH gr = DEREF_graph(off_deriv_graph(off));`
		1515	`bs = enc_base(bs, gr, 0);`
		1516	`break;`
2	7u83	1517	`}`
7	7u83	1518	`case off_member_tag: {`
		1519	`/* Member offsets */`
		1520	`IDENTIFIER id = DEREF_id(off_member_id(off));`
		1521	`bs = enc_member(bs, id);`
		1522	`break;`
2	7u83	1523	`}`
7	7u83	1524	`case off_ptr_mem_tag: {`
		1525	`/* Pointer to member offsets */`
		1526	`BITSTREAM *ts;`
		1527	`EXP a = DEREF_exp(off_ptr_mem_arg(off));`
		1528	`TYPE s = DEREF_type(exp_type(a));`
		1529	`s = DEREF_type(type_ptr_mem_sub(s));`
		1530	`bs = enc_special(bs, TOK_pm_offset);`
		1531	`ts = start_bitstream(NIL(FILE), bs->link);`
		1532	`ts = enc_exp(ts, a);`
		1533	`ts = enc_alignment(ts, s);`
		1534	`bs = enc_bitstream(bs, ts);`
		1535	`break;`
2	7u83	1536	`}`
7	7u83	1537	`case off_negate_tag: {`
		1538	`/* Offset negations */`
		1539	`OFFSET off1 = DEREF_off(off_negate_arg(off));`
		1540	`ENC_offset_negate(bs);`
		1541	`bs = enc_offset(bs, off1);`
		1542	`break;`
2	7u83	1543	`}`
7	7u83	1544	`case off_plus_tag: {`
		1545	`/* Offset additions */`
		1546	`OFFSET off1 = DEREF_off(off_plus_arg1(off));`
		1547	`OFFSET off2 = DEREF_off(off_plus_arg2(off));`
		1548	`if (!IS_NULL_off(off1)) {`
		1549	`ENC_offset_add(bs);`
		1550	`bs = enc_offset(bs, off1);`
		1551	`}`
		1552	`bs = enc_offset(bs, off2);`
		1553	`break;`
2	7u83	1554	`}`
7	7u83	1555	`case off_mult_tag: {`
		1556	`/* Offset multiplications */`
		1557	`OFFSET off1 = DEREF_off(off_mult_arg1(off));`
		1558	`EXP a = DEREF_exp(off_mult_arg2(off));`
		1559	`ENC_offset_mult(bs);`
		1560	`bs = enc_offset(bs, off1);`
		1561	`bs = enc_exp(bs, a);`
		1562	`break;`
2	7u83	1563	`}`
7	7u83	1564	`case off_ptr_diff_tag: {`
		1565	`/* Difference of two pointers */`
		1566	`EXP a = DEREF_exp(off_ptr_diff_ptr1(off));`
		1567	`EXP b = DEREF_exp(off_ptr_diff_ptr2(off));`
		1568	`ENC_subtract_ptrs(bs);`
		1569	`bs = enc_exp(bs, a);`
		1570	`bs = enc_exp(bs, b);`
		1571	`break;`
2	7u83	1572	`}`
7	7u83	1573	`case off_token_tag: {`
		1574	`/* Token applications */`
		1575	`IDENTIFIER tok = DEREF_id(off_token_tok(off));`
		1576	`LIST(TOKEN)args = DEREF_list(off_token_args(off));`
		1577	`bs = enc_token(bs, tok, args);`
		1578	`break;`
		1579	`}`
2	7u83	1580	`default : {`
7	7u83	1581	`/* Illegal offset */`
		1582	`ENC_offset_zero(bs);`
		1583	`bs = enc_alignment(bs, type_sint);`
		1584	`break;`
2	7u83	1585	`}`
7	7u83	1586	`}`
		1587	`return (bs);`
2	7u83	1588	`}`
		1589
		1590
		1591	`/*`
		1592	`ENCODE AN EXTRA OFFSET`
		1593
		1594	`This routine adds an expression representing n times the offset off`
		1595	`rounded up to the alignment of t to the bitstream bs.`
		1596	`*/`
		1597
7	7u83	1598	`BITSTREAM *`
		1599	`enc_extra_offset(BITSTREAM *bs, TYPE t, OFFSET off, int n)`
2	7u83	1600	`{`
7	7u83	1601	`if (n == 0) {`
		1602	`ENC_offset_zero(bs);`
		1603	`bs = enc_alignment(bs, t);`
2	7u83	1604	`} else {`
7	7u83	1605	`if (n < 0) {`
		1606	`ENC_offset_negate(bs);`
		1607	`n = -n;`
		1608	`}`
		1609	`if (n == 1) {`
		1610	`BITSTREAM *ts;`
		1611	`bs = enc_special(bs, TOK_extra_offset);`
		1612	`ts = start_bitstream(NIL(FILE), bs->link);`
		1613	`ts = enc_alignment(ts, t);`
		1614	`ts = enc_offset(ts, off);`
		1615	`bs = enc_bitstream(bs, ts);`
		1616	`} else {`
		1617	`ENC_offset_mult(bs);`
		1618	`bs = enc_extra_offset(bs, t, off, 1);`
		1619	`bs = enc_make_int(bs, type_sint, n);`
		1620	`}`
2	7u83	1621	`}`
7	7u83	1622	`return (bs);`
2	7u83	1623	`}`
		1624
		1625
		1626	`/*`
		1627	`ENCODE AN ADD TO POINTER EXPRESSION`
		1628
		1629	`This routine adds the expression formed by adding the offset off`
		1630	`to the pointer a to the bitstream bs. virt is true for a virtual`
		1631	`base offset.`
		1632	`*/`
		1633
7	7u83	1634	`BITSTREAM *`
		1635	`enc_add_ptr(BITSTREAM *bs, EXP a, ulong n, OFFSET off, int virt)`
2	7u83	1636	`{`
7	7u83	1637	`if (IS_NULL_off(off)) {`
		1638	`if (n == LINK_NONE) {`
		1639	`bs = enc_exp(bs, a);`
		1640	`} else {`
		1641	`ENC_exp_apply_token(bs);`
		1642	`ENC_make_tok(bs, n);`
		1643	`ENC_LEN_SMALL(bs, 0);`
		1644	`}`
		1645	`return (bs);`
2	7u83	1646	`}`
7	7u83	1647	`ASSERT(ORDER_off == 13);`
		1648	`switch (TAG_off(off)) {`
		1649	`case off_base_tag: {`
		1650	`/* Base class offsets */`
		1651	`GRAPH gr = DEREF_graph(off_base_graph(off));`
		1652	`DECL_SPEC acc = DEREF_dspec(graph_access(gr));`
		1653	`if (virt && (acc & dspec_mutable)) {`
		1654	`/* Virtual base offset */`
		1655	`bs = enc_add_base(bs, off, NULL_off);`
		1656	`bs = enc_add_ptr(bs, a, n, NULL_off, 0);`
		1657	`bs = enc_end_base(bs, off, NULL_off);`
		1658	`return (bs);`
		1659	`}`
		1660	`if (acc & dspec_ignore) {`
		1661	`/* Null base offset */`
		1662	`bs = enc_add_ptr(bs, a, n, NULL_off, 0);`
		1663	`return (bs);`
		1664	`}`
		1665	`break;`
2	7u83	1666	`}`
7	7u83	1667	`case off_deriv_tag: {`
		1668	`/* Derived class offsets */`
		1669	`GRAPH gr = DEREF_graph(off_deriv_graph(off));`
		1670	`DECL_SPEC acc = DEREF_dspec(graph_access(gr));`
		1671	`if (virt && (acc & dspec_mutable)) {`
		1672	`/* Virtual base offset */`
		1673	`OFFSET off1, off2;`
		1674	`gr = min_base_class(gr);`
		1675	`off = DEREF_off(graph_off(gr));`
		1676	`if (IS_off_deriv(off)) {`
		1677	`off1 = DEREF_off(off_deriv_direct(off));`
		1678	`off2 = DEREF_off(off_deriv_indirect(off));`
		1679	`} else {`
		1680	`off1 = off;`
		1681	`off2 = NULL_off;`
		1682	`}`
		1683	`bs = enc_add_base(bs, off1, off2);`
		1684	`bs = enc_add_ptr(bs, a, n, NULL_off, 0);`
		1685	`bs = enc_end_base(bs, off1, off2);`
		1686	`return (bs);`
		1687	`}`
		1688	`if (acc & dspec_ignore) {`
		1689	`/* Null base offset */`
		1690	`bs = enc_add_ptr(bs, a, n, NULL_off, 0);`
		1691	`return (bs);`
		1692	`}`
		1693	`break;`
		1694	`}`
		1695	`case off_plus_tag: {`
		1696	`/* Offset additions */`
		1697	`OFFSET off1 = DEREF_off(off_plus_arg1(off));`
		1698	`OFFSET off2 = DEREF_off(off_plus_arg2(off));`
		1699	`if (is_zero_offset(off2)) {`
		1700	`bs = enc_add_ptr(bs, a, n, off1, virt);`
2	7u83	1701	`} else {`
7	7u83	1702	`ENC_add_to_ptr(bs);`
		1703	`bs = enc_add_ptr(bs, a, n, off1, virt);`
		1704	`bs = enc_offset(bs, off2);`
2	7u83	1705	`}`
7	7u83	1706	`return (bs);`
2	7u83	1707	`}`
		1708	`}`
		1709
7	7u83	1710	`/* Other offsets */`
		1711	`if (is_zero_offset(off)) {`
		1712	`bs = enc_add_ptr(bs, a, n, NULL_off, 0);`
		1713	`} else {`
		1714	`ENC_add_to_ptr(bs);`
		1715	`bs = enc_add_ptr(bs, a, n, NULL_off, 0);`
		1716	`bs = enc_offset(bs, off);`
		1717	`}`
		1718	`return (bs);`
2	7u83	1719	`}`
		1720
		1721
		1722	`/*`
		1723	`ENCODE A TDF SHAPE`
		1724
		1725	`This routine adds the type t to the bitstream bs as a TDF SHAPE.`
		1726	`*/`
		1727
7	7u83	1728	`BITSTREAM *`
		1729	`enc_shape(BITSTREAM *bs, TYPE t)`
2	7u83	1730	`{`
7	7u83	1731	`if (IS_NULL_type(t)) {`
		1732	`/* This shouldn't happen */`
		1733	`t = type_sint;`
2	7u83	1734	`}`
7	7u83	1735	`ASSERT(ORDER_type == 18);`
		1736	`switch (TAG_type(t)) {`
		1737	`case type_integer_tag:`
		1738	`case type_enumerate_tag: {`
		1739	`/* Integral and enumeration types */`
		1740	`ENC_integer(bs);`
		1741	`bs = enc_variety(bs, t);`
		1742	`break;`
2	7u83	1743	`}`
7	7u83	1744	`case type_floating_tag: {`
		1745	`/* Floating point types */`
		1746	`ENC_floating(bs);`
		1747	`bs = enc_flvar(bs, t);`
		1748	`break;`
2	7u83	1749	`}`
7	7u83	1750	`case type_top_tag: {`
		1751	`/* The top type */`
		1752	`ENC_top(bs);`
		1753	`break;`
2	7u83	1754	`}`
7	7u83	1755	`case type_bottom_tag: {`
		1756	`/* The bottom type */`
		1757	`ENC_bottom(bs);`
		1758	`break;`
		1759	`}`
		1760	`case type_ptr_tag:`
		1761	`case type_ref_tag: {`
		1762	`/* Pointer types */`
		1763	`TYPE s = DEREF_type(type_ptr_etc_sub(t));`
		1764	`switch (TAG_type(s)) {`
		1765	`case type_top_tag:`
		1766	`case type_bottom_tag: {`
		1767	`/* Generic pointer */`
		1768	`bs = enc_special(bs, TOK_ptr_void);`
		1769	`break;`
2	7u83	1770	`}`
7	7u83	1771	`case type_func_tag: {`
		1772	`/* Function pointer */`
		1773	`ENC_proc(bs);`
		1774	`break;`
2	7u83	1775	`}`
		1776	`default : {`
7	7u83	1777	`/* Normal pointer */`
		1778	`ENC_pointer(bs);`
		1779	`bs = enc_alignment(bs, s);`
		1780	`break;`
2	7u83	1781	`}`
7	7u83	1782	`}`
		1783	`break;`
2	7u83	1784	`}`
7	7u83	1785	`case type_ptr_mem_tag: {`
		1786	`/* Pointer to member types */`
		1787	`TYPE s = DEREF_type(type_ptr_mem_sub(t));`
		1788	`if (IS_type_func(s)) {`
		1789	`bs = enc_special(bs, TOK_pmf_type);`
		1790	`} else {`
		1791	`bs = enc_special(bs, TOK_pm_type);`
		1792	`}`
		1793	`break;`
2	7u83	1794	`}`
7	7u83	1795	`case type_func_tag: {`
		1796	`/* Function types */`
		1797	`ENC_proc(bs);`
		1798	`break;`
2	7u83	1799	`}`
7	7u83	1800	`case type_array_tag: {`
		1801	`/* Array types */`
		1802	`NAT n = DEREF_nat(type_array_size(t));`
		1803	`TYPE s = DEREF_type(type_array_sub(t));`
		1804	`ENC_nof(bs);`
		1805	`bs = enc_nat(bs, n, 1);`
		1806	`bs = enc_shape(bs, s);`
		1807	`break;`
2	7u83	1808	`}`
7	7u83	1809	`case type_bitfield_tag: {`
		1810	`/* Bitfield types */`
		1811	`ENC_bitfield(bs);`
		1812	`bs = enc_bfvar(bs, t);`
		1813	`break;`
2	7u83	1814	`}`
7	7u83	1815	`case type_compound_tag: {`
		1816	`/* Compound types */`
		1817	`CLASS_TYPE ct = DEREF_ctype(type_compound_defn(t));`
		1818	`TYPE s = DEREF_type(ctype_form(ct));`
		1819	`if (is_tokenised_class(s)) {`
		1820	`bs = enc_shape(bs, s);`
		1821	`} else {`
		1822	`bs = enc_ctype(bs, ct);`
		1823	`}`
		1824	`break;`
2	7u83	1825	`}`
7	7u83	1826	`case type_token_tag: {`
		1827	`/* Tokenised types */`
		1828	`IDENTIFIER tok = DEREF_id(type_token_tok(t));`
		1829	`LIST(TOKEN)args = DEREF_list(type_token_args(t));`
		1830	`if (IS_id_token(tok)) {`
		1831	`bs = enc_token(bs, tok, args);`
		1832	`} else {`
		1833	`/* This case shouldn't occur */`
		1834	`bs = enc_shape(bs, type_sint);`
		1835	`}`
		1836	`break;`
2	7u83	1837	`}`
7	7u83	1838	`case type_templ_tag: {`
		1839	`/* Template types */`
		1840	`TYPE s = DEREF_type(type_templ_defn(t));`
		1841	`bs = enc_shape(bs, s);`
		1842	`break;`
2	7u83	1843	`}`
7	7u83	1844	`case type_dummy_tag: {`
		1845	`/* Dummy special token types */`
		1846	`int tok = DEREF_int(type_dummy_tok(t));`
2	7u83	1847	`#if LANGUAGE_CPP`
7	7u83	1848	`if (tok == TOK_vtab_type) {`
		1849	`bs = enc_vtable_shape(bs, size_dummy_vtab);`
		1850	`break;`
		1851	`}`
2	7u83	1852	`#endif`
7	7u83	1853	`bs = enc_special(bs, tok);`
		1854	`break;`
2	7u83	1855	`}`
7	7u83	1856	`default: {`
		1857	`/* This case shouldn't occur */`
		1858	`bs = enc_shape(bs, type_sint);`
		1859	`break;`
2	7u83	1860	`}`
7	7u83	1861	`}`
		1862	`return (bs);`
2	7u83	1863	`}`
		1864
		1865
		1866	`/*`
		1867	`DO TWO TYPES HAVE THE SAME REPRESENTATION?`
		1868
		1869	`This routine returns true if the types s and t have the same`
		1870	`representation as shapes (or alignments if ptr is true) in TDF.`
		1871	`*/`
		1872
7	7u83	1873	`int`
		1874	`eq_type_rep(TYPE s, TYPE t, int ptr)`
2	7u83	1875	`{`
7	7u83	1876	`unsigned ns, nt;`
		1877	`if (EQ_type(s, t)) {`
		1878	`return (1);`
		1879	`}`
		1880	`if (IS_NULL_type(s) \|\| IS_NULL_type(t)) {`
		1881	`return (0);`
		1882	`}`
		1883	`ns = TAG_type(s);`
		1884	`nt = TAG_type(t);`
2	7u83	1885
7	7u83	1886	`/* Check the first type */`
		1887	`switch (ns) {`
		1888	`case type_top_tag:`
		1889	`case type_bottom_tag: {`
		1890	`/* Top and bottom types */`
		1891	`if (nt == ns) {`
		1892	`return (1);`
		1893	`}`
		1894	`if (nt == type_top_tag \|\| nt == type_bottom_tag) {`
		1895	`/* alignment ( top ) == alignment ( bottom ) */`
		1896	`return (ptr);`
		1897	`}`
		1898	`break;`
2	7u83	1899	`}`
7	7u83	1900	`case type_ptr_tag:`
		1901	`case type_ref_tag: {`
		1902	`/* Pointer and reference types */`
		1903	`if (nt == type_ptr_tag \|\| nt == type_ref_tag) {`
		1904	`TYPE ps, pt;`
		1905	`if (ptr) {`
		1906	`/* alignment ( pointer ( s ) ) is constant */`
		1907	`return (1);`
		1908	`}`
		1909	`ps = DEREF_type(type_ptr_etc_sub(s));`
		1910	`pt = DEREF_type(type_ptr_etc_sub(t));`
		1911	`return (eq_type_rep(ps, pt, 1));`
2	7u83	1912	`}`
7	7u83	1913	`break;`
2	7u83	1914	`}`
7	7u83	1915	`case type_ptr_mem_tag: {`
		1916	`/* Pointer to member types */`
		1917	`if (nt == type_ptr_mem_tag) {`
		1918	`TYPE ps = DEREF_type(type_ptr_mem_sub(s));`
		1919	`TYPE pt = DEREF_type(type_ptr_mem_sub(t));`
		1920	`if (IS_type_func(ps)) {`
		1921	`if (IS_type_func(pt)) {`
		1922	`/* Pointers to member functions */`
		1923	`return (1);`
		1924	`}`
		1925	`} else {`
		1926	`if (!IS_type_func(pt)) {`
		1927	`/* Pointers to data members */`
		1928	`return (1);`
		1929	`}`
		1930	`}`
2	7u83	1931	`}`
7	7u83	1932	`break;`
2	7u83	1933	`}`
7	7u83	1934	`case type_func_tag: {`
		1935	`/* Function types */`
		1936	`if (nt == type_func_tag) {`
		1937	`/* All functions have the same representation */`
		1938	`return (1);`
		1939	`}`
		1940	`break;`
2	7u83	1941	`}`
7	7u83	1942	`case type_array_tag: {`
		1943	`/* Array types */`
		1944	`if (ptr) {`
		1945	`/* alignment ( nof ( n, s ) ) == alignment ( s ) */`
		1946	`TYPE ps = DEREF_type(type_array_sub(s));`
		1947	`return (eq_type_rep(ps, t, 1));`
2	7u83	1948	`}`
7	7u83	1949	`if (nt == type_array_tag) {`
		1950	`NAT ms = DEREF_nat(type_array_size(s));`
		1951	`NAT mt = DEREF_nat(type_array_size(t));`
		1952	`if (EQ_nat(ms, mt) \|\| eq_nat(ms, mt)) {`
		1953	`TYPE ps = DEREF_type(type_array_sub(s));`
		1954	`TYPE pt = DEREF_type(type_array_sub(t));`
		1955	`return (eq_type_rep(ps, pt, 0));`
		1956	`}`
		1957	`}`
		1958	`break;`
2	7u83	1959	`}`
7	7u83	1960	`case type_enumerate_tag: {`
		1961	`/* Enumeration types */`
		1962	`ENUM_TYPE es = DEREF_etype(type_enumerate_defn(s));`
		1963	`TYPE ps = DEREF_type(etype_rep(es));`
		1964	`return (eq_type_rep(ps, t, ptr));`
2	7u83	1965	`}`
7	7u83	1966	`}`
2	7u83	1967
7	7u83	1968	`/* Check the second type */`
		1969	`switch (nt) {`
		1970	`case type_array_tag: {`
		1971	`/* Array types */`
		1972	`if (ptr) {`
		1973	`/* alignment ( nof ( n, t ) ) == alignment ( t ) */`
		1974	`TYPE pt = DEREF_type(type_array_sub(t));`
		1975	`return (eq_type_rep(s, pt, 1));`
		1976	`}`
		1977	`break;`
2	7u83	1978	`}`
7	7u83	1979	`case type_enumerate_tag: {`
		1980	`/* Enumeration types */`
		1981	`ENUM_TYPE et = DEREF_etype(type_enumerate_defn(t));`
		1982	`TYPE pt = DEREF_type(etype_rep(et));`
		1983	`return (eq_type_rep(s, pt, ptr));`
2	7u83	1984	`}`
7	7u83	1985	`}`
2	7u83	1986
7	7u83	1987	`/* Compare the types */`
		1988	`if (ns == nt) {`
		1989	`if (ptr) {`
		1990	`return (eq_type_offset(s, t));`
		1991	`}`
		1992	`return (eq_type_unqual(s, t));`
		1993	`}`
		1994	`return (0);`
2	7u83	1995	`}`
		1996
		1997
		1998	`#endif /* TDF_OUTPUT */`

Subversion Repositories tendra.SVN

(root)/branches/algol60/src/producers/common/output/shape.c – Rev 7