home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / APPS / lout2.lzh / LOUT2 / z09.c < prev    next >
Text File  |  1994-01-23  |  11KB  |  228 lines
  1. /*@z09.c:Closure Expansion:SearchEnv()@***************************************/
  2. /*                                                                           */
  3. /*  LOUT: A HIGH-LEVEL LANGUAGE FOR DOCUMENT FORMATTING (VERSION 2.05)       */
  4. /*  COPYRIGHT (C) 1993 Jeffrey H. Kingston                                   */
  5. /*                                                                           */
  6. /*  Jeffrey H. Kingston (jeff@cs.su.oz.au)                                   */
  7. /*  Basser Department of Computer Science                                    */
  8. /*  The University of Sydney 2006                                            */
  9. /*  AUSTRALIA                                                                */
  10. /*                                                                           */
  11. /*  This program is free software; you can redistribute it and/or modify     */
  12. /*  it under the terms of the GNU General Public License as published by     */
  13. /*  the Free Software Foundation; either version 1, or (at your option)      */
  14. /*  any later version.                                                       */
  15. /*                                                                           */
  16. /*  This program is distributed in the hope that it will be useful,          */
  17. /*  but WITHOUT ANY WARRANTY; without even the implied warranty of           */
  18. /*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the            */
  19. /*  GNU General Public License for more details.                             */
  20. /*                                                                           */
  21. /*  You should have received a copy of the GNU General Public License        */
  22. /*  along with this program; if not, write to the Free Software              */
  23. /*  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.                */
  24. /*                                                                           */
  25. /*  FILE:         z09.c                                                      */
  26. /*  MODULE:       Closure Expansion                                          */
  27. /*  EXTERNS:      SearchEnv(), SetEnv(), AttachEnv(), GetEnv(),              */
  28. /*                DetachEnv(), ClosureExpand()                               */
  29. /*                                                                           */
  30. /*****************************************************************************/
  31. #include "externs"
  32.  
  33.  
  34. /*****************************************************************************/
  35. /*                                                                           */
  36. /*  OBJECT SearchEnv(env, sym)                                               */
  37. /*                                                                           */
  38. /*  Search environment env for a symbol such that actual() == sym.           */
  39. /*                                                                           */
  40. /*****************************************************************************/
  41.  
  42. OBJECT SearchEnv(env, sym)
  43. OBJECT env, sym;
  44. { OBJECT link, y;
  45.   debug2(DCE, DD, "SearchEnv(%s, %s)", EchoObject(env), SymName(sym));
  46.   for(;;)
  47.   {
  48.     debug1(DCE, DDD, "  searching env %s", EchoObject(env));
  49.     assert( env != nil && type(env) == ENV, "SearchEnv: env!" );
  50.     if( Down(env) == env )
  51.     { debug0(DCE, DD, "SearchEnv returning <nil>");
  52.       return nil;
  53.     }
  54.     Child(y, Down(env));
  55.     assert( type(y) == CLOSURE, "SearchEnv: type(y) != CLOSURE!" );
  56.     if( actual(y) == sym )
  57.     { debug1(DCE, DD, "SearchEnv returning %s", EchoObject(y));
  58.       return y;
  59.     }
  60.     assert( LastDown(y) != y, "SearchEnv: LastDown(y) == y!" );
  61.     link = LastDown(env) != Down(env) ? LastDown(env) : LastDown(y);
  62.     Child(env, link);
  63.   }
  64. } /* end SearchEnv */
  65.  
  66.  
  67. /*@::SetEnv(), AttachEnv(), GetEnv(), DetachEnv()@****************************/
  68. /*                                                                           */
  69. /*  OBJECT SetEnv(x, y)                                                      */
  70. /*                                                                           */
  71. /*  Create a new environment containing x and possibly y.                    */
  72. /*                                                                           */
  73. /*****************************************************************************/
  74.  
  75. OBJECT SetEnv(x, y)
  76. OBJECT x, y;
  77. { OBJECT res;
  78.   debug2(DCR, DD, "SetEnv( %s, %s )", EchoObject(x), EchoObject(y));
  79.   debug2(DCE, D, "SetEnv( %s, %s )", EchoObject(x), EchoObject(y));
  80.   assert( x != nil && type(x) == CLOSURE, "SetEnv: x == nil or not CLOSURE!" );
  81.   assert( y == nil || type(y) == ENV, "SetEnv: y != nil && type(y) != ENV!" );
  82.   res = New(ENV);  Link(res, x);
  83.   if( y != nil )  Link(res, y);
  84.   debug1(DCE, D, "SetEnv returning %s", EchoObject(res));
  85.   return res;
  86. } /* end SetEnv */
  87.  
  88.  
  89. /*****************************************************************************/
  90. /*                                                                           */
  91. /*  AttachEnv(env, x)                                                        */
  92. /*                                                                           */
  93. /*  Attach environment env to CLOSURE x.                                     */
  94. /*                                                                           */
  95. /*****************************************************************************/
  96.  
  97. AttachEnv(env, x)
  98. OBJECT env, x;
  99. { debug2(DCE, D, "AttachEnv( %s, %s )", EchoObject(env), EchoObject(x));
  100.   assert( env != nil && type(env) == ENV, "AttachEnv: type(env) != ENV!" );
  101.   assert( type(x) == CLOSURE, "AttachEnv: type(x) != CLOSURE!" );
  102.   Link(x, env);
  103.   debug0(DCE, D, "AttachEnv returning.");
  104. } /* end AttachEnv */
  105.  
  106.  
  107. /*****************************************************************************/
  108. /*                                                                           */
  109. /*  OBJECT GetEnv(x)                                                         */
  110. /*                                                                           */
  111. /*  Get from CLOSURE x the environment previously attached.                  */
  112. /*                                                                           */
  113. /*****************************************************************************/
  114.  
  115. OBJECT GetEnv(x)
  116. OBJECT x;
  117. { OBJECT env;
  118.   assert( type(x) == CLOSURE, "GetEnv: type(x) != CLOSURE!" );
  119.   assert( LastDown(x) != x, "GetEnv: LastDown(x) == x!" );
  120.   Child(env, LastDown(x));
  121.   assert( type(env) == ENV, "GetEnv: type(env) != ENV!" );
  122.   return env;
  123. } /* end GetEnv */
  124.  
  125.  
  126. /*****************************************************************************/
  127. /*                                                                           */
  128. /*  OBJECT DetachEnv(x)                                                      */
  129. /*                                                                           */
  130. /*  Detach from CLOSURE x the environment previously attached.               */
  131. /*                                                                           */
  132. /*****************************************************************************/
  133.  
  134. OBJECT DetachEnv(x)
  135. OBJECT x;
  136. { OBJECT env;
  137.   debug1(DCE, DD, "DetachEnv( %s )", EchoObject(x));
  138.   assert( type(x) == CLOSURE, "DetachEnv: type(x) != CLOSURE!" );
  139.   assert( LastDown(x) != x, "DetachEnv: LastDown(x) == x!" );
  140.   Child(env, LastDown(x));
  141.   DeleteLink(LastDown(x));
  142.   assert( type(env) == ENV, "DetachEnv: type(env) != ENV!" );
  143.   debug1(DCE, DD, "DetachEnv resturning %s", EchoObject(env));
  144.   return env;
  145. } /* end DetachEnv */
  146.  
  147.  
  148. /*@::ClosureExpand()@*********************************************************/
  149. /*                                                                           */
  150. /*  OBJECT ClosureExpand(x, env, crs_wanted, crs, res_env)                   */
  151. /*                                                                           */
  152. /*  Return expansion of closure x in environment env.                        */
  153. /*  The body comes from the environment of x if x is a parameter, else from  */
  154. /*  the symbol table.  The original x is pushed into the environments.       */
  155. /*  If crs_wanted and x has a tag, a cross-reference is added to crs.        */
  156. /*                                                                           */
  157. /*****************************************************************************/
  158.  
  159. OBJECT ClosureExpand(x, env, crs_wanted, crs, res_env)
  160. OBJECT x, env;  BOOLEAN crs_wanted;  OBJECT *crs, *res_env;
  161. { OBJECT link, y, res, prnt_env, par, prnt;
  162.   debug3(DCE, D, "ClosureExpand( %s, crs, %s, %s, res_env )",
  163.     EchoObject(x), bool(crs_wanted), EchoObject(env));
  164.   assert( type(x) == CLOSURE, "ClosureExpand given non-CLOSURE!");
  165.   assert( predefined(actual(x)) == FALSE, "ClosureExpand given predefined!" );
  166.  
  167.   /* add tag to x if needed but not provided;  add cross-reference to crs  */
  168.   CrossAddTag(x);
  169.   if( crs_wanted && has_tag(actual(x)) )
  170.   { OBJECT tmp = CopyObject(x, no_fpos);  AttachEnv(env, tmp);
  171.     y = CrossMake(actual(x), tmp, CROSS_TARG);
  172.     tmp = New(CROSS_TARG);  actual(tmp) = y;  Link(tmp, y);
  173.     if( *crs == nil )  *crs = New(CR_LIST);   Link(*crs, tmp);
  174.   }
  175.  
  176.   /* case x is a parameter */
  177.   res = *res_env = nil;
  178.   if( is_par(type(actual(x))) )
  179.   { prnt = SearchEnv(env, enclosing(actual(x)));
  180.     if( prnt==nil ) Error(FATAL, &fpos(x), "symbol with import list misused");
  181.     assert( prnt != nil, "ClosureExpand: is_par but prnt == nil!" );
  182.     prnt_env = GetEnv(prnt);
  183.     for( link = Down(prnt);  link != prnt;  link = NextDown(link) )
  184.     { Child(par, link);
  185.       if( type(par) == PAR && actual(par) == actual(x) )
  186.       {    assert( Down(par) != par, "ExpandCLosure: Down(par)!");
  187.     Child(res, Down(par));
  188.     if( dirty(enclosing(actual(par))) )
  189.     { debug2(DSU, DD, "c %s %s", SymName(actual(par)), EchoObject(res));
  190.       res = CopyObject(res, no_fpos);
  191.     }
  192.     else
  193.     { debug2(DSU, DD, "l %s %s", SymName(actual(par)), EchoObject(res));
  194.       DeleteLink(Down(par));
  195.       y = MakeWord(WORD, STR_NOCROSS, &fpos(res));
  196.       Link(par, y);
  197.     }
  198.     ReplaceNode(res, x);
  199.     if( type(actual(x)) == RPAR && has_body(enclosing(actual(x))) )
  200.     { debug0(DCR, DD, "  calling SetEnv from ClosureExpand (a)");
  201.       *res_env = SetEnv(prnt, nil);  DisposeObject(x);
  202.     }
  203.     else
  204.     { AttachEnv(env, x);
  205.       debug0(DCR, DD, "  calling SetEnv from ClosureExpand (b)");
  206.       *res_env = SetEnv(x, prnt_env);
  207.     }
  208.     break;
  209.       }
  210.     }
  211.   }
  212.  
  213.   /* case x is a user-defined symbol or default parameter */
  214.   if( res == nil )
  215.   { if( sym_body(actual(x)) == nil )  res = MakeWord(WORD,STR_NOCROSS,&fpos(x));
  216.     else res = CopyObject(sym_body(actual(x)), &fpos(x));
  217.     ReplaceNode(res, x);  AttachEnv(env, x);
  218.     debug0(DCR, DD, "  calling SetEnv from ClosureExpand (c)");
  219.     *res_env = SetEnv(x, nil);
  220.   }
  221.  
  222.   assert( *res_env != nil && type(*res_env) == ENV, "ClosureExpand: *res_env!");
  223.   debug0(DCE, D, "ClosureExpand returning, res =");
  224.   ifdebug(DCE, D, DebugObject(res));
  225.   debug1(DCE, DD, "  environment = %s", EchoObject(*res_env));
  226.   return res;
  227. } /* end ClosureExpand */
  228.