WebSVN – tendra.SVN – Diff – /branches/tendra5/src/installers/680x0/common/coder.c

+/*
+ * Copyright (c) 2002-2006 The TenDRA Project <http://www.tendra.org/>.
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * 1. Redistributions of source code must retain the above copyright notice,
+ *    this list of conditions and the following disclaimer.
+ * 2. Redistributions in binary form must reproduce the above copyright notice,
+ *    this list of conditions and the following disclaimer in the documentation
+ *    and/or other materials provided with the distribution.
+ * 3. Neither the name of The TenDRA Project nor the names of its contributors
+ *    may be used to endorse or promote products derived from this software
+ *    without specific, prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+ * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+ * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+ * PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+ * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+ * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+ * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+ * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ * $Id$
+ */
 /*
     		 Crown Copyright (c) 1997
     This TenDRA(r) Computer Program is subject to Copyright
     owned by the United Kingdom Secretary of State for Defence
 #if have_diagnostics
 #include "xdb_basics.h"
 #endif
-extern int do_peephole ;
+extern int do_peephole;
-extern int normal_version ;
+extern int normal_version;
-static int extra_weight = 0 ;
+static int extra_weight = 0;
 /*
     ADD A SHAPE TO A THE STACK
     Given an ash p, representing the stack, and a shape s, this procedure
     returns the ast correponding to the new stack formed by adding s to the
     old stack.
 */
-ast add_shape_to_stack
+ast
-    PROTO_N ( ( p, s ) )
-    PROTO_T ( ash p X shape s )
+add_shape_to_stack(ash p, shape s)
+{
-    ast res ;
+	ast res;
-    char n = name ( s ) ;
+	char n = name(s);
-    long sz = shape_size ( s ) ;
+	long sz = shape_size(s);
-    long adj = 0 ;
+	long adj = 0;
-    if ( n == scharhd || n == ucharhd || n == swordhd || n == uwordhd ) {
+	if (n == scharhd || n == ucharhd || n == swordhd || n == uwordhd) {
-	adj = SLONG_SZ - sz ;
+		adj = SLONG_SZ - sz;
-	sz = SLONG_SZ ;
+		sz = SLONG_SZ;
-    }
+	}
-    if ( n == bitfhd ) sz = SLONG_SZ ;
+	if (n == bitfhd) {
+		sz = SLONG_SZ;
+	}
-    res.astoff = round ( p, param_align ) ;
+	res.astoff = round(p, param_align);
-    res.astadj = adj ;
+	res.astadj = adj;
-    res.astash = round ( res.astoff + sz, param_align ) ;
+	res.astash = round(res.astoff + sz, param_align);
-    return ( res ) ;
+	return (res);
+}
 /*
     REGISTER ALLOCATION ROUTINES
     gives the breakpoint - the minimum number of registers which need to
     be free for it to be worth putting this value in a register.  The big
     flag is true to indicate that a register which is preserved across
     procedure calls is required.  If a register can be allocated, then
     its bitpattern is returned.  Otherwise 0 is returned.
 */
-static bitpattern alloc_reg
+static bitpattern
-    PROTO_N ( ( sha, br, big ) )
-    PROTO_T ( shape sha X int br X bool big )
+alloc_reg(shape sha, int br, bool big)
 {
-    int go = 1 ;
+	int go = 1;
-    bitpattern mask ;
+	bitpattern mask;
-    bitpattern rs = regsinuse ;
+	bitpattern rs = regsinuse;
-    int i, start, end, rev = 0 ;
+	int i, start, end, rev = 0;
-    int rg ;
+	int rg;
-    int r = shtype ( sha ) ;
+	int r = shtype(sha);
-    if ( r == Dreg ) {
+	if (r == Dreg) {
-	rg = bits_in ( ~rs & 0x00fc ) ;
+		rg = bits_in(~rs & 0x00fc);
-	mask = regmsk ( REG_D2 ) ;
+		mask = regmsk(REG_D2);
-	start =  REG_D2 ;
+		start =  REG_D2;
-	end = REG_D7 ;
+		end = REG_D7;
-    } else if ( r == Areg ) {
+	} else if (r == Areg) {
-	rg = bits_in ( ~rs & 0x3c00 ) ;
+		rg = bits_in(~rs & 0x3c00);
-	mask = regmsk ( REG_A2 ) ;
+		mask = regmsk(REG_A2);
-	start = REG_A2 ;
+		start = REG_A2;
-	end = REG_A5 ;
+		end = REG_A5;
-	if ( br > extra_weight ) br -= extra_weight ;
+		if (br > extra_weight) {
+			br -= extra_weight;
+		}
-    } else if ( r == Freg ) {
+	} else if (r == Freg) {
-	if ( round_after_flop ) return ( 0 ) ;
+		if (round_after_flop) {
+			return (0);
+		}
-	rg = bits_in ( ~rs & 0xfc0000 ) ;
+		rg = bits_in(~rs & 0xfc0000);
-	mask = regmsk ( REG_FP7 ) ;
+		mask = regmsk(REG_FP7);
-	start = REG_FP7 ;
+		start = REG_FP7;
-	end = REG_FP2 ;
+		end = REG_FP2;
-	rev = 1 ;
+		rev = 1;
-    } else {
+	} else {
-	error ( "Illegal register type" ) ;
+		error("Illegal register type");
-	return ( 0 ) ;
+		return (0);
-    }
+	}
-    if ( rg < br || rg == 0 ) return ( 0 ) ;
+	if (rg < br || rg == 0) {
+		return (0);
+	}
-    i = start ;
+	i = start;
-    while ( go ) {
+	while (go) {
-	if ( !( rs & mask ) ) {
+		if (!(rs & mask)) {
-	    if ( big ) {
+			if (big) {
-		bigregs |= mask ;
+				bigregs |= mask;
+				if (r == Freg) {
-		if ( r == Freg ) normal_version = 0 ;
+					normal_version = 0;
-	    }
+				}
+			}
-	    regsinproc |= mask ;
+			regsinproc |= mask;
-	    return ( mask ) ;
+			return (mask);
-	}
+		}
-	if ( i == end ) {
+		if (i == end) {
-	    go = 0 ;
+			go = 0;
-	} else {
+		} else {
-	    if ( rev ) {
+			if (rev) {
-		i-- ;
+				i--;
-		mask >>= 1 ;
+				mask >>= 1;
-	    } else {
+			} else {
-		i++ ;
+				i++;
-		mask <<= 1 ;
+				mask <<= 1;
-	    }
+			}
-	}
+		}
-    }
+	}
-    return ( 0 ) ;
+	return (0);
 }
 /*
     IS A GIVEN EXPRESSION A USE OF A REUSABLE REGISTER?
     This routine returns 0 if the expression e is not a use of a reuseable
     register, and the bitmask of the register otherwise.
 */
-static long reuse_check
-    PROTO_N ( ( e ) )
-    PROTO_T ( exp e )
-{
-    exp id ;
-    if ( name ( e ) != name_tag ) return ( 0 ) ;
-    id = son ( e ) ;
-    if ( isglob ( id ) || pt ( id ) != reg_pl ) return ( 0 ) ;
-    return ( reuseables & no ( id ) ) ;
-}
-/*
-    CAN WE REUSE A REGISTER?
-    This routine checks whether or not we can use a reuseable register to
-    store def.  It returns the bitmask of a suitable register if so and 0
-    otherwise.
-*/
-static long reuse
+static long
-    PROTO_N ( ( def ) )
-    PROTO_T ( exp def )
+reuse_check(exp e)
+{
-    switch ( name ( def ) ) {
+	exp id;
-	case name_tag : {
+	if (name(e) != name_tag) {
-	    return ( reuse_check ( def ) ) ;
+		return (0);
+	}
+	id = son(e);
+	if (isglob(id) || pt(id) != reg_pl) {
+		return (0);
+	}
+	return (reuseables & no(id));
+}
+/*
+    CAN WE REUSE A REGISTER?
+    This routine checks whether or not we can use a reuseable register to
+    store def.  It returns the bitmask of a suitable register if so and 0
+    otherwise.
+*/
+static long
+reuse(exp def)
+{
+	switch (name(def)) {
+	case name_tag:
+		return (reuse_check(def));
-	case plus_tag :
+	case plus_tag:
-	case and_tag :
+	case and_tag:
-	case or_tag :
+	case or_tag:
-	case xor_tag :
+	case xor_tag:
-	case mult_tag : {
+	case mult_tag: {
-	    /* Allow at most two arguments - check both */
+		/* Allow at most two arguments - check both */
-	    exp arg1 = son ( def ) ;
+		exp arg1 = son(def);
-	    exp arg2 = bro ( arg1 ) ;
+		exp arg2 = bro(arg1);
-	    if ( last ( arg1 ) ) {
+		if (last(arg1)) {
-		return ( reuse_check ( arg1 ) ) ;
+			return (reuse_check(arg1));
-	    }
+		}
-	    if ( last ( arg2 ) ) {
+		if (last(arg2)) {
-		return ( reuse_check ( arg1 ) || reuse_check ( arg2 ) ) ;
+			return (reuse_check(arg1) || reuse_check(arg2));
-	    }
+		}
-	    return ( 0 ) ;
+		return (0);
 	}
-	case chvar_tag :
+	case chvar_tag:
-	case neg_tag :
+	case neg_tag:
-	case not_tag : {
+	case not_tag:
-	    /* Check one argument */
+		/* Check one argument */
-	    return ( reuse_check ( son ( def ) ) ) ;
+		return (reuse_check(son(def)));
+	case minus_tag:
+	case subptr_tag:
+	case minptr_tag:
+	case shl_tag:
+	case shr_tag: {
+		/* Check two arguments */
+		exp arg1 = son(def);
+		exp arg2 = bro(arg1);
+		return (reuse_check(arg1) || reuse_check(arg2));
+	}
-	case minus_tag :
-	case subptr_tag :
-	case minptr_tag :
-	case shl_tag :
-	case shr_tag : {
-	    /* Check two arguments */
-	    exp arg1 = son ( def ) ;
-	    exp arg2 = bro ( arg1 ) ;
-	    return ( reuse_check ( arg1 ) || reuse_check ( arg2 ) ) ;
+	}
-    }
-    return ( 0 ) ;
+	return (0);
+}
 /*
     IS AN EXPRESSION GUARANTEED NOT TO USE D0?
     Or if it is, are we really careful?
 */
-static bool nouse
+static bool
-    PROTO_N ( ( e ) )
-    PROTO_T ( exp e )
+nouse(exp e)
+{
-    char n = name ( e ) ;
+	char n = name(e);
-    if ( n == test_tag ) return ( 1 ) ;
+	if (n == test_tag) {
+		return (1);
+	}
-    return ( 0 ) ;
+	return (0);
+}
 /*
     WHERE IS A DECLARATION TO BE PUT?
     registers).  new_stack gives the ash of the stack after this declaration.
     is_new is a flag indicating a new declaration or a reuse of an old
     declaration.
 */
-static allocation alloc_variable
+static allocation
-    PROTO_N ( ( e, def, stack ) )
-    PROTO_T ( exp e X exp def X ash stack )
+alloc_variable(exp e, exp def, ash stack)
+{
-    ast locast ;
+	ast locast;
-    allocation dc ;
+	allocation dc;
-    bitpattern ru ;
+	bitpattern ru;
-    unsigned char n = name ( def ) ;
+	unsigned char n = name(def);
-    exp s = son ( def ) ;
+	exp s = son(def);
-    exp body = bro ( def ) ;
+	exp body = bro(def);
-    int br = ( int ) no ( e ) ;
+	int br = (int)no(e);
-    bool force_reg = isusereg ( e ) ;
+	bool force_reg = isusereg(e);
-    bool big = ( props ( e ) & 0x80 ? 1 : 0 ) ;
+	bool big = (props(e) & 0x80 ? 1 : 0);
-    bool in_reg1 = 0, in_reg2 = 0, in_reg3 = 1 ;
+	bool in_reg1 = 0, in_reg2 = 0, in_reg3 = 1;
-    dc.new_stack = stack ;
+	dc.new_stack = stack;
-    dc.is_new = 1 ;
+	dc.is_new = 1;
-    if ( name ( sh ( def ) ) == tophd && !isvis(e)) {
+	if (name(sh(def)) == tophd && !isvis(e)) {
-	dc.place = nowhere_pl ;
+		dc.place = nowhere_pl;
-	dc.num = 0 ;
+		dc.num = 0;
-	return ( dc ) ;
+		return (dc);
-    }
+	}
-    if ( n == name_tag ) {
+	if (n == name_tag) {
-	in_reg1 = ( !isvar ( s ) && ( no ( def ) == 0 || !isglob ( s ) ) ) ;
+		in_reg1 = (!isvar(s) && (no(def) == 0 || !isglob(s)));
-    } else if ( n == cont_tag && name ( s ) == name_tag ) {
+	} else if (n == cont_tag && name(s) == name_tag) {
-	exp t = son ( s ) ;
+		exp t = son(s);
-	in_reg2 = ( isvar ( t ) && ( no ( s ) == 0 || !isglob ( t ) ) &&
+		in_reg2 = (isvar(t) && (no(s) == 0 || !isglob(t)) &&
-		    no_side ( body ) ) ;
+			   no_side(body));
-    }
+	}
-    if ( !isvar ( e ) && ( in_reg1 || in_reg2 ) ) {
+	if (!isvar(e) && (in_reg1 || in_reg2)) {
-	/* Re-identification or contents of variable not altered in body */
+		/* Re-identification or contents of variable not altered in
+		 * body */
-	if ( in_reg1 ) {
+		if (in_reg1) {
-	    dc.place = ptno ( s ) ;
+			dc.place = ptno(s);
 #ifndef tdf3
-            switch ( ptno (s) ) {
+			switch (ptno(s)) {
-            case var_pl:
+			case var_pl:
-		dc.num = no ( s ) - no ( def ) ;
+				dc.num = no(s) - no(def);
-                break;
+				break;
-            case par3_pl:
+			case par3_pl:
-            case par2_pl:
+			case par2_pl:
-		dc.num = no ( s ) - no ( def ) ;
+				dc.num = no(s) - no(def);
-                break;
+				break;
-            default:
+			default:
-		dc.num = no ( s ) + no ( def ) ;
+				dc.num = no(s) + no(def);
-            }
+			}
 #else
-	    if ( ptno ( s ) == var_pl ) {
+			if (ptno(s) == var_pl) {
-		dc.num = no ( s ) - no ( def ) ;
+				dc.num = no(s) - no(def);
-	    } else {
+			} else {
-		dc.num = no ( s ) + no ( def ) ;
+				dc.num = no(s) + no(def);
-	    }
+			}
 #endif
-	} else {
-	    s = son ( s ) ;
-	    dc.place = ptno ( s ) ;
-	    if ( ptno ( s ) == var_pl ) {
-		dc.num = no ( s ) - no ( son ( def ) ) ;
-	    } else {
-		dc.num = no ( s ) + no ( son ( def ) ) ;
-	    }
-	}
-	/* We have a declaration */
-	if ( dc.place == reg_pl ) {
-	    /* If the old one was in registers, reuse it */
-	    dc.is_new = 0 ;
-	    return ( dc ) ;
-	}
-	if ( !force_reg ) {
-	    if ( regable ( e ) ) {
-		ru = alloc_reg ( sh ( def ), br, big ) ;
-		if ( ru ) {
-		    dc.place = reg_pl ;
-		    dc.num = ru ;
-		    return ( dc ) ;
-		}
-	    }
-	    if ( isglob ( s ) ) {
-		locast = add_shape_to_stack ( stack, sh ( def ) ) ;
-		dc.new_stack = locast.astash ;
-		dc.place = var_pl ;
-		if ( locast.astadj ) {
-		    dc.num = locast.astoff + locast.astadj ;
 		} else {
+			s = son(s);
+			dc.place = ptno(s);
+			if (ptno(s) == var_pl) {
+				dc.num = no(s) - no(son(def));
+			} else {
+				dc.num = no(s) + no(son(def));
+			}
+		}
+		/* We have a declaration */
+		if (dc.place == reg_pl) {
+			/* If the old one was in registers, reuse it */
+			dc.is_new = 0;
+			return (dc);
+		}
+		if (!force_reg) {
+			if (regable(e)) {
+				ru = alloc_reg(sh(def), br, big);
+				if (ru) {
+					dc.place = reg_pl;
+					dc.num = ru;
+					return (dc);
+				}
+			}
+			if (isglob(s)) {
+				locast = add_shape_to_stack(stack, sh(def));
+				dc.new_stack = locast.astash;
+				dc.place = var_pl;
+				if (locast.astadj) {
+					dc.num = locast.astoff + locast.astadj;
+				} else {
-		    dc.num = locast.astash ;
+					dc.num = locast.astash;
-		}
+				}
-		return ( dc ) ;
+				return (dc);
-	    }
+			}
-	    /* If there was not room, reuse the old dec */
+			/* If there was not room, reuse the old dec */
-	    dc.is_new = 0 ;
+			dc.is_new = 0;
-	    return ( dc ) ;
+			return (dc);
-	}
+		}
-	if ( regable ( e ) ) {
+		if (regable(e)) {
-	    ru = alloc_reg ( sh ( def ), br, big ) ;
+			ru = alloc_reg(sh(def), br, big);
-	    if ( ru ) {
+			if (ru) {
-		dc.place = reg_pl ;
+				dc.place = reg_pl;
-		dc.num = ru ;
+				dc.num = ru;
-		return ( dc ) ;
+				return (dc);
-	    }
+			}
-	    if ( isglob ( s ) ) {
+			if (isglob(s)) {
-		locast = add_shape_to_stack ( stack, sh ( def ) ) ;
+				locast = add_shape_to_stack(stack, sh(def));
-		dc.new_stack = locast.astash ;
+				dc.new_stack = locast.astash;
-		dc.place = var_pl ;
+				dc.place = var_pl;
-		if ( locast.astadj ) {
+				if (locast.astadj) {
-		    dc.num = locast.astoff + locast.astadj ;
+					dc.num = locast.astoff + locast.astadj;
-		} else {
+				} else {
-		    dc.num = locast.astash ;
+					dc.num = locast.astash;
+				}
+				return (dc);
+			}
+			dc.is_new = 0;
+			return (dc);
+		}
+		return (dc);
+	}
+	if (n == apply_tag || n == apply_general_tag || n == tail_call_tag) {
+		in_reg3 = result_in_reg(sh(def));
+	}
+	/* Try to allocate in registers */
+	if (regable(e) && in_reg3) {
+		if ((n == apply_tag || n == apply_general_tag ||
+		     n == tail_call_tag) && shtype(sh(def)) != Freg &&
+		    nouse(bro(def))) {
+			dc.place = reg_pl;
+			dc.num = regmsk(REG_D0);
+			return (dc);
+		}
+		if (is_a(n)) {
+			long rg = reuse(def) & 0x3cfc;
+			if (rg) {
+				reuseables &= ~rg;
+				dc.place = reg_pl;
+				dc.num = rg;
+				return (dc);
+			}
+		}
+		ru = alloc_reg(sh(def), br, big);
+		if (ru) {
+			dc.place = reg_pl;
+			dc.num = ru;
+			return (dc);
+		}
-		return ( dc ) ;
-	    }
-	    dc.is_new = 0 ;
-	    return ( dc ) ;
+	}
-	return ( dc ) ;
-    }
-    if ( n == apply_tag || n == apply_general_tag || n == tail_call_tag )
-    in_reg3 = result_in_reg ( sh ( def ) ) ;
-    /* Try to allocate in registers */
+	/* Otherwise allocate on the stack */
-    if ( regable ( e ) && in_reg3 ) {
+	locast = add_shape_to_stack(stack, sh(def));
-	if ( ( n == apply_tag || n == apply_general_tag || n == tail_call_tag )
+	dc.new_stack = locast.astash;
-            && shtype ( sh ( def ) ) != Freg && nouse ( bro ( def ) ) ) {
-	    dc.place = reg_pl ;
+	dc.place = var_pl;
-	    dc.num = regmsk ( REG_D0 ) ;
-	    return ( dc ) ;
-	}
-	if ( is_a ( n ) ) {
+	if (locast.astadj) {
-	    long rg = reuse ( def ) & 0x3cfc ;
+		dc.num = locast.astoff + locast.astadj;
-	    if ( rg ) {
+	} else {
-		reuseables &= ~rg ;
-		dc.place = reg_pl ;
-		dc.num = rg ;
+		dc.num = locast.astash;
-		return ( dc ) ;
-	    }
+	}
-	ru = alloc_reg ( sh ( def ), br, big ) ;
-	if ( ru ) {
-	    dc.place = reg_pl ;
-	    dc.num = ru ;
-	    return ( dc ) ;
+	return (dc);
-	}
-    }
-    /* Otherwise allocate on the stack */
-    locast = add_shape_to_stack ( stack, sh ( def ) ) ;
-    dc.new_stack = locast.astash ;
-    dc.place = var_pl ;
-    if ( locast.astadj ) {
-	dc.num = locast.astoff + locast.astadj ;
-    } else {
-	dc.num = locast.astash ;
-    }
-    return ( dc ) ;
+}
 /*
     CURRENT SCOPES
     These variables are used for the scope and destination of inlined
     procedures.
 */
-static exp crt_rscope ;
+static exp crt_rscope;
-static where rscope_dest ;
+static where rscope_dest;
 /*
     The arguments are given by a bro-list starting with t.  They are
     coded in reverse order.
 */
-static void code_pars
+static void
-    PROTO_N ( ( w, stack, t ) )
-    PROTO_T ( where w X ash stack X exp t )
+code_pars(where w, ash stack, exp t)
+{
-    long sz = shape_size ( sh ( t ) ) ;
+	long sz = shape_size(sh(t));
-    if ( last ( t ) ) {
+	if (last(t)) {
-	/* Code last argument */
+		/* Code last argument */
-	coder ( w, stack, t ) ;
+		coder(w, stack, t);
-	stack_dec -= round ( sz, param_align ) ;
+		stack_dec -= round(sz, param_align);
-    } else {
+	} else {
-	/* Code the following arguments */
+		/* Code the following arguments */
-	code_pars ( w, stack, bro ( t ) ) ;
+		code_pars(w, stack, bro(t));
-	/* And then this one */
+		/* And then this one */
-	coder ( w, stack, t ) ;
+		coder(w, stack, t);
-	stack_dec -= round ( sz, param_align ) ;
+		stack_dec -= round(sz, param_align);
-    }
+	}
-    return ;
+	return;
+}
 /*
     PRODUCE CODE FOR A SOLVE STATEMENT
     The solve statement with starter s, labelled statements l, destination
     dest and default jump jr is processed.
 */
-static void solve
+static void
-    PROTO_N ( ( s, l, dest, jr, stack ) )
-    PROTO_T ( exp s X exp l X where dest X exp jr X ash stack )
+solve(exp s, exp l, where dest, exp jr, ash stack)
 {
-    exp t ;
+	exp t;
-    long r1 ;
+	long r1;
-    while ( !last ( l ) ) {
+	while (!last(l)) {
-	allocation dc ;
+		allocation dc;
-	long lb = next_lab () ;
+		long lb = next_lab();
-	exp record = simple_exp ( 0 ) ;
+		exp record = simple_exp(0);
-	if ( props ( son ( bro ( l ) ) ) & 2 ) setlast ( record ) ;
+		if (props(son(bro(l))) & 2) {
+			setlast(record);
+		}
-	no ( record ) = stack ;
+		no(record) = stack;
-	sonno ( record ) = stack_dec ;
+		sonno(record) = stack_dec;
-	ptno ( record ) = lb ;
+		ptno(record) = lb;
-	pt ( son ( bro ( l ) ) ) = record ;
+		pt(son(bro(l))) = record;
-	dc = alloc_variable ( bro ( l ), son ( bro ( l ) ), stack ) ;
+		dc = alloc_variable(bro(l), son(bro(l)), stack);
-	ptno ( bro ( l ) ) = dc.place ;
+		ptno(bro(l)) = dc.place;
-	no ( bro ( l ) ) = dc.num ;
+		no(bro(l)) = dc.num;
-	l = bro ( l ) ;
+		l = bro(l);
-    }
+	}
-    r1 = regsinuse ;
+	r1 = regsinuse;
-    if ( name ( s ) != goto_tag || pt ( s ) != bro ( s ) ) {
+	if (name(s) != goto_tag || pt(s) != bro(s)) {
-	/* Code the starting expression */
+		/* Code the starting expression */
-	have_cond = 0 ;
+		have_cond = 0;
-	coder ( dest, stack, s ) ;
+		coder(dest, stack, s);
-    }
+	}
-    t = s ;
+	t = s;
-    do {
+	do {
-	regsinuse = r1 ;
+		regsinuse = r1;
+		if (name(sh(t)) != bothd) {
-	if ( name ( sh ( t ) ) != bothd ) make_jump ( m_bra, ptno ( jr ) ) ;
+			make_jump(m_bra, ptno(jr));
+		}
-	t = bro ( t ) ;
+		t = bro(t);
-	if ( no ( son ( t ) ) > 0 ) {
+		if (no(son(t)) > 0) {
-	    make_label ( ptno ( pt ( son ( t ) ) ) ) ;
+			make_label(ptno(pt(son(t))));
-	    coder ( dest, stack, t ) ;
+			coder(dest, stack, t);
-	}
+		}
-    } while ( !last ( t ) ) ;
+	} while (!last(t));
-    regsinuse = r1 ;
+	regsinuse = r1;
-    have_cond = 0 ;
+	have_cond = 0;
-    return ;
+	return;
 }
 /*
     PRODUCE CODE FOR A CASE STATEMENT
     The controlling number of the case statement is in the D1 register, from
     which already has been deducted.  The list of options is given as a
     bro-list in arg.  The routine returns the total number which has been
     deducted from D1 at the end.
 */
-static long caser
+static long
-    PROTO_N ( ( arg, already ) )
-    PROTO_T ( exp arg X long already )
+caser(exp arg, long already)
+{
-    bool sw, go = 1, diff = 0 ;
+	bool sw, go = 1, diff = 0;
-    exp t, jr, jt, split_at ;
+	exp t, jr, jt, split_at;
-    shape sha = sh ( arg ) ;
+	shape sha = sh(arg);
-    double low, high ;
+	double low, high;
-    double lowest = LONG_MAX, highest = LONG_MIN ;
+	double lowest = LONG_MAX, highest = LONG_MIN;
-    long i, j, n, *jtab ;
+	long i, j, n, *jtab;
-    long worth = 0 ;
+	long worth = 0;
-    for ( t = bro ( arg ) ; go && ( t != nilexp ) ; t = bro ( t ) ) {
-       if (is_signed(sh(t))) low = no (t) ;
-       else low = (unsigned) no(t) ;
-       if (son(t)) {
-          if (is_signed(sh(son(t)))) high = no(son(t)) ;
-          else high =(unsigned) no(son(t)) ;
-       }
-       else high = low ;
-	if ( low != high ) diff = 1 ;
-	if ( low < lowest ) lowest = low ;
-	if ( high > highest ) highest = high ;
-	worth += ( low == high ? 1 : 2 ) ;
-	if ( bro ( t ) != nilexp ) {
+	for (t = bro(arg); go && (t != nilexp); t = bro(t)) {
-           double nextlow;
-           if (is_signed(sh(bro(t)))) nextlow = no(bro(t));
+		if (is_signed(sh(t))) {
-           else nextlow = (unsigned) no(bro(t));
-	    if ( ( nextlow / 2 ) > ( high / 2 ) + 20 ) {
-		split_at = t ;
+			low = no(t);
-		go = 0 ;
+		}
-	    }
+		else {
+			low = (unsigned)no(t);
-	}
+		}
-#ifndef tdf3
+		if (son(t)) {
-        if (high/2 > low/2 + 20) {
+			if (is_signed(sh(son(t)))) {
-           worth = 0 ;
+				high = no(son(t));
-        }
+			} else {
+				high = (unsigned)no(son(t));
-#endif
+			}
+		} else {
+			high = low;
-    }
+		}
+		if (low != high) {
+			diff = 1;
+		}
+		if (low < lowest) {
+			lowest = low;
+		}
+		if (high > highest) {
+			highest = high;
+		}
+		worth += (low == high ? 1 : 2);
+		if (bro(t) != nilexp) {
+			double nextlow;
+			if (is_signed(sh(bro(t)))) {
+				nextlow = no(bro(t));
+			} else {
+				nextlow = (unsigned)no(bro(t));
+			}
+			if ((nextlow / 2) > (high / 2) + 20) {
+				split_at = t;
+				go = 0;
+			}
+		}
+#ifndef tdf3
+		if (high / 2 > low / 2 + 20) {
+			worth = 0;
+		}
+#endif
+	}
-    if ( !go ) {
+	if (!go) {
-	/* Split into two */
+		/* Split into two */
-	long a ;
+		long a;
-	exp new = copyexp ( arg ) ;
+		exp new = copyexp(arg);
-	exp old_bro = bro ( split_at ) ;
+		exp old_bro = bro(split_at);
-	bro ( new ) = old_bro ;
+		bro(new) = old_bro;
-	bro ( split_at ) = nilexp ;
+		bro(split_at) = nilexp;
-	setlast ( split_at ) ;
+		setlast(split_at);
-	/* Code the first half */
+		/* Code the first half */
-	a = caser ( arg, already ) ;
+		a = caser(arg, already);
-	/* Code the second half */
+		/* Code the second half */
-	return ( caser ( new, a ) ) ;
+		return (caser(new, a));
-    }
+	}
-    if ( worth > 2 ) {
+	if (worth > 2) {
-	/* Construct a jump table */
+		/* Construct a jump table */
-	mach_op *op1, *op2 ;
+		mach_op *op1, *op2;
-	long rlab = next_lab () ;
+		long rlab = next_lab();
-	long tlab = next_lab () ;
+		long tlab = next_lab();
-	long slab = next_lab () ;
+		long slab = next_lab();
-	n = highest - lowest + 1 ;
+		n = highest - lowest + 1;
-	jtab = ( long * ) xcalloc ( n, sizeof ( long ) ) ;
+		jtab = (long *)xcalloc(n, sizeof(long));
-	for ( i = 0 ; i < n ; i++ ) jtab [i] = rlab ;
+		for (i = 0; i < n; i++) {
+			jtab[i] = rlab;
+		}
-	for ( t = bro ( arg ) ; t != nilexp ; t = bro ( t ) ) {
+		for (t = bro(arg); t != nilexp; t = bro(t)) {
-           if (is_signed(sh(t))) low = no (t) ;
+			if (is_signed(sh(t))) {
+				low = no(t);
+			} else {
-           else low = (unsigned) no(t) ;
+				low = (unsigned)no(t);
+			}
-           if (son(t)) {
+			if (son(t)) {
-              if (is_signed(sh(son(t)))) high = no(son(t)) ;
+				if (is_signed(sh(son(t)))) {
+					high = no(son(t));
+				} else {
-              else high =(unsigned) no(son(t)) ;
+					high = (unsigned)no(son(t));
+				}
-           }
+			} else {
-           else high = low ;
+				high = low;
+			}
-           j = ptno ( pt ( son ( pt ( t ) ) ) ) ;
+			j = ptno(pt(son(pt(t))));
-           for ( i = low ; i <= high ; i++ ) jtab [ i - (long)lowest ] = j ;
+			for (i = low; i <= high; i++) {
+				jtab[i - (long)lowest] = j;
+			}
-	}
+		}
-	/* Move offset into D1 */
+		/* Move offset into D1 */
-	jt = simple_exp ( 0 ) ;
+		jt = simple_exp(0);
-	ptno ( jt ) = rlab ;
+		ptno(jt) = rlab;
+		/*
-	/* Subtract the lowest value (minus anything already deducted) */
+		 * Subtract the lowest value (minus anything already deducted).
+		 */
-	sub ( slongsh, mnw ( lowest - already ), D1, D1 ) ;
+		sub(slongsh, mnw(lowest - already), D1, D1);
-	sw = cmp ( slongsh, D1, mnw ( highest - lowest ), tst_gr ) ;
+		sw = cmp(slongsh, D1, mnw(highest - lowest), tst_gr);
-	branch ( tst_gr, jt, 0, sw, 0 ) ;
+		branch(tst_gr, jt, 0, sw, 0);
-	/* Move displacement into D0 */
+		/* Move displacement into D0 */
 #if 0
-	op1 = make_reg_index ( REG_ZA0, REG_D1, 0, 4 ) ;
+		op1 = make_reg_index(REG_ZA0, REG_D1, 0, 4);
-	op1->of->plus->plus = make_lab ( slab, 0 ) ;
+		op1->of->plus->plus = make_lab(slab, 0);
-	regsinproc |= regmsk ( REG_A0 ) ;
+		regsinproc |= regmsk(REG_A0);
-	debug_warning ( "%%za0 used" ) ;
+		debug_warning("%%za0 used");
 #else
-	op1 = make_lab_ind ( slab, 0 ) ;
+		op1 = make_lab_ind(slab, 0);
-	i = tmp_reg ( m_lea, op1 ) ;
+		i = tmp_reg(m_lea, op1);
-	op1 = make_reg_index ( i, REG_D1, 0, 4 ) ;
+		op1 = make_reg_index(i, REG_D1, 0, 4);
 #endif
-	op2 = make_register ( REG_D0 ) ;
+		op2 = make_register(REG_D0);
-	make_instr ( m_movl, op1, op2, regmsk ( REG_D0 ) ) ;
+		make_instr(m_movl, op1, op2, regmsk(REG_D0));
-	/* Do the jump */
-	op1 = make_reg_index ( REG_PC, REG_D0, 2, 1 ) ;
-	make_instr ( m_jmp, op1, null, 0 ) ;
-	/* Print out table */
+		/* Do the jump */
-	make_label ( tlab ) ;
-#ifndef no_align_directives
-	make_instr ( m_as_align4, null, null, 0 ) ;
-#endif
-	make_label ( slab ) ;
-	for ( i = 0 ; i < n ; i++ ) {
-	    op1 = make_lab_diff ( jtab [i], tlab ) ;
+		op1 = make_reg_index(REG_PC, REG_D0, 2, 1);
-	    make_instr ( m_as_long, op1, null, 0 ) ;
+		make_instr(m_jmp, op1, null, 0);
-	}
-	make_label ( rlab ) ;
+		/* Print out table */
+		make_label(tlab);
+#ifndef no_align_directives
+		make_instr(m_as_align4, null, null, 0);
+#endif
+		make_label(slab);
+		for (i = 0; i < n; i++) {
+			op1 = make_lab_diff(jtab[i], tlab);
+			make_instr(m_as_long, op1, null, 0);
+		}
+		make_label(rlab);
-	/* Return the total number deducted from D1 */
+		/* Return the total number deducted from D1 */
-	return ( lowest ) ;
+		return (lowest);
-    }
+	}
-    /* If 'high' is not always equal to 'low', restore value of D1 */
+	/* If 'high' is not always equal to 'low', restore value of D1 */
-    if ( diff ) {
+	if (diff) {
-	add ( slongsh, D1, mnw ( already ), D1 ) ;
+		add(slongsh, D1, mnw(already), D1);
-	already = 0 ;
+		already = 0;
-    }
+	}
-    /* A series of jumps/comparisons */
-    for ( t = bro ( arg ) ; t != nilexp ; t = bro ( t ) ) {
-       if (is_signed(sh(t))) low = no (t) ;
-       else low = (unsigned) no(t) ;
-       if (son(t)) {
-          if (is_signed(sh(son(t)))) high = no(son(t)) ;
-          else high =(unsigned) no(son(t)) ;
-       }
-       else high = low ;
+	/* A series of jumps/comparisons */
+	for (t = bro(arg); t != nilexp; t = bro(t)) {
+		if (is_signed(sh(t))) {
+			low = no(t);
+		} else {
+			low = (unsigned)no(t);
+		}
+		if (son(t)) {
+			if (is_signed(sh(son(t)))) {
+				high = no(son(t));
+			} else {
+				high = (unsigned)no(son(t));
+			}
+		} else {
+			high = low;
+		}
-	jr = pt ( son ( pt ( t ) ) ) ;
+		jr = pt(son(pt(t)));
-	if ( low == high ) {
+		if (low == high) {
-	    sw = cmp ( sha, D1, mnw ( low - already ), tst_eq ) ;
+			sw = cmp(sha, D1, mnw(low - already), tst_eq);
-	    branch ( tst_eq, jr, 1, sw, 0 ) ;
+			branch(tst_eq, jr, 1, sw, 0);
-	} else {
+		} else {
-	    jt = simple_exp ( 0 ) ;
+			jt = simple_exp(0);
-	    ptno ( jt ) = next_lab () ;
+			ptno(jt) = next_lab();
-	    sw = cmp ( sha, D1, mnw ( low - already ), tst_ls ) ;
+			sw = cmp(sha, D1, mnw(low - already), tst_ls);
-	    branch ( tst_ls, jt, is_signed ( sh ( t ) ), sw, 0 ) ;
+			branch(tst_ls, jt, is_signed(sh(t)), sw, 0);
-	    sw = cmp ( sha, D1, mnw ( (unsigned)(high - already) ), tst_le ) ;
+			sw = cmp(sha, D1, mnw((unsigned)(high - already)),
+				 tst_le);
-	    branch ( tst_le, jr, is_signed ( sh ( son ( t ) ) ), sw, 0 ) ;
+			branch(tst_le, jr, is_signed(sh(son(t))), sw, 0);
-	    make_label ( ptno ( jt ) ) ;
+			make_label(ptno(jt));
+		}
+	}
-    }
-    /* Return what has been subtracted from D1 */
+	/* Return what has been subtracted from D1 */
-    have_cond = 0 ;
+	have_cond = 0;
-    return ( already ) ;
+	return (already);
+}
 /*
     RESET STACK POINTER FROM APPLICATIONS POINTER
     sp = AP - (env_size - (sizeof(params) + sizeof(ret-addr) + sizeof(AP)))
 */
-static void reset_stack_pointer
+static void
-    PROTO_Z ()
+reset_stack_pointer(void)
+{
-    mach_op *op1, *op2, *op3 ;
+	mach_op *op1, *op2, *op3;
-    make_comment("reset stack pointer ...");
+	make_comment("reset stack pointer ...");
-    update_stack () ;
+	update_stack();
-    op1 = make_indirect ( REG_AP, 0 ) ;
+	op1 = make_indirect(REG_AP, 0);
-    op2 = op1->of->plus = new_mach_op() ;
+	op2 = op1->of->plus = new_mach_op();
-    op2->type = MACH_NEG ;
+	op2->type = MACH_NEG;
-    op2->plus = make_ldisp(4);
+	op2->plus = make_ldisp(4);
-    op2 = make_register ( REG_SP ) ;
+	op2 = make_register(REG_SP);
-    make_instr ( m_lea, op1, op2, regmsk ( REG_SP ) ) ;
+	make_instr(m_lea, op1, op2, regmsk(REG_SP));
 #if 0
-    /* gas misinterpret lea a6@( <label> ) if <label> isn't declared ?? */
+	/* gas misinterpret lea a6@( <label> ) if <label> isn't declared ?? */
-    op1 = make_indirect ( REG_AP, 0 ) ;
+	op1 = make_indirect(REG_AP, 0);
-    op2 = new_mach_op() ;
+	op2 = new_mach_op();
-    op1->of->plus = op2 ;
+	op1->of->plus = op2;
-    /* The address of cur_proc_dec is used to form the env_size label */
+	/* The address of cur_proc_dec is used to form the env_size label */
-    op3 = make_lab ((long)cur_proc_dec,8+(cur_proc_callers_size+cur_proc_callees_size)/8);
+	op3 = make_lab((long)cur_proc_dec,8+ (cur_proc_callers_size+cur_proc_callees_size) /8);
-    op2->type = MACH_NEG ;
+	op2->type = MACH_NEG;
-    op2->plus = op3 ;
+	op2->plus = op3;
-    op2 = make_register ( REG_SP ) ;
+	op2 = make_register(REG_SP);
-    make_instr ( m_lea, op1, op2, regmsk ( REG_SP ) ) ;
+	make_instr(m_lea, op1, op2, regmsk(REG_SP));
 #endif
-    make_comment("reset stack pointer done");
+	make_comment("reset stack pointer done");
+}
 /*
     CHECK UP ON JUMPS
     This routine checks for jumps to immediately following labels.
 */
-static bool red_jump
+static bool
-    PROTO_N ( ( e, la ) )
-    PROTO_T ( exp e X exp la )
+red_jump(exp e, exp la)
 {
-    if ( !last ( la ) && pt ( e ) == bro ( la ) ) return ( 1 ) ;
+	if (!last(la) && pt(e) == bro(la)) {
+		return (1);
+	}
-    return ( 0 ) ;
+	return (0);
+}
 /*
     ALLOW SPACE ON STACK
 */
-static ash stack_room
+static ash
-    PROTO_N ( ( stack, dest, off ) )
-    PROTO_T ( ash stack X where dest X long off )
+stack_room(ash stack, where dest, long off)
+{
-    exp e = dest.wh_exp ;
+	exp e = dest.wh_exp;
-    if ( name ( e ) == ident_tag ) {
+	if (name(e) == ident_tag) {
-	if ( ptno ( e ) != var_pl ) return ( stack ) ;
+		if (ptno(e) != var_pl) {
+			return (stack);
+		}
-	if ( no ( e ) + off > stack ) stack = no ( e ) + off ;
+		if (no(e) + off > stack) {
+			stack = no(e) + off;
-    }
+		}
+	}
-    return ( stack ) ;
+	return (stack);
+}
 /*
     MAIN CODING ROUTINE
     evaluation is dealt with by codec.  The expression e is coded and
     the result put into dest.  The stack argument gives the current
     structure of the stack.
 */
-void coder
+void
-    PROTO_N ( ( dest, stack, e ) )
-    PROTO_T ( where dest X ash stack X exp e )
+coder(where dest, ash stack, exp e)
+{
-    bool sw ;
+	bool sw;
 		} else {
-		    /* Encode the definition */
+			exp s_d0 = sim_exp(sh(offset),D0);
-		    if ( ptno ( e ) == reg_pl ) regsindec |= dc.num ;
-		    coder ( zw ( e ), stack, def ) ;
+			where w_d0;
-		}
-		/* Modify regsinuse if a register is being used */
-		if ( ptno ( e ) == reg_pl ) {
+			w_d0 = zw(s_d0);
-		    regsindec &= ~dc.num ;
+			coder(w_d0,stack,offset);
-		    if ( used_once ) {
+			add(sh(offset),mnw(7),D0,D0);
-			regsinuse |= dc.num ;
+			and(sh(offset),D0,mnw(~7),D0);
-			reuseables |= dc.num ;
+			add(sh(offset),A0,D0,SP);
-		    } else {
+		}
-			regsinuse |= dc.num ;
+		if (need_preserve_stack) {
-			reuseables &= ~dc.num ;
+			save_stack();
-		    }
 		}
-		/* Modify max_stack is the stack is being used */
+		make_comment("local_free done");
-		if ( ptno ( e ) == var_pl && sz > max_stack ) max_stack = sz ;
-	    }
-	    /* Encode the body */
-	    coder ( dest, dc.new_stack, body ) ;
-	    extra_weight -= dw ;
+		return;
+	}
-	    /* Look for peephole optimizations */
+	case local_free_all_tag: {
-	    if ( dc.is_new && pt ( e ) == reg_pl ) {
+		mach_op *op1, *op2;
-		regsinuse &= ~dc.num ;
+		must_use_bp = 1;
-		if ( !output_immediately && p && do_peephole ) {
+		make_comment("local_free_all ...");
-		    if ( used_twice && post_inc_check ( p, no ( e ) ) ) {
+		reset_stack_pointer();
-			regsinproc = rg ;
+		if (need_preserve_stack) {
-			return ;
+			save_stack();
-		    }
+		}
-	    }
+		make_comment("local_free_all done");
-	    return ;
+		return;
+	}
-#ifndef tdf3
-#else
-	case clear_tag : {
-	    /* Clear means do nothing */
-	    return ;
-	}
-#endif
-	case seq_tag : {
-	    /* Sequences */
-	    bool no_bottom = 1 ;
-	    exp t = son ( son ( e ) ) ;
-	    /* Code each sub-expression */
-	    while ( coder ( zero, stack, t ),
-		    no_bottom = ( name ( sh ( t ) ) != bothd ),
-		    !last ( t ) ) t = bro ( t ) ;
-	    /* Code the result expression if necessary */
-	    if ( no_bottom ) coder ( dest, stack, bro ( son ( e ) ) ) ;
-	    return ;
-	}
-	case cond_tag : {
-	    /* Conditionals */
-	    long lb, r1 ;
-	    allocation dc ;
-	    exp jr, record ;
-	    bool is_condgoto = 0 ;
-	    /* Find the first and alternative expressions */
-	    exp first = son ( e ) ;
-	    exp alt = bro ( first ) ;
-	    /* Check for "if cond goto ..." */
-	    if ( name ( bro ( son ( alt ) ) ) == goto_tag ) is_condgoto = 1 ;
-	    /* Find or create the label */
-	    if ( is_condgoto ) {
-		record = pt ( son ( pt ( bro ( son ( alt ) ) ) ) ) ;
-	    } else {
-		lb = next_lab () ;
-		record = simple_exp ( 0 ) ;
-		no ( record ) = stack ;
-		sonno ( record ) = stack_dec ;
-		ptno ( record ) = lb ;
-	    }
-	    no(son(alt)) = ptno(record);
-	    pt ( son ( alt ) ) = record ;
-	    /* Allocate space for the alternative expression */
-	    dc = alloc_variable ( alt, son ( alt ), stack ) ;
-	    ptno ( alt ) = dc.place ;
-	    no ( alt ) = dc.num ;
-	    /* If first is just a jump to alt, just encode alt */
-	    if ( name ( first ) == goto_tag && pt ( first ) == alt &&
-		 son ( first ) != nilexp &&
-		 name ( sh ( son ( first ) ) ) == tophd ) {
-		coder ( dest, stack, bro ( son ( alt ) ) ) ;
-		return ;
-	    }
-	    /* Code the first expression */
-	    reuseables = 0 ;
-	    r1 = regsinuse ;
-	    coder ( dest, stack, first ) ;
-	    /* Restore regsinuse */
-	    regsinuse = r1 ;
-	    /* If alt is trivial, no further action is required */
-	    if ( name ( bro ( son ( alt ) ) ) == top_tag ) {
-		bitpattern ch = last_jump_regs ;
-		make_label ( ptno ( record ) ) ;
-		if ( !is_condgoto && !output_immediately && last_jump == lb ) {
-		    current_ins->changed = ch ;
-		}
-		return ;
-	    }
-	    /* No further action is required for conditional gotos */
-	    if ( is_condgoto ) return ;
-	    /* If first doesn't end with a jump, add one */
-	    if ( name ( sh ( first ) ) != bothd ) {
-		long lb2 = next_lab () ;
-		jr = simple_exp ( 0 ) ;
-		ptno ( jr ) = lb2 ;
-		make_jump ( m_bra, lb2 ) ;
-	    }
-	    /* Encode the alternative expression */
-	    reuseables = 0 ;
-	    make_label ( ptno ( record ) ) ;
-	    coder ( dest, stack, alt ) ;
-	    regsinuse = r1 ;
-	    reuseables = 0 ;
-	    /* Output the label for the jump added to first if necessary */
-	    if ( name ( sh ( first ) ) != bothd ) {
-		make_label ( ptno ( jr ) ) ;
-		retcell ( jr ) ;
-	    }
-	    have_cond = 0 ;
-	    retcell ( record ) ;
-	    return ;
+#ifndef tdf3
-	}
-	case labst_tag : {
+	case untidy_return_tag:
-	    /* Labelled statements */
-	    allocation dc ;
-	    have_cond = 0 ;
-            /* Is there long jump access to this label ? */
-            if ( is_loaded_lv(e) ) {
-               if ( need_preserve_stack )
-                  restore_stack ();
-               else if (!has_alloca)
-                  reset_stack_pointer() ;
-            };
-	    /* Allocate space */
-	    dc = alloc_variable ( e, son ( e ), stack ) ;
-	    if ( dc.place == reg_pl ) {
-		regsinuse |= dc.num ;
-		reuseables &= ~dc.num ;
-	    }
-	    /* Encode the body */
-	    coder ( dest, stack, bro ( son ( e ) ) ) ;
-	    /* Update max_stack and regsinuse */
-	    if ( dc.place == var_pl ) {
-		if ( dc.new_stack > max_stack ) max_stack = dc.new_stack ;
-	    }
+#endif
-	    if ( dc.place == reg_pl ) regsinuse &= ( ~dc.num ) ;
-	    return ;
-	}
-	case rep_tag : {
+	case res_tag:
-	    /* Loops */
-	    long lb ;
-	    exp record ;
-	    allocation dc ;
-	    /* Find the starter and the body of the loop */
-	    exp start = son ( e ) ;
-	    exp body = bro ( start ) ;
-	    /* Allocate space */
+		/* Procedure results */
-	    dc = alloc_variable ( body, son ( body ), stack ) ;
-	    ptno ( body ) = dc.place ;
-	    no ( body ) = dc.num ;
-	    /* Code the starter of the loop */
-	    coder ( zw ( body ), stack, start ) ;
-	    /* Create the repeat label */
-	    lb = next_lab () ;
-	    make_label ( lb ) ;
-	    record = simple_exp ( 0 ) ;
-	    setlast ( record ) ;
-	    no ( record ) = stack ;
-	    sonno ( record ) = stack_dec ;
-	    ptno ( record ) = lb ;
-	    pt ( son ( body ) ) = record ;
-	    reuseables = 0 ;
+		have_cond = 0;
-	    /* Encode the body of the loop */
-	    coder ( dest, stack, body ) ;
-	    retcell ( record ) ;
-	    return ;
-	}
-	case goto_tag : {
+		/* Has the procedure been inlined? */
-	  /* Jumps */
-	  exp lab ;
+		if (crt_rscope == 0) {
-	  /* Try to avoid unnecessary jumps */
+			/* Non-inlined procedures */
-	  if ( last ( e ) && name ( bro ( e ) ) == seq_tag &&
-	       name ( bro ( bro ( e ) ) ) == labst_tag &&
-	       red_jump ( e, bro ( e ) ) ) return ;
+			shape rsha = sh(son(e));
+			/* Does the result go into a register? */
+			if (result_in_reg(rsha)) {
+				if (shape_size(rsha) <= 32) {
+					/* Small register results go into D0 */
+					coder(D0, stack, son(e));
+				} else {
+#ifdef SYSV_ABI
+					coder(FP0, stack, son(e));
+#else
+					/*
+					 * Larger register results go into D0
+					 * and D1.
+					 */
+					coder(D0_D1, stack, son(e));
+					regsinproc |= regmsk(REG_D1);
+#endif
+				}
-	  /* Output the jump */
+				/* Jump to the return label */
-	  lab = pt ( e ) ;
+				if (name(rsha) != bothd) {
+#ifndef tdf3
-	  make_jump ( m_bra, ptno ( pt ( son ( lab ) ) ) ) ;
+					if (name(e) == untidy_return_tag) {
-	  reuseables = 0 ;
+						untidy_return();
+					} else
+#endif
+						make_jump(m_bra, crt_ret_lab);
+				}
-	  return ;
+				return;
-	}
+			}
-	case goto_lv_tag : {
+			/* Otherwise the result has to be encoded into the
-	  exp dest_exp = son(e); /* destination label */
+			 * position pointed to by A1 at the start of the
-	  exp cont_exp = getexp(sh(dest_exp),nilexp,1,dest_exp,nilexp,0,0,
+			 * procedure. This value was stored in A6_4. The value
-				cont_tag);
+			 * of this pointer is returned in D0.
-	  where wh;
+			 */
-	  mach_op *op;
-	  wh = zw(cont_exp);
+			if (name(son(e)) == apply_tag ||
-	  wh.wh_is = RegInd;
+			    name(son(e)) == apply_general_tag) {
-	  op = operand(32,wh);
+				coder(A6_4_p, stack, son(e));
-	  /*epilogue(1);*/
+			} else {
-	  make_instr(m_jmp,op,null,~save_msk);
+				codec(A6_4_p, stack, son(e));
+			}
+#ifdef SYSV_ABI
-	  /*ins1(m_jmp,32,D0,0);*/
+			move(slongsh, A6_4, A1);
-	  return ;
+#else
+			move(slongsh, A6_4, D0);
-	}
+#endif
+			regsinproc |= regmsk(REG_A1);
 #ifndef tdf3
-        case return_to_label_tag: {
+			if (name(e) == untidy_return_tag) {
-           exp dest_lab = son(e);
-           make_comment("return_to_label ...");
-           move(slongsh, zw(dest_lab), A0);
-           restore_regs(ALL);
-           make_instr(m_jmp,operand(32,A0_p),null,~save_msk);
-           make_comment("return_to_label done");
-           return;
+				untidy_return();
-        };
+			} else
 #endif
-	case long_jump_tag : {
-	  exp new_env = son(e);
-	  exp dest_lab = bro(new_env);
-          make_comment("long_jump");
-	  move(sh(dest_lab),zw(dest_lab),A0);
+				make_jump(m_bra, crt_ret_lab);
-	  move(sh(new_env),zw(new_env),A1);
-          /* restore all registers but A6 or SP */
-          restore_regs(NOT_A6_OR_SP);
-	  move(sh(new_env),A1,AP);
-	  make_instr(m_jmp,operand(32,A0_p),null,~save_msk);
-	  return ;
+			return;
-	}
-	case test_tag : {
-	    /* Tests */
-	    exp qwe ;
+		} else {
-	    where qw ;
-	    bool sg = 1, sf = 0 ;
-            int shn ;
+			/*
-	    /* Find the test number */
+			 * For inlined procedures, the result goes into
-	    long test_n = ( long ) props ( e ) ;
+			 * rscope_dest and a jump is made to crt_rscope.
+			 */
-	    /* Find the expressions being compared */
-	    exp arg1 = son ( e ) ;
+			coder(rscope_dest, stack, son(e));
-	    exp arg2 = bro ( arg1 ) ;
-	    /* Find the label to be jumped to */
-	    exp lab_exp = pt ( e ) ;
+#ifndef tdf3
-	    exp jr = pt ( son ( lab_exp ) ) ;
-	    /* If arg1 is not an operand, code it into D1 */
-	    if ( !is_o ( name ( arg1 ) ) ) {
+			if (name(e) == untidy_return_tag) {
-		qwe = sim_exp ( sh ( arg1 ), D1 ) ;
+				untidy_return();
-		qw = zw ( qwe ) ;
+			} else
-		regsinproc |= regmsk ( REG_D1 ) ;
+#endif
-		coder ( qw, stack, arg1 ) ;
+				make_jump(m_bra, ptno(crt_rscope));
-		arg1 = qwe ;
+			return;
-	    }
+		}
-	    /* If arg2 is not an operand, code it into D1 */
+#ifdef rscope_tag
-	    if ( !is_o ( name ( arg2 ) ) ) {
+	case rscope_tag: {
-		qwe = sim_exp ( sh ( arg2 ), D1 ) ;
+		/* Procedure scopes */
-		qw = zw ( qwe ) ;
+		exp record;
-		regsinproc |= regmsk ( REG_D1 ) ;
+		where old_rscope_dest;
-		coder ( qw, stack, arg2 ) ;
+		exp old_rscope = crt_rscope;
-		arg2 = qwe ;
+		old_rscope_dest = rscope_dest;
-	    }
-	    /* Look for unsigned or floating tests */
+		/* Check for inlined procedures */
-            shn = name ( sh ( arg1 ) ) ;
-	    switch ( shn ) {
-	        case ucharhd :
-	        case uwordhd :
-	        case ulonghd :
-                case u64hd   :  sg = 0 ; break ;
-		case shrealhd :
-		case realhd :
-		case doublehd : sg = 0 ; sf = 1 ; break ;
-	    }
-	    /* Certain comparisons with 1 or -1 can be changed */
-	    if ( name ( arg1 ) == val_tag ) {
-		long d = no ( arg1 ) ;
-		if ( is_offset ( arg1 ) ) d /= 8 ;
-		if ( d == 1 ) {
+		if (last(e) &&
-		    if ( test_n == tst_le ) {
-			/* 1 <= x becomes 0 < x */
-			test_n = tst_ls ;
-			no ( arg1 ) = 0 ;
-		    } else if ( test_n == tst_gr ) {
-			/* 1 > x becomes 0 >= x */
-			test_n = tst_ge ;
-			no ( arg1 ) = 0 ;
-		    }
-		} else if ( d == -1 && sg ) {
-		    if ( test_n == tst_ls ) {
+		    (name(bro(e)) == proc_tag ||
-			/* -1 < x becomes 0 <= x */
-			test_n = tst_le ;
-			no ( arg1 ) = 0 ;
-		    } else if ( test_n == tst_ge ) {
-			/* -1 >= x becomes 0 > x */
-			test_n = tst_gr ;
-			no ( arg1 ) = 0 ;
-		    }
-		}
-	    }
-	    /* Certain other comparisons with 1 or -1 can be changed */
-	    if ( name ( arg2 ) == val_tag ) {
+		     name(bro(e)) == general_proc_tag)) {
-		long d = no ( arg2 ) ;
-		if ( is_offset ( arg2 ) ) d /= 8 ;
-		if ( d == 1 ) {
-		    if ( test_n == tst_ge ) {
-			/* x >= 1 becomes x > 0 */
-			test_n = tst_gr ;
-			no ( arg2 ) = 0 ;
-		    } else if ( test_n == tst_ls ) {
-			/* x < 1 becomes x <= 0 */
-			test_n = tst_le ;
-			no ( arg2 ) = 0 ;
-		    }
-		} else if ( d == -1 && sg ) {
-		    if ( test_n == tst_gr ) {
-			/* x > -1 becomes x >= 0 */
-			test_n = tst_ge ;
-			no ( arg2 ) = 0 ;
-		    } else if ( test_n == tst_le ) {
-			/* x <= 1 becomes x < 0 */
-			test_n = tst_ls ;
-			no ( arg2 ) = 0 ;
-		    }
-		}
-	    }
-            if ( shn == u64hd || shn == s64hd ) {
-	      where w1, w2 ;
-              w1 = zw ( arg1 ) ;
-	      w2 = zw ( arg2 ) ;
-              /* compare low word (unsigned) */
-              sw = cmp ( ulongsh, w1, w2, test_n ) ;
-              branch ( test_n, jr, sg, sw, sf ) ;
-              /* compare high word */
-              w1.wh_off += 32 ;
-              w2.wh_off += 32 ;
-              if ( sg )
-                sw = cmp ( slongsh, w1, w2, test_n ) ;
-              else
-                sw = cmp ( ulongsh, w1, w2, test_n ) ;
-              branch ( test_n, jr, sg, sw, sf ) ;
-              return ;
-            }
-	    /* Code the comparison */
-	    sw = cmp ( sh ( arg1 ), zw ( arg1 ), zw ( arg2 ), test_n ) ;
-	    /* Output the condition jump */
-	    branch ( test_n, jr, sg, sw, sf ) ;
-	    return ;
-	}
-	case testbit_tag : {
-	    /* Bit tests */
-	    exp qwe ;
-	    where qw ;
-	    /* Find the arguments */
-	    exp arg1 = son ( e ) ;
-	    exp arg2 = bro ( arg1 ) ;
-	    /* Find the label to be jumped to */
-	    exp lab_exp = pt ( e ) ;
-	    exp jr = pt ( son ( lab_exp ) ) ;
-	    /* If arg1 is not an operand, code it into D1 */
-	    if ( !is_o ( name ( arg1 ) ) ) {
-		qwe = sim_exp ( sh ( arg1 ), D1 ) ;
-		qw = zw ( qwe ) ;
-		regsinproc |= regmsk ( REG_D1 ) ;
-		coder ( qw, stack, arg1 ) ;
-		arg1 = qwe ;
-	    }
-	    /* If arg2 is not an operand, code it into D1 */
-	    if ( !is_o ( name( arg2 ) ) ) {
-		qwe = sim_exp ( sh ( arg2 ), D1 ) ;
-		qw = zw ( qwe ) ;
-		regsinproc |= regmsk ( REG_D1 ) ;
-		coder ( qw, stack, arg2 ) ;
-		arg2 = qwe ;
-	    }
-	    /* Code the test */
-	    bit_test ( sh ( arg1 ), zw ( arg1 ), zw ( arg2 ) ) ;
-	    /* Output the conditional jump */
+			/* Non-inlined procedures are simple */
-	    branch ( ( long ) props ( e ), jr, 1, 0, 0 ) ;
-	    return ;
-	}
-	case ass_tag :
-	case assvol_tag : {
-	    /* Variable assignments */
-	    exp assdest = son ( e ) ;
-	    exp assval = bro ( assdest ) ;
-            make_comment("assign ...") ;
-	    if ( name ( sh ( assval ) ) == bitfhd ) {
-		int_to_bitf ( assval, e, stack ) ;
-		return ;
-	    }
-	    codec (zw ( e ), stack, assval ) ;
-            make_comment("assign done") ;
-	    return ;
-	}
-	case nof_tag : {
-	    shape sha ;
-	    long crt, off ;
-	    exp v = son ( e ) ;
-	    if ( v == nilexp ) return ;
-	    if ( name ( dest.wh_exp ) == val_tag ) return ;
-	    sha = sh ( v ) ;
-	    crt = dest.wh_off ;
-	    off = rounder ( shape_size ( sha ), shape_align ( sha ) ) ;
-	    while ( 1 ) {
-		where wh ;
-		ash stack2 ;
-		wh = mw ( dest.wh_exp, crt ) ;
-		stack2 = stack_room ( stack, dest, off + crt ) ;
-		coder ( wh, stack2, v ) ;
-		if ( last ( v ) ) return ;
-		crt += off ;
+			crt_rscope = 0;
-		v = bro ( v ) ;
-	    }
-	    /* Not reached */
-	}
-	case ncopies_tag : {
-	    where wh ;
-	    long n = no ( e ) ;
-	    shape sha = sh ( son ( e ) ) ;
-	    long sz = rounder ( shape_size ( sha ), shape_align ( sha ) ) ;
-	    if ( n == 0 ) return ;
-	    if ( name ( dest.wh_exp ) == val_tag ) return ;
-	    if ( n == 1 ) {
-		coder ( dest, stack, son ( e ) ) ;
+			coder(zero, stack, son(e));
-		return ;
-	    }
-	    if ( sz == 8 || sz == 16 || sz == 32 ) {
-		coder ( D1, stack, son ( e ) ) ;
-		regsinproc |= regmsk ( REG_D1 ) ;
-		if ( n <= 10 ) {
-		    long i ;
-		    for ( i = 0 ; i < n ; i++ ) {
-			wh = mw ( dest.wh_exp, dest.wh_off + i * sz ) ;
-			move ( sha, D1, wh ) ;
-		    }
-		    return ;
-		} else {
-		    mach_op *op1, *op2 ;
-		    long lab = next_lab () ;
-		    int instr = ins ( sz, ml_mov ) ;
-		    mova ( dest, A0 ) ;
-		    regsinproc |= regmsk ( REG_A0 ) ;
-		    move ( slongsh, mnw ( n - 1 ), D0 ) ;
-		    make_label ( lab ) ;
-		    op1 = make_register ( REG_D1 ) ;
-		    op2 = make_postinc ( REG_A0 ) ;
-		    make_instr ( instr, op1, op2, regmsk ( REG_A0 ) ) ;
-		    op1 = make_register ( REG_D0 ) ;
-		    op2 = make_lab_data ( lab, 0 ) ;
-		    make_instr ( m_dbf, op1, op2, regmsk ( REG_D0 ) ) ;
-		    return ;
-		}
-	    }
-	    coder ( dest, stack, son ( e ) ) ;
-	    wh = mw ( dest.wh_exp, dest.wh_off + sz ) ;
-	    move_bytes ( sz * ( n - 1 ), dest, wh, 0 ) ;
-	    return ;
-	}
-	case concatnof_tag : {
-	    ash stack2 ;
-	    exp a1 = son ( e ) ;
-	    exp a2 = bro ( a1 ) ;
-	    long off = dest.wh_off + shape_size ( sh ( a1 ) ) ;
-	    coder ( dest, stack, a1 ) ;
-	    stack2 = stack_room ( stack, dest, off ) ;
-	    coder ( mw ( dest.wh_exp, off ), stack2, a2 ) ;
-	    return ;
-	}
-#ifndef tdf3
-          case apply_tag :
-          case apply_general_tag : {
-             apply_general_proc(e, dest, stack);
-             return;
-          }
-          case tail_call_tag : {
-             int old_stack_dec = stack_dec;
-             tail_call(e, dest, stack);
-             stack_dec = old_stack_dec;
-             return;
-          }
-          case caller_tag : {
-             coder ( dest, stack, son ( e ) ) ;
-             return;
-          }
-          case trap_tag: {
-             trap_ins( no( e ) ) ;
-             return;
-          }
-#endif
-#if 0
-	case apply_tag : {
-	    /* Procedure applications */
-#ifndef tdf3
-#else
-          static int apply_tag_flag = 0 ;
-#endif
-	    exp t ;
-	    ash st ;
-	    long comp_room = 0 ;
-	    long longs = 0, stkdec ;
-	    long start_stack = stack_dec ;
-	    bool use_push = 1, reg_res ;
-	    /* Find the procedure and the arguments */
-	    exp proc = son ( e ) ;
-	    exp arg = ( last ( proc ) ? nilexp : bro ( proc ) ) ;
-#if 0
-            /* not a normal procedure call, but a way to specify a debuger break point */
-          if ((brog(son(proc))->dec_u.dec_val.processed) &&
-              (brog(son(proc))->dec_u.dec_val.extnamed)  &&
-              (!strcmp( brog(son(proc))->dec_u.dec_val.dec_id, "_TESTPOINT"))) {
-               TESTPOINT();
-               return;
-            }
-#endif
-   make_comment("Call Normal Proc");
-	    /* See if we can push all the arguments */
-	    st = 0 ;
-	    if ( arg != nilexp ) {
-		t = arg ;
-		while ( t != nilexp ) {
-		    ast a ;
-                    if ( cpd_param ( sh ( t ) ) ) use_push = 0 ;
-                    if ((name(sh(t)) == s64hd) || (name(sh(t)) == u64hd)){
-                      use_push = 0;
-                    }
-                    if ( !push_arg ( t ) ) use_push = 0 ;
-		    a = add_shape_to_stack ( st, sh ( t ) ) ;
-		    st = a.astash ;
-		    t = ( last ( t ) ? nilexp : bro ( t ) ) ;
-		}
-	    }
-	    longs = st ;
-	    /* Does the result go into a register? */
-	    reg_res = result_in_reg ( sh ( e ) ) ;
-	    if ( !reg_res ) {
-		if ( eq_where ( dest, zero ) ) {
-		    /* Calculate room for ignored compound result */
-/* todo: use symbol instead of 32 */
-		    comp_room = round ( shape_size ( sh ( e ) ), 32 ) ;
-		}
-	    }
-	    /* Find total amount of stack decrease */
-	    stkdec = longs + comp_room ;
-	    /* Put arguments onto stack */
-	    if ( use_push ) {
-              make_comment("Push callers");
-		if ( comp_room ) {
-		    /* Make room for unwanted compound result */
-		    dec_stack ( comp_room ) ;
-		    stack_dec -= comp_room ;
-		}
-		/* Push the arguments */
-		if ( arg != nilexp ) code_pars ( zw ( e ), stack, arg ) ;
-	    } else {
-              make_comment("Place callers");
-		/* Decrease stack */
-		if ( stkdec ) dec_stack ( stkdec ) ;
-		stack_dec -= stkdec ;
-		/* Indicate recursive calls */
-		apply_tag_flag++ ;
-		/* Encode the arguments onto the stack */
-		st = 0 ;
-		t = arg ;
-		while ( t != nilexp ) {
-		    ast a ;
-		    where stp ;
-		    long adj = 0 ;
-		    char nc = name ( sh ( t ) ) ;
-		    if ( nc == scharhd || nc == ucharhd ) adj = 24 ;
-		    if ( nc == swordhd || nc == uwordhd ) adj = 16 ;
-		    stp = mw ( SP_p.wh_exp, st + adj ) ;
-		    coder ( stp, stack, t ) ;
-		    a = add_shape_to_stack ( st, sh ( t ) ) ;
-		    st = a.astash ;
-		    t = ( last ( t ) ? nilexp : bro ( t ) ) ;
-		}
-		apply_tag_flag-- ;
-	    }
-	    start_stack -= stack_dec ;
-	    /* For results which do not fit into registers a pointer to
-	       where the result is to be put is passed in in A1 */
-	    if ( !reg_res ) {
-		if ( comp_room ) {
-		    /* Find the space allocated for unwanted results */
-		    where w ;
-		    w = mnw ( longs / 8 ) ;
-		    add ( slongsh, SP, w, A1 ) ;
-		} else {
-		    /* Find the address of where the result is to be put */
-		    tmp_reg_prefer = REG_A1 ;
-		    if ( apply_tag_flag ) {
-			/* For recursive calls we need to be very careful
-			   if the result is itself to be a procedure argument
-			   to get the right stack offset. */
-			long ex = extra_stack ;
-			long doff = dest.wh_off ;
-			extra_stack += start_stack ;
-			dest.wh_off = 0 ;
-			if ( eq_where ( dest, SP_p ) ) {
-			    /* Careful! */
-			    dest.wh_off = doff + extra_stack ;
-			    mova ( dest, A1 ) ;
-			    dest.wh_off = doff ;
-			} else {
-			    /* Easy */
-			    dest.wh_off = doff ;
-			    mova ( dest, A1 ) ;
-			}
-			extra_stack = ex ;
-		    } else {
-			/* Otherwise (easy) ... */
-			mova ( dest, A1 ) ;
-		    }
-		}
-		/* Make sure we don't reuse A1 accidently */
-		avoid_tmp_reg ( REG_A1 ) ;
-		regsinproc |= regmsk ( REG_A1 ) ;
-	    }
-	    /* Output the call instruction */
-	    callins ( longs, son ( e ) ) ;
-	    stack_dec += stkdec ;
-	    have_cond = 0 ;
-	    /* Throw away unwanted compound result */
-	    if ( comp_room ) {
-		dec_stack ( -comp_room ) ;
-		return ;
-	    }
-	    /* Throw away unwanted simple result */
-	    if ( eq_where ( dest, zero ) ) return ;
-	    /* Now move the result into place */
-	    if ( reg_res ) {
-		if ( shape_size ( sh ( e ) ) <= 32 ) {
-		    /* Small register results are in D0 */
-		    move ( sh ( e ), D0, dest ) ;
-		    return ;
 		} else {
-		    /* Larger register results are in D0 and D1 */
-#ifdef SYSV_ABI
-		    move ( sh ( e ), FP0, dest ) ;
+			/* This is an inlined procedure */
-#else
-		    move ( sh ( e ), D0_D1, dest ) ;
+			long lb = next_lab();
-		    regsinproc |= regmsk ( REG_D1 ) ;
+			record = simple_exp(0);
-#endif
-		    return ;
+			ptno(record) = lb;
-		}
-	    } else {
+			crt_rscope = record;
-		/* Compound results should already have been copied to
-		   the position pointed to by A1 by the called procedure
-		   and returned by it in D0, so no further action should
-		   be required by the calling procedure.  Unfortunately
-		   cc doesn't always get this right for union results. */
-#ifdef OLD_SPEC
+			rscope_dest = dest;
-		if ( cc_conventions && name ( sh ( e ) ) == unhd ) {
-		    regsinproc |= regmsk ( REG_A0 ) ;
+			coder(zero, stack, son(e));
-		    move ( slongsh, D0, A0 ) ;
+			make_label(lb);
-		    move ( sh ( e ), A0_p, dest ) ;
+			retcell(record);
+		}
-#endif
+		/* Restore the previous scopes */
+		rscope_dest = old_rscope_dest;
+		crt_rscope = old_rscope;
-		return ;
+		return;
-	    }
+	}
 #endif
-	case alloca_tag : {
+	case solve_tag: {
-	    /* Local memory allocation */
+		/* Solve statements */
-	    exp s = son ( e ) ;
+		long lb = next_lab();
-            where size_w ;
+		exp jr = simple_exp(0);
+		ptno(jr) = lb;
-            bool allocation_done = 0 ;
+		solve(son(e), son(e), dest, jr, stack);
-	    used_stack = 1 ;
+		make_label(lb);
+		retcell(jr);
+		return;
+	}
+	case case_tag: {
-            make_comment("Allocate ...") ;
+		/* Case statements */
+		exp d1;
+		where w1;
+		bool old_D1_sp = D1_is_special;
+		exp arg1 = son(e);
+		exp t = arg1;
-            /* Create a where representing the value to be allocated */
+		/* Mark the end of the cases */
+		while (!last(t)) {
+			t = bro(t);
+		}
+		bro(t) = nilexp;
-	    if ( name ( s ) == val_tag ) {
+		d1 = sim_exp(sh(arg1), D1);
+		w1 = zw(d1);
-              long off = no ( s ) ;
+		D1_is_special = 1;
-              if ( ! is_offset ( s ) ) off *= 8 ;
+		regsinproc |= regmsk(REG_D1);
-              off = rounder(off, stack_align) ;
+		coder(w1, stack, arg1);
-              if ( checkalloc(e)) {
-                 size_w = mw(zeroe, off / 8);
+		change_var_sh(slongsh, sh(arg1), w1, D1);
-              }
-              else {
-                 /* simple allocation of constant */
-                 dec_stack ( off ) ;
-                 allocation_done = 1 ;
-              }
-	    }
-            else {
-               size_w = zw(s) ;
+		D1_is_special = old_D1_sp;
-            }
-            /* Allocate (checked or not) */
+		/* Output the case statement */
+		(void)caser(arg1, L0);
-            if ( ! allocation_done )
-            if (checkalloc(e)) checkalloc_stack (size_w, 1) ;
-            else sub ( slongsh, size_w, SP, SP ) ;
-	    /* The result of the construct is SP */
-	    if ( !eq_where ( dest, zero ) ) move ( sh ( e ), SP, dest ) ;
-	    have_cond = 0 ;
-            if (need_preserve_stack) save_stack ();
-            make_comment("Allocate done") ;
-	    return ;
-	}
-	case last_local_tag : {
-           make_comment("last_local ...");
-           move ( sh ( e ), SP, dest ) ;
-           make_comment("last_local done");
-           return ;
-	}
-	case local_free_tag : {
-	  exp base = son(e);
-	  exp offset = bro(base);
-	  exp s_a0 = sim_exp(sh(base),A0);
-	  where w_a0;
-	  w_a0 = zw(s_a0);
-          make_comment("local_free ...");
-	  coder(w_a0,stack,base);
-	  if(name(offset) == val_tag) {
-            long off = no ( offset ) ;
-            where size_w ;
-            if ( ! is_offset ( offset ) ) off *= 8 ;
-            off = rounder(off, stack_align) / 8 ;
-            size_w = mw(zeroe, off);
-	    add(sh(offset),A0,zw(offset),SP);
-	  }
-	  else {
-	    exp s_d0 = sim_exp(sh(offset),D0);
-	    where w_d0;
-	    w_d0 = zw(s_d0);
-	    coder(w_d0,stack,offset);
-	    add(sh(offset),mnw(7),D0,D0);
-	    and(sh(offset),D0,mnw(~7),D0);
-	    add(sh(offset),A0,D0,SP);
-	  }
-          if (need_preserve_stack)
-	  save_stack ();
-          make_comment("local_free done");
-	  return ;
-	}
-	case local_free_all_tag : {
-           mach_op *op1, *op2 ;
-           must_use_bp = 1 ;
-           make_comment("local_free_all ...");
-           reset_stack_pointer();
-           if (need_preserve_stack)
-           save_stack ();
-           make_comment("local_free_all done");
-           return ;
-	}
-#ifndef tdf3
-        case untidy_return_tag :
-#endif
-	case res_tag : {
-	    /* Procedure results */
-	    have_cond = 0 ;
-	    /* Has the procedure been inlined? */
-	    if ( crt_rscope == 0 ) {
-		/* Non-inlined procedures */
-		shape rsha = sh ( son ( e ) ) ;
-		/* Does the result go into a register? */
-		if ( result_in_reg ( rsha ) ) {
-		    if ( shape_size ( rsha ) <= 32 ) {
-			/* Small register results go into D0 */
-			coder ( D0, stack, son ( e ) ) ;
-		    } else {
-#ifdef SYSV_ABI
-			coder ( FP0, stack, son ( e ) ) ;
-#else
-			/* Larger register results go into D0 and D1 */
-			coder ( D0_D1, stack, son ( e ) ) ;
-			regsinproc |= regmsk ( REG_D1 ) ;
-#endif
-		    }
-		    /* Jump to the return label */
-		    if ( name ( rsha ) != bothd ) {
-#ifndef tdf3
-                       if ( name ( e ) == untidy_return_tag ) {
-                          untidy_return() ;
-                       }
-                       else
-#endif
-			make_jump ( m_bra, crt_ret_lab ) ;
-		    }
-		    return ;
-		}
-		/* Otherwise the result has to be encoded into the
-		   position pointed to by A1 at the start of the procedure.
-		   This value was stored in A6_4.  The value of this
-		   pointer is returned in D0. */
-		if (   name ( son ( e ) ) == apply_tag
-                    || name ( son ( e ) ) == apply_general_tag ) {
-		    coder ( A6_4_p, stack, son ( e ) ) ;
-		} else {
-		    codec ( A6_4_p, stack, son ( e ) ) ;
-		}
-#ifdef SYSV_ABI
-		move ( slongsh, A6_4, A1 ) ;
-#else
-		move ( slongsh, A6_4, D0 ) ;
-#endif
-		regsinproc |= regmsk ( REG_A1 ) ;
-#ifndef tdf3
-                if ( name ( e ) == untidy_return_tag ) {
-                   untidy_return() ;
-                }
-                else
-#endif
-		make_jump ( m_bra, crt_ret_lab ) ;
-		return ;
+		retcell(d1);
-	    } else {
-		/* For inlined procedures, the result goes into rscope_dest
-		   and a jump is made to crt_rscope */
-		coder ( rscope_dest, stack, son ( e ) ) ;
-#ifndef tdf3
-                if ( name ( e ) == untidy_return_tag ) {
-                   untidy_return() ;
-                }
-                else
-#endif
-		make_jump ( m_bra, ptno ( crt_rscope ) ) ;
-		return ;
+		return;
-	    }
-	}
-#ifdef rscope_tag
-	case rscope_tag : {
-	    /* Procedure scopes */
-	    exp record ;
-	    where old_rscope_dest ;
-	    exp old_rscope = crt_rscope ;
-	    old_rscope_dest = rscope_dest ;
-	    /* Check for inlined procedures */
-	    if ( last ( e ) && ( name ( bro ( e ) ) == proc_tag
-                                || name ( bro ( e ) ) == general_proc_tag ) ) {
-		/* Non-inlined procedures are simple */
-		crt_rscope = 0 ;
-		coder ( zero, stack, son ( e ) ) ;
-	    } else {
-		/* This is an inlined procedure */
-		long lb = next_lab () ;
-		record = simple_exp ( 0 ) ;
-		ptno ( record ) = lb ;
-		crt_rscope = record ;
-		rscope_dest = dest ;
-		coder ( zero, stack, son ( e ) ) ;
-		make_label ( lb ) ;
-		retcell ( record ) ;
-	    }
-	    /* Restore the previous scopes */
-	    rscope_dest = old_rscope_dest ;
-	    crt_rscope = old_rscope ;
-	    return ;
-	}
-#endif
-	case solve_tag : {
-	    /* Solve statements */
-	    long lb = next_lab () ;
-	    exp jr = simple_exp ( 0 ) ;
-	    ptno ( jr ) = lb ;
-	    solve ( son ( e ), son ( e ), dest, jr, stack ) ;
-	    make_label ( lb ) ;
-	    retcell ( jr ) ;
-	    return ;
-	}
-	case case_tag : {
-	    /* Case statements */
-	    exp d1 ;
-	    where w1 ;
-	    bool old_D1_sp = D1_is_special ;
-	    exp arg1 = son ( e ) ;
-	    exp t = arg1 ;
-	    /* Mark the end of the cases */
-	    while ( !last ( t ) ) t = bro ( t ) ;
-	    bro ( t ) = nilexp ;
-	    d1 = sim_exp ( sh ( arg1 ), D1 ) ;
-	    w1 = zw ( d1 ) ;
-	    D1_is_special = 1 ;
-	    regsinproc |= regmsk ( REG_D1 ) ;
-	    coder ( w1, stack, arg1 ) ;
-	    change_var_sh ( slongsh, sh ( arg1 ), w1, D1 ) ;
-	    D1_is_special = old_D1_sp ;
-	    /* Output the case statement */
-	    ( void ) caser ( arg1, L0 ) ;
-	    retcell ( d1 ) ;
-	    return ;
 	}
-	case movecont_tag : {
+	case movecont_tag: {
-	  /* This is done by a library call to memmove */
+		/* This is done by a library call to memmove */
-	  exp from_exp = son(e);
+		exp from_exp = son(e);
-	  exp to_exp = bro(from_exp);
+		exp to_exp = bro(from_exp);
-	  exp num_bytes = bro(to_exp);
+		exp num_bytes = bro(to_exp);
 #if defined(SUN)
-          mach_op *op = make_extern_ind("_bcopy",0);
+		mach_op *op = make_extern_ind("_bcopy",0);
 #else
-          mach_op *op = make_extern_ind("_memmove",0);
+		mach_op *op = make_extern_ind("_memmove",0);
 #endif
-          make_comment("move_some ...");
+		make_comment("move_some ...");
-	  push(slongsh,L32,D0);
+		push(slongsh,L32,D0);
-	  push(slongsh,L32,D1);
+		push(slongsh,L32,D1);
-	  push(slongsh,L32,zw(num_bytes));
+		push(slongsh,L32,zw(num_bytes));
 #if defined(SUN)
-	  push(slongsh,L32,zw(to_exp));
+		push(slongsh,L32,zw(to_exp));
-	  push(slongsh,L32,zw(from_exp));
+		push(slongsh,L32,zw(from_exp));
 #else
-	  push(slongsh,L32,zw(from_exp));
+		push(slongsh,L32,zw(from_exp));
-	  push(slongsh,L32,zw(to_exp));
+		push(slongsh,L32,zw(to_exp));
 #endif
-	  make_instr(m_call,op,null,0);
+		make_instr(m_call,op,null,0);
-	  dec_stack(-96);
+		dec_stack(-96);
-	  pop(slongsh,L32,D1);
+		pop(slongsh,L32,D1);
-	  pop(slongsh,L32,D0);
+		pop(slongsh,L32,D0);
-          make_comment("move_some done");
+		make_comment("move_some done");
-	  return ;
+		return;
+	}
-	case diagnose_tag : {
+	case diagnose_tag:
 #if have_diagnostics
-	    diag_start ( dno ( e ), e ) ;
+		diag_start(dno(e), e);
-	    coder ( dest, stack, son ( e ) ) ;
+		coder(dest, stack, son(e));
-	    diag_end ( dno ( e ), e ) ;
+		diag_end(dno(e), e);
 #else
-	    coder ( dest, stack, son ( e ) ) ;
+		coder(dest, stack, son(e));
 #endif
-	    return ;
+		return;
-	}
-	case prof_tag :{
+	case prof_tag:
-	  return;
+		return;
-	}
-	default :  {
+	default:
-	    if ( !is_a ( name ( e ) ) ) {
+		if (!is_a(name(e))) {
-		error ( "Bad operation" ) ;
+			error("Bad operation");
-		return ;
+			return;
-	    }
+		}
-	    if ( name ( dest.wh_exp ) != val_tag){
+		if (name(dest.wh_exp) != val_tag) {
-               /* All other cases are passed to codec */
+			/* All other cases are passed to codec */
-               codec ( dest, stack, e ) ;
+			codec(dest, stack, e);
-               return ;
+			return;
-	    }
-	    else if (!optop(e)){
+		} else if (!optop(e)) {
+			/*
-               /* An operation with an error jump must always be performed,
+			 * An operation with an error jump must always be
-                  even if the result is discarded.  */
+			 * performed, even if the result is discarded.
+			 */
-               codec (zero,stack,e);
+			codec(zero,stack,e);
-               return ;
+			return;
-	    }
+		}
+	}
-    }
+}

Subversion Repositories tendra.SVN

(root)/branches/tendra5/src/installers/680x0/common/coder.c – Rev 5 → 6