Lout 3.17.

git-svn-id: http://svn.savannah.nongnu.org/svn/lout/trunk@2 9365b830-b601-4143-9ba8-b4a8e2c3339c

1 files changed, 294 insertions, 0 deletions

diff --git a/z09.c b/z09.c
new file mode 100644
index 0000000..6801dd8
--- /dev/null
+++ b/z09.c
@@ -0,0 +1,294 @@
+/*@z09.c:Closure Expansion:SearchEnv()@***************************************/
+/*                                                                           */
+/*  THE LOUT DOCUMENT FORMATTING SYSTEM (VERSION 3.17)                       */
+/*  COPYRIGHT (C) 1991, 1999 Jeffrey H. Kingston                             */
+/*                                                                           */
+/*  Jeffrey H. Kingston (jeff@cs.usyd.edu.au)                                */
+/*  Basser Department of Computer Science                                    */
+/*  The University of Sydney 2006                                            */
+/*  AUSTRALIA                                                                */
+/*                                                                           */
+/*  This program is free software; you can redistribute it and/or modify     */
+/*  it under the terms of the GNU General Public License as published by     */
+/*  the Free Software Foundation; either Version 2, or (at your option)      */
+/*  any later version.                                                       */
+/*                                                                           */
+/*  This program is distributed in the hope that it will be useful,          */
+/*  but WITHOUT ANY WARRANTY; without even the implied warranty of           */
+/*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            */
+/*  GNU General Public License for more details.                             */
+/*                                                                           */
+/*  You should have received a copy of the GNU General Public License        */
+/*  along with this program; if not, write to the Free Software              */
+/*  Foundation, Inc., 59 Temple Place, Suite 330, Boston MA 02111-1307 USA   */
+/*                                                                           */
+/*  FILE:         z09.c                                                      */
+/*  MODULE:       Closure Expansion                                          */
+/*  EXTERNS:      SearchEnv(), SetEnv(), AttachEnv(), GetEnv(),              */
+/*                DetachEnv(), ClosureExpand()                               */
+/*                                                                           */
+/*****************************************************************************/
+#include "externs.h"
+
+
+/*****************************************************************************/
+/*                                                                           */
+/*  OBJECT SearchEnv(env, sym)                                               */
+/*                                                                           */
+/*  Search environment env for a symbol such that actual() == sym.           */
+/*                                                                           */
+/*****************************************************************************/
+
+OBJECT SearchEnv(OBJECT env, OBJECT sym)
+{ OBJECT link, y;
+  debug2(DCE, DD, "[ SearchEnv(%s, %s)", EchoObject(env), SymName(sym));
+  for(;;)
+  {
+    debug1(DCE, DDD, "  searching env %s", EchoObject(env));
+    assert( env != nilobj && type(env) == ENV, "SearchEnv: env!" );
+    if( Down(env) == env )
+    { debug0(DCE, DD, "] SearchEnv returning <nilobj>");
+      return nilobj;
+    }
+    Child(y, Down(env));
+    assert( type(y) == CLOSURE, "SearchEnv: type(y) != CLOSURE!" );
+    if( actual(y) == sym )
+    { debug1(DCE, DD, "] SearchEnv returning %s", EchoObject(y));
+      return y;
+    }
+    assert( LastDown(y) != y, "SearchEnv: LastDown(y) == y!" );
+    link = LastDown(env) != Down(env) ? LastDown(env) : LastDown(y);
+    Child(env, link);
+  }
+} /* end SearchEnv */
+
+
+/*@::SetEnv(), AttachEnv(), GetEnv(), DetachEnv()@****************************/
+/*                                                                           */
+/*  OBJECT SetEnv(x, y)                                                      */
+/*                                                                           */
+/*  Create a new environment containing x and possibly y.                    */
+/*                                                                           */
+/*****************************************************************************/
+
+OBJECT SetEnv(OBJECT x, OBJECT y)
+{ OBJECT res;
+  debug1(DCE, DD, "SetEnv( x, %s ), x =", EchoObject(y));
+  ifdebug(DCE, DD, DebugObject(x));
+  assert( x!=nilobj && type(x)==CLOSURE, "SetEnv: x==nilobj or not CLOSURE!" );
+  assert( y==nilobj || type(y)==ENV, "SetEnv: y!=nilobj && type(y) != ENV!" );
+  New(res, ENV);  Link(res, x);
+  if( y != nilobj )  Link(res, y);
+  debug1(DCE, DD, "SetEnv returning %s", EchoObject(res));
+  return res;
+} /* end SetEnv */
+
+
+/*****************************************************************************/
+/*                                                                           */
+/*  AttachEnv(env, x)                                                        */
+/*                                                                           */
+/*  Attach environment env to CLOSURE x.                                     */
+/*                                                                           */
+/*****************************************************************************/
+
+void AttachEnv(OBJECT env, OBJECT x)
+{ debug2(DCE, DD, "AttachEnv( %s, %s )", EchoObject(env), EchoObject(x));
+  assert( env != nilobj && type(env) == ENV, "AttachEnv: type(env) != ENV!" );
+  assert( type(x) == CLOSURE || type(x) == ENV_OBJ, "AttachEnv: type(x)!" );
+  Link(x, env);
+  debug0(DCE, DD, "AttachEnv returning.");
+} /* end AttachEnv */
+
+
+/*****************************************************************************/
+/*                                                                           */
+/*  OBJECT GetEnv(x)                                                         */
+/*                                                                           */
+/*  Get from CLOSURE x the environment previously attached.                  */
+/*                                                                           */
+/*****************************************************************************/
+
+OBJECT GetEnv(OBJECT x)
+{ OBJECT env;
+  assert( type(x) == CLOSURE, "GetEnv: type(x) != CLOSURE!" );
+  assert( LastDown(x) != x, "GetEnv: LastDown(x) == x!" );
+  Child(env, LastDown(x));
+  assert( type(env) == ENV, "GetEnv: type(env) != ENV!" );
+  return env;
+} /* end GetEnv */
+
+
+/*****************************************************************************/
+/*                                                                           */
+/*  OBJECT DetachEnv(x)                                                      */
+/*                                                                           */
+/*  Detach from CLOSURE x the environment previously attached.               */
+/*                                                                           */
+/*****************************************************************************/
+
+OBJECT DetachEnv(OBJECT x)
+{ OBJECT env;
+  debug1(DCE, DD, "DetachEnv( %s )", EchoObject(x));
+  assert( type(x) == CLOSURE, "DetachEnv: type(x) != CLOSURE!" );
+  assert( LastDown(x) != x, "DetachEnv: LastDown(x) == x!" );
+  Child(env, LastDown(x));
+  DeleteLink(LastDown(x));
+  assert( type(env) == ENV, "DetachEnv: type(env) != ENV!" );
+  debug1(DCE, DD, "DetachEnv resturning %s", EchoObject(env));
+  return env;
+} /* end DetachEnv */
+
+
+/*@::ClosureExpand()@*********************************************************/
+/*                                                                           */
+/*  OBJECT ClosureExpand(x, env, crs_wanted, crs, res_env)                   */
+/*                                                                           */
+/*  Return expansion of closure x in environment env.                        */
+/*  The body comes from the environment of x if x is a parameter, else from  */
+/*  the symbol table.  The original x is pushed into the environments.       */
+/*  If crs_wanted and x has a tag, a cross-reference is added to crs.        */
+/*                                                                           */
+/*****************************************************************************/
+
+OBJECT ClosureExpand(OBJECT x, OBJECT env, BOOLEAN crs_wanted,
+OBJECT *crs, OBJECT *res_env)
+{ OBJECT link, y, res, prnt_env, par, prnt;
+  debug3(DCE, D, "[ ClosureExpand( %s, %s, %s, crs, res_env )",
+    EchoObject(x), EchoObject(env), bool(crs_wanted));
+  assert( type(x) == CLOSURE, "ClosureExpand given non-CLOSURE!");
+  assert( predefined(actual(x)) == FALSE, "ClosureExpand given predefined!" );
+
+  /* add tag to x if needed but not provided;  add cross-reference to crs  */
+  if( has_tag(actual(x)) )  CrossAddTag(x);
+  if( crs_wanted && has_tag(actual(x)) )
+  { OBJECT tmp = CopyObject(x, no_fpos);  AttachEnv(env, tmp);
+    y = CrossMake(actual(x), tmp, CROSS_TARG);
+    New(tmp, CROSS_TARG);  actual(tmp) = y;  Link(tmp, y);
+    if( *crs == nilobj )  New(*crs, CR_LIST);   Link(*crs, tmp);
+  }
+
+  /* case x is a parameter */
+  res = *res_env = nilobj;
+  if( is_par(type(actual(x))) )
+  { prnt = SearchEnv(env, enclosing(actual(x)));
+    if( prnt != nilobj )
+    {
+      prnt_env = GetEnv(prnt);
+      for( link = Down(prnt);  link != prnt;  link = NextDown(link) )
+      { Child(par, link);
+        if( type(par) == PAR && actual(par) == actual(x) )
+        { assert( Down(par) != par, "ExpandCLosure: Down(par)!");
+	  Child(res, Down(par));
+	  if( dirty(enclosing(actual(par))) )
+	  { debug2(DSU, DD, "c %s %s", SymName(actual(par)), EchoObject(res));
+	    res = CopyObject(res, no_fpos);
+	  }
+	  else
+	  { debug2(DCE, DDD, "l %s %s",
+	      FullSymName(actual(par), AsciiToFull(".")), EchoObject(res));
+	    DeleteLink(Down(par));
+	    y = MakeWord(WORD, STR_NOCROSS, &fpos(res));
+	    Link(par, y);
+	  }
+	  ReplaceNode(res, x);
+	  if( type(actual(x)) == RPAR && has_body(enclosing(actual(x))) )
+	  { debug0(DCR, DDD, "  calling SetEnv from ClosureExpand (a)");
+	    *res_env = SetEnv(prnt, nilobj);  DisposeObject(x);
+	  }
+	  else if( type(actual(x)) == NPAR && imports_encl(actual(x)) )
+	  { debug0(DCR, DDD, "  calling SetEnv from ClosureExpand (x)");
+	    AttachEnv(env, x);
+	    *res_env = SetEnv(x, nilobj);
+	  }
+	  else
+	  { AttachEnv(env, x);
+	    debug0(DCR, DDD, "  calling SetEnv from ClosureExpand (b)");
+	    *res_env = SetEnv(x, prnt_env);
+	  }
+	  break;
+        }
+      }
+    }
+    else
+    {
+      /* fail only if there is no default value available */
+      if( sym_body(actual(x)) == nilobj )
+      {
+        debug3(DCE, D, "failing ClosureExpand( %s, crs, %s, %s, res_env )\n",
+	  EchoObject(x), bool(crs_wanted), EchoObject(env));
+        Error(9, 2, "no value for parameter %s of symbol %s:", WARN, &fpos(x),
+	  SymName(actual(x)), SymName(enclosing(actual(x))));
+        Error(9, 1, "symbol with import list misused", FATAL, &fpos(x));
+      }
+    }
+  }
+
+  /* case x is a user-defined symbol or default parameter */
+  if( res == nilobj )
+  { if( sym_body(actual(x)) == nilobj )
+      res = MakeWord(WORD,STR_NOCROSS,&fpos(x));
+    else res = CopyObject(sym_body(actual(x)), &fpos(x));
+    ReplaceNode(res, x);  AttachEnv(env, x);
+    debug0(DCR, DDD, "  calling SetEnv from ClosureExpand (c)");
+    *res_env = SetEnv(x, nilobj);
+  }
+
+  assert( *res_env!=nilobj && type(*res_env)==ENV, "ClosureExpand: *res_env!");
+  debug0(DCE, D, "] ClosureExpand returning, res =");
+  ifdebug(DCE, D, DebugObject(res));
+  debug1(DCE, D, "  environment = %s", EchoObject(*res_env));
+  return res;
+} /* end ClosureExpand */
+
+
+/*@::ParameterCheck()@********************************************************/
+/*                                                                           */
+/*  OBJECT ParameterCheck(x, env)                                            */
+/*                                                                           */
+/*  Check whether object x (which is an actual parameter that happens to be  */
+/*  a CLOSURE) has a value which is a simple word, and if so return a copy   */
+/*  of that word, else nilobj.                                               */
+/*                                                                           */
+/*****************************************************************************/
+
+OBJECT ParameterCheck(OBJECT x, OBJECT env)
+{ OBJECT link, y, res, prnt_env, par, prnt;
+  debug2(DCE, DD, "ParameterCheck(%s, %s)", EchoObject(x), EchoObject(env));
+  assert( type(x) == CLOSURE, "ParameterCheck given non-CLOSURE!");
+
+  /* case x is a parameter */
+  prnt = SearchEnv(env, enclosing(actual(x)));
+  if( prnt == nilobj )
+  { debug0(DCE, DD, "ParameterCheck returning nilobj (prnt fail)");
+    return nilobj;
+  }
+  prnt_env = GetEnv(prnt);
+  for( link = Down(prnt);  link != prnt;  link = NextDown(link) )
+  { Child(par, link);
+    if( type(par) == PAR && actual(par) == actual(x) )
+    {	assert( Down(par) != par, "ParameterCheck: Down(par)!");
+	Child(y, Down(par));
+	res = is_word(type(y)) ? CopyObject(y, no_fpos) : nilobj;
+	debug1(DCE, DD, "  ParameterCheck returning %s", EchoObject(res));
+	return res;
+    }
+  }
+
+  /* case x is a default parameter */
+  y = sym_body(actual(x));
+  if( y == nilobj )
+  { res = nilobj;
+  }
+  else if( is_word(type(y)) )
+  { res = CopyObject(y, &fpos(y));
+  }
+  else if( type(y) == CLOSURE && is_par(type(actual(y))) )
+  { res = ParameterCheck(y, prnt_env);
+  }
+  else
+  { res = nilobj;
+  }
+  debug1(DCE, DD, "ParameterCheck returning %s", EchoObject(res));
+  return res;
+} /* end ParameterCheck */