WebSVN – tendra.SVN – Diff – /trunk/src/installers/common/construct/inline.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
 Revision 1.1  1995/04/06 10:44:05  currie
 Initial revision
 ***********************************************************************/
 #include "config.h"
 #include "common_types.h"
 #include "exp.h"
 #include "expmacs.h"
 #include "inline.h"
 /* PROCEDURES */
-static exp last_action
+static exp
-    PROTO_N ( (e) )
-    PROTO_T ( exp e )
+last_action(exp e)
+{
-  if (e == nilexp)
+	if (e == nilexp) {
-    return e;
+		return e;
+	}
-  if (name(e) == ident_tag || name(e) == seq_tag) {
+	if (name(e) == ident_tag || name(e) == seq_tag) {
-    return last_action(bro(son(e)));
+		return last_action(bro(son(e)));
+	}
+	return e;
+}
+static void
+change_last_shapes(exp e, shape sha)
+{
+	if (e == nilexp) {
+		return;
+	}
+	if (name(e) == ident_tag || name(e) == seq_tag) {
+		sh(e) = sha;
+		change_last_shapes(bro(son(e)), sha);
+	}
+	return;
+}
+/* replaces a formal paramter by an actual parameter */
+static void
+replace_pars(exp actual, exp formal_par)
+{
+	exp def;
+	if (!last(actual)) {
+		replace_pars(bro(actual), bro(son(formal_par)));
-  }
+	}
-  return e;
-}
-static void change_last_shapes
-    PROTO_N ( (e, sha) )
-    PROTO_T ( exp e X shape sha )
-{
-  if (e == nilexp)
-    return;
-  if (name(e) == ident_tag || name(e) == seq_tag) {
-    sh(e) = sha;
-    change_last_shapes(bro(son(e)), sha);
-  }
-  return;
-}
-  /* replaces a formal paramter by an actual parameter */
-static void replace_pars
-    PROTO_N ( (actual, formal_par) )
-    PROTO_T ( exp actual X exp formal_par )
-{
-  exp def;
-  if (!last(actual))
-     replace_pars(bro(actual), bro(son(formal_par)));
-  clearparam(formal_par);
+	clearparam(formal_par);
-  def = son(formal_par);
+	def = son(formal_par);
-  if (no(formal_par) == 1 &&
-	shape_size(sh(pt(formal_par))) == 8)
+	if (no(formal_par) == 1 && shape_size(sh(pt(formal_par))) == 8) {
-    setvis(formal_par);
+		setvis(formal_par);
+	}
-  replace(def, actual, formal_par);
+	replace(def, actual, formal_par);
-  retcell(def);
+	retcell(def);
-  return;
+	return;
+}
-  /* inlines the procedure application e */
+/* inlines the procedure application e */
-void inline_exp
+void
-    PROTO_N ( (e) )
-    PROTO_T ( exp e )
+inline_exp(exp e)
+{
-  exp fn = son(e);	/* the name_tag for the function */
+	exp fn = son(e);	/* the name_tag for the function */
-  exp pars = bro(fn);	/* the first actual parameter */
+	exp pars = bro(fn);	/* the first actual parameter */
-  exp body = son(son(son(fn)));	/* the proc_tag exp */
+	exp body = son(son(son(fn)));	/* the proc_tag exp */
-  exp bc, t, q;
+	exp bc, t, q;
-  exp lab;
+	exp lab;
-  exp var;		/* the destination to which the result is to
+	exp var;		/* the destination to which the result is to be
-  			   be assigned */
+				   assigned */
-  exp new_var = nilexp;
+	exp new_var = nilexp;
-  exp new_dec;	/* a new variable declaration if we make one */
+	exp new_dec;		/* a new variable declaration if we make one */
-  shape sha = sh(e);	/* the shape delivered by the application */
+	shape sha = sh(e);	/* the shape delivered by the application */
-  exp cond_alt;
+	exp cond_alt;
-  exp res;
+	exp res;
-  exp last_act;
+	exp last_act;
+	if (name(sha) == tophd) {
-  if (name(sha) == tophd) {	/* not returning a result, no ass needed */
+		/* not returning a result, no ass needed */
-    var = nilexp;
+		var = nilexp;
-    cond_alt = f_make_top();
+		cond_alt = f_make_top();
-  }
-  else {
+	} else {
-    if (last(e) && name(bro(e)) == ass_tag &&
+		if (last(e) && name(bro(e)) == ass_tag &&
-	  name(son(bro(e))) == name_tag) {
+		    name(son(bro(e))) == name_tag) {
-	  	/* the result of the application is being assigned to
+			/* the result of the application is being assigned to
-		   a name_tag */
+			   a name_tag */
-      var = son(bro(e));/* the destination of the ass */
+			var = son(bro(e));	/* the destination of the ass */
-      cond_alt = f_make_top();	/* the result is being assigned in the
+			cond_alt = f_make_top();	/* the result is being
+							   assigned in the body
+							   - no need for a
-      				   body - no need for a delivered result */
+							   delivered result */
-      e = bro(e); /* NOTE e CHANGED to ass_tag */
+			e = bro(e); /* NOTE e CHANGED to ass_tag */
 #ifdef NEWDIAGS
+			if (diagnose) {
-      if (diagnose) {	/* bro(son(e)) is now the call */
+				/* bro(son(e)) is now the call */
-	dg_whole_comp (e, bro(son(e)));
+				dg_whole_comp(e, bro(son(e)));
-	dgf(e) = dgf(bro(son(e)));
+				dgf(e) = dgf(bro(son(e)));
-      }
+			}
 #endif
-    }
-    else {
+		} else {
-      new_dec = me_start_clearvar(sha, sha);
+			new_dec = me_start_clearvar(sha, sha);
-      	/* make a new variable to assign to at each res_tag */
+			/* make a new variable to assign to at each res_tag */
-      setinlined(new_dec);	/* mark the declaration */
+			setinlined(new_dec);	/* mark the declaration */
-      new_var = me_obtain(new_dec);
+			new_var = me_obtain(new_dec);
-      var = new_var;	/* the destination of assignments
+			var = new_var;	/* the destination of assignments
-      			   new_var is killed at end */
+					   new_var is killed at end */
-      cond_alt = f_contents(sha, copy(new_var));
+			cond_alt = f_contents(sha, copy(new_var));
-      	/* delivers the contents of the variable - hence the value */
+			/* delivers the contents of the variable - hence the
+			 * value */
-    };
+		}
-  };
+	}
-  lab = me_b3(sh(cond_alt), me_shint(sha, 0), cond_alt, labst_tag);
+	lab = me_b3(sh(cond_alt), me_shint(sha, 0), cond_alt, labst_tag);
-  	/* the labst for the new cond_tag we are making up */
+	/* the labst for the new cond_tag we are making up */
-  name(son(lab)) = clear_tag;
+	name(son(lab)) = clear_tag;
-  t = fn; /* start t so that its bro is the first actual parameter */
+	t = fn;	  /* start t so that its bro is the first actual parameter */
-  q = body;	/* start q so that its son is the first formal parameter */
+	q = body; /* start q so that its son is the first formal parameter */
+	while (!last(t)) {
-  while (!last(t))	/* check actual and formal shapes */
+		/* check actual and formal shapes */
-    {
-      if (name(q) != ident_tag || !isparam(q))
+		if (name(q) != ident_tag || !isparam(q)) {
-	return;  /* no inline if more actuals than formals */
+			return;  /* no inline if more actuals than formals */
+		}
-      if (shape_size(sh(bro(t))) != shape_size(sh(son(q))))
+		if (shape_size(sh(bro(t))) != shape_size(sh(son(q)))) {
-        return;	/* no inlining if shapes do not match. */
+			return;	/* no inlining if shapes do not match. */
+		}
-      t = bro(t);	/* next actual */
+		t = bro(t);		/* next actual */
-      q = bro(son(q));	/* next formal */
+		q = bro(son(q));	/* next formal */
-    };
+	}
-  if (name(q) == ident_tag && isparam(q))
+	if (name(q) == ident_tag && isparam(q)) {
-    return;  /* no inline if more formals than actuals */
+		return;  /* no inline if more formals than actuals */
+	}
 #ifdef NEWDIAGS
-  doing_inlining = 1;
+	doing_inlining = 1;
 #endif
-  bc = copy_res(body, var, lab);
+	bc = copy_res(body, var, lab);
-  	/* copy the body, making res_tag into assignment to var and
+	/* copy the body, making res_tag into assignment to var and
 	   jump to lab */
 #ifdef NEWDIAGS
-  doing_inlining = 0;
+	doing_inlining = 0;
 #endif
-  bc = hold(bc);
+	bc = hold(bc);
-  if (!last(fn)) {	/* if there are any parameters */
+	/* if there are any parameters */
+	if (!last(fn)) {
-    replace_pars(pars, son(bc)); /* replace formals by actuals */
+		/* replace formals by actuals */
+		replace_pars(pars, son(bc));
-  }
+	}
-  IGNORE check(son(bc), son(bc));	/* check the result (proc_tag ?)*/
+	IGNORE check(son(bc), son(bc));	/* check the result (proc_tag ?)*/
-  res = son(bc); /* remove the proc_tag */
+	res = son(bc); /* remove the proc_tag */
-  retcell(bc);	/* and retcell it */
+	retcell(bc);	/* and retcell it */
-  last_act = last_action(res);
+	last_act = last_action(res);
-  if (no(son(lab)) == 1 && name(last_act) == goto_tag &&
+	if (no(son(lab)) == 1 && name(last_act) == goto_tag &&
-        pt(last_act) == lab) {
+	    pt(last_act) == lab) {
-     /* there is only one (final) goto replacement for return */
+		/* there is only one (final) goto replacement for return */
-    if (name(res) == goto_tag) {
+		if (name(res) == goto_tag) {
-      res = (name(sha)==tophd)?f_make_top():f_make_value(sha);
+			res = (name(sha) == tophd) ? f_make_top() :
-    }
+				f_make_value(sha);
-    else {
+		} else {
-      change_last_shapes(res, sh(bro(son(lab))));
+			change_last_shapes(res, sh(bro(son(lab))));
 #ifdef NEWDIAGS
-      if (diagnose)
+			if (diagnose) {
-	dg_whole_comp (last_act, bro(son(lab)));
+				dg_whole_comp(last_act, bro(son(lab)));
+			}
 #endif
-      replace(last_act, bro(son(lab)), res);
+			replace(last_act, bro(son(lab)), res);
-    }
-  }
+		}
-  else
+	} else {
-    res = me_b3(sh(lab), res, lab, cond_tag);
+		res = me_b3(sh(lab), res, lab, cond_tag);
+	}
-  	/* make up the cond out of the substituted exp and lab */
+	/* make up the cond out of the substituted exp and lab */
-  if (var != nilexp)
+	if (var != nilexp) {
-    kill_exp(var, var);
+		kill_exp(var, var);
+	}
-  if (new_var != nilexp) { /* we made up a new variable */
+	if (new_var != nilexp) { /* we made up a new variable */
-    SET(new_dec);
+		SET(new_dec);
-    if (no(new_dec) != 1) {
+		if (no(new_dec) != 1) {
-      res = me_complete_id(new_dec, res);	/* complete the variable def */
+			/* complete the variable def */
-    }
+			res = me_complete_id(new_dec, res);
-    else {
+		} else {
-      exp r = f_make_top();
+			exp r = f_make_top();
 #ifdef NEWDIAGS
-      if (diagnose)
+			if (diagnose) {
-	dgf(r) = dgf(bro(son(lab)));
+				dgf(r) = dgf(bro(son(lab)));
+			}
 #endif
-      replace(bro(son(lab)), r, r);
+			replace(bro(son(lab)), r, r);
-    }
+		}
-  };
+	}
 #ifdef NEWDIAGS
-  if (diagnose)
+	if (diagnose) {
-    dg_complete_inline (e, res);
+		dg_complete_inline(e, res);
+	}
 #endif
-  replace(e, res, nilexp);	/* replace the call by the inlined stuff */
+	replace(e, res, nilexp); /* replace the call by the inlined stuff */
-  kill_exp(fn, fn);	/* kill off the function name_tag */
+	kill_exp(fn, fn);	 /* kill off the function name_tag */
-  return;
+	return;
+}

Subversion Repositories tendra.SVN

(root)/trunk/src/installers/common/construct/inline.c – Rev 2 → 7