/*@z06.c:Parser:PushObj(), PushToken(), etc.@*********************************/
/*                                                                           */
/*  THE LOUT DOCUMENT FORMATTING SYSTEM (VERSION 3.41)                       */
/*  COPYRIGHT (C) 1991, 2023 Jeffrey H. Kingston                             */
/*                                                                           */
/*  Jeffrey H. Kingston (jeff@it.usyd.edu.au)                                */
/*  School of Information Technologies                                       */
/*  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 3, 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:         z06.c                                                      */
/*  MODULE:       Parser                                                     */
/*  EXTERNS:      InitParser(), Parse()                                      */
/*                                                                           */
/*****************************************************************************/
#include "externs.h"
#include "child.h"
#define	LEFT_ASSOC	0
#define	RIGHT_ASSOC	1

#define	PREV_OP		0		/* means an operator was previous    */
#define	PREV_OBJ	1		/* prev was object not ending in RBR */
#define	PREV_RBR	2		/* prev was object ending in RBR     */

static	OBJECT		cross_name;	/* name of the cr database   */


#define	MAX_STACK	250			/* size of parser stacks     */
static	OBJECT		obj_stack[MAX_STACK];	/* stack of objects          */
static	int		otop;			/* top of obj_stack          */
static	OBJECT		tok_stack[MAX_STACK];	/* stack of tokens           */
static	int		ttop;			/* top of tok_stack          */
static	int		unknown_count;		/* no. of unknown symbols    */
	BOOLEAN		InDefinitions;		/* TRUE when in definitions  */
#if DEBUG_ON
static	BOOLEAN		debug_now = FALSE;	/* TRUE when want to debug   */
#endif


/*****************************************************************************/
/*                                                                           */
/*  OBJECT OptimizeCase(x)                                                   */
/*                                                                           */
/*  Optimize the @Case expression x, which is known to be of the form        */
/*  "@BackEnd @Case ...", by evaluating it immediately if its choices        */
/*  are all literal words or "else".                                         */
/*                                                                           */
/*****************************************************************************/

static void check_yield(OBJECT y, OBJECT *res_yield, BOOLEAN *all_literals)
{ OBJECT s1, link, z;
  Child(s1, Down(y));
  debug1(DOP, DD, "  checkyield(%s)", EchoObject(y));
  if( is_word(type(s1)) )
  { if( StringEqual(string(s1), BackEnd->name) ||
	StringEqual(string(s1),STR_ELSE) )
      if( *res_yield == nilobj )  *res_yield = y;
  }
  else if( type(s1) == ACAT )
  { for( link = Down(s1);  link != s1;  link = NextDown(link) )
    { Child(z, link);
      if( type(z) == GAP_OBJ )  continue;
      if( is_word(type(z)) )
      { if( StringEqual(string(z), BackEnd->name) ||
	    StringEqual(string(s1), STR_ELSE))
	  if( *res_yield == nilobj )  *res_yield = y;
      }
      else
      { *all_literals = FALSE;
	*res_yield = nilobj;
	break;
      }
    }
  }
  else
  { *all_literals = FALSE;
    *res_yield = nilobj;
  }
  debug2(DOP, DD, "  checkyield returning (%s, %s)", EchoObject(*res_yield),
    bool(*all_literals));
}

OBJECT OptimizeCase(OBJECT x)
{ OBJECT link, s2, y, res_yield, res;  BOOLEAN all_literals;  
  debug1(DOP, DD, "OptimizeCase(%s)", EchoObject(x));
  assert( type(x) == CASE, "OptimizeCase:  type(x) != CASE!" );

  Child(s2, LastDown(x));
  all_literals = TRUE;  res_yield = nilobj;
  if( type(s2) == YIELD )
  { check_yield(s2, &res_yield, &all_literals);
  }
  else if( type(s2) == ACAT )
  { for( link = Down(s2);  link != s2 && all_literals;  link = NextDown(link) )
    {
      Child(y, link);
      debug2(DOP, DD, "  OptimizeCase examining %s %s", Image(type(y)),
	EchoObject(y));
      if( type(y) == GAP_OBJ )  continue;
      if( type(y) == YIELD )
      { check_yield(y, &res_yield, &all_literals);
      }
      else
      { all_literals = FALSE;
	res_yield = nilobj;
      }
    }
  }
  else
  { all_literals = FALSE;
    res_yield = nilobj;
  }

  if( all_literals && res_yield != nilobj )
  { Child(res, LastDown(res_yield));
    DeleteLink(Up(res));
    DisposeObject(x);
  }
  else
  { res = x;
  }

  debug1(DOP, DD, "OptimizeCase returning %s", EchoObject(res));
  return res;
} /* end OptimizeCase */


/*****************************************************************************/
/*                                                                           */
/*  HuntCommandOptions(x)                                                    */
/*                                                                           */
/*  See if any of the command-line options apply to closure x.  If so,       */
/*  change x to reflect the overriding command line option.                  */
/*                                                                           */
/*****************************************************************************/

static void HuntCommandOptions(OBJECT x)
{ OBJECT colink, coname, coval, opt = nilobj, y = nilobj, link, sym;  BOOLEAN found;
  debug1(DOP, DD, "HuntCommandOptions(%s)", SymName(actual(x)));
  sym = actual(x);
  for( colink = Down(CommandOptions);  colink != CommandOptions;
    colink = NextDown(NextDown(colink)) )
  {
    Child(coname, colink);
    Child(coval, NextDown(colink));
    debug2(DOP, DD, "  hunting \"%s\" with value \"%s\"", string(coname),
      EchoObject(coval));

    /* set found to TRUE iff coname is the name of an option of x */
    found = FALSE;
    for( link = Down(sym);  link != sym;  link = NextDown(link) )
    { Child(opt, link);
      if( type(opt) == NPAR && StringEqual(SymName(opt), string(coname)) )
      { found = TRUE;
	debug2(DOP, DD, "  %s is an option of %s", string(coname),SymName(sym));
	break;
      }
    }

    if( found )
    {
      /* see whether this option is already set within x */
      found = FALSE;
      for( link = Down(x);  link != x;  link = NextDown(link) )
      { Child(y, link);
	if( type(y) == PAR && actual(y) == opt )
	{ found = TRUE;
	  debug2(DOP, DD, "  %s is set in %s", string(coname), SymName(sym));
	  break;
	}
      }

      if( found )
      {
	/* option exists already in x: replace it with oval */
	DisposeChild(Down(y));
	Link(y, coval);
	debug2(DOP, DD, "  replacing %s value with %s; x =", string(coname),
	  EchoObject(coval));
	ifdebug(DOP, DD, DebugObject(x));
      }
      else
      {
	/* option applies to x but has not yet been set in x */
	New(y, PAR);
	Link(x, y);
	actual(y) = opt;
	Link(y, coval);
	debug2(DOP, DD, "  inserting %s with value %s; x =", string(coname),
	  EchoObject(coval));
	ifdebug(DOP, DD, DebugObject(x));
      }
    }
  }
  debug1(DOP, DD, "HuntCommandOptions(%s) returning", SymName(sym));
} /* end HuntCommandOptions */


/*****************************************************************************/
/*                                                                           */
/*  PushObj(x)                                                               */
/*  PushToken(t)                                                             */
/*  OBJECT PopObj()                                                          */
/*  OBJECT PopToken()                                                        */
/*  OBJECT TokenTop                                                          */
/*  OBJECT ObjTop                                                            */
/*                                                                           */
/*  Push and pop from the object and token stacks; examine top item.         */
/*                                                                           */
/*****************************************************************************/

#define PushObj(x)							\
{ zz_hold = x;								\
  if( ++otop < MAX_STACK ) obj_stack[otop] = zz_hold;			\
  else Error(6, 1, "expression is too deeply nested",			\
    FATAL, &fpos(obj_stack[otop-1]));					\
}

#define PushToken(t)							\
{ if( ++ttop < MAX_STACK ) tok_stack[ttop] = t;				\
  else Error(6, 2, "expression is too deeply nested",			\
	 FATAL, &fpos(tok_stack[ttop-1]));				\
}

#define PopObj()	obj_stack[otop--]
#define PopToken()	tok_stack[ttop--]
#define	TokenTop	tok_stack[ttop]
#define	ObjTop		obj_stack[otop]


/*@::DebugStacks(), InsertSpace()@********************************************/
/*                                                                           */
/*  DebugStacks()                                                            */
/*                                                                           */
/*  Print debug output of the stacks state                                   */
/*                                                                           */
/*****************************************************************************/

#if DEBUG_ON
static void DebugStacks(int initial_ttop, int obj_prev)
{ int i;
  debug3(ANY, D, "  obj_prev: %s; otop: %d; ttop: %d",
    obj_prev == PREV_OP ? "PREV_OP" : obj_prev == PREV_OBJ ? "PREV_OBJ" :
    obj_prev == PREV_RBR ? "PREV_RBR" : "???", otop, ttop);
  for( i = 0;  i <= otop; i++ )
    debug3(ANY, D, "  obj[%d] = (%s) %s", i,
       Image(type(obj_stack[i])), EchoObject(obj_stack[i]));
  for( i = 0;  i <= ttop;  i++ )
  { if( i == initial_ttop+1 ) debug0(DOP, DD, "  $");
    debug3(ANY, D, "  tok[%d] = %s (precedence %d)", i,
      type(tok_stack[i]) == CLOSURE ?
	SymName(actual(tok_stack[i])) : Image(type(tok_stack[i])),
      precedence(tok_stack[i]));
  }
} /* end DebugStacks */
#endif


/*****************************************************************************/
/*                                                                           */
/*  InsertSpace(t)                                                           */
/*                                                                           */
/*  Add any missing catenation operator in front of token t.                 */
/*                                                                           */
/*****************************************************************************/

#define InsertSpace(t)							\
if( obj_prev )								\
{ int typ, prec;							\
  if( hspace(t) + vspace(t) > 0 )					\
    typ = TSPACE, prec = ACAT_PREC;					\
  else if( type(t) == LBR || obj_prev == PREV_RBR )			\
    typ = TJUXTA, prec = ACAT_PREC;					\
  else									\
    typ = TJUXTA, prec = JUXTA_PREC;					\
  debugcond1(DOP, DD, debug_now, "[ InsertSpace(%s)", Image(typ));	\
  while( obj_prev && precedence(TokenTop) >= prec )			\
    obj_prev = Reduce();						\
  if( obj_prev )							\
  { New(tmp, typ);  precedence(tmp) = prec;				\
    vspace(tmp) = vspace(t);  hspace(tmp) = hspace(t);			\
    width(gap(tmp)) = 0;  nobreak(gap(tmp)) = TRUE;			\
    mark(gap(tmp)) = FALSE;  join(gap(tmp)) = TRUE;			\
    units(gap(tmp)) = FIXED_UNIT;  mode(gap(tmp)) = EDGE_MODE;		\
    FposCopy(fpos(tmp), fpos(t));					\
    PushToken(tmp);							\
  }									\
  debugcond0(DOP, DD, debug_now, "] end InsertSpace()");		\
} /* end InsertSpace */


/*@::Shift(), ShiftObj()@*****************************************************/
/*                                                                           */
/*  static Shift(t, prec, rassoc, leftpar, rightpar)                         */
/*  static ShiftObj(t)                                                       */
/*                                                                           */
/*  Shift token or object t onto the stacks; it has the attributes shown.    */
/*                                                                           */
/*****************************************************************************/

#define Shift(t, prec, rassoc, leftpar, rightpar)			\
{ debugcond5(DOP, DD, debug_now, "[ Shift(%s, %d, %s, %s, %s)",		\
    Image(type(t)), prec, rassoc ? "rightassoc" : "leftassoc",		\
      leftpar ? "lpar" : "nolpar", rightpar ? "rpar" : "norpar");	\
  if( leftpar )								\
  { for(;;)								\
    { if( !obj_prev )							\
      {	PushObj( MakeWord(WORD, STR_EMPTY, &fpos(t)) );			\
	obj_prev = PREV_OBJ;						\
      }									\
      else if( precedence(TokenTop) >= prec + rassoc )			\
      { obj_prev = Reduce();						\
	if( ttop == initial_ttop )					\
	{ *token = t;							\
	  debugcond0(DOP, DD, debug_now,				\
	    "] ] end Shift() and Parse(); stacks are:");		\
	  ifdebugcond(DOP, DD, debug_now,				\
	    DebugStacks(initial_ttop, obj_prev));			\
	  return PopObj();						\
	}								\
      }									\
      else break;							\
    }									\
  }									\
  else InsertSpace(t);							\
  PushToken(t);								\
  if( rightpar )  obj_prev = FALSE;					\
  else									\
  { obj_prev = Reduce(); 						\
    if( ttop == initial_ttop )						\
    { *token = nilobj;							\
      debugcond0(DOP, DD, debug_now,					\
	"] ] end Shift and Parse; stacks are:");			\
      ifdebugcond(DOP, DD, debug_now,					\
	DebugStacks(initial_ttop, obj_prev));				\
      return PopObj();							\
    }									\
  }									\
  debugcond0(DOP, DD, debug_now, "] end Shift()");			\
} /* end Shift */


#define ShiftObj(t, new_obj_prev)					\
{ debugcond1(DOP, DD, debug_now, "[ ShiftObj(%s)", Image(type(t)));	\
  InsertSpace(t);							\
  PushObj(t);								\
  obj_prev = new_obj_prev;						\
  debugcond0(DOP, DD, debug_now, "] end ShiftObj()");			\
}

/*@::Reduce()@****************************************************************/
/*                                                                           */
/*  static Reduce()                                                          */
/*                                                                           */
/*  Perform a single reduction of the stacks.                                */
/*                                                                           */
/*****************************************************************************/

static BOOLEAN Reduce(void)
{ OBJECT p1, p2, p3, s1, s2, tmp;
  OBJECT op;  int obj_prev;
  debugcond0(DOP, DD, debug_now, "[ Reduce()");
  /* ifdebugcond(DOP, DD, debug_now, DebugStacks(0, TRUE)); */

  op = PopToken();
  obj_prev = PREV_OBJ;
  switch( type(op) )
  {

    case GSTUB_INT:
    case GSTUB_EXT:
    
	debug0(DGT, D, "calling TransferEnd( PopObj() ) from Reduce()");
	TransferEnd( PopObj() );
	New(p1, NULL_CLOS);
	PushObj(p1);
	Dispose(op);
	break;


    case GSTUB_NONE:

	New(p1, NULL_CLOS);
	PushObj(p1);
	Dispose(op);
	break;


    case NULL_CLOS:
    case PAGE_LABEL:
    case BEGIN_HEADER:
    case END_HEADER:
    case SET_HEADER:
    case CLEAR_HEADER:
    case ONE_COL:
    case ONE_ROW:
    case WIDE:
    case HIGH:
    case HSHIFT:
    case VSHIFT:
    case HMIRROR:
    case VMIRROR:
    case HSCALE:
    case VSCALE:
    case HCOVER:
    case VCOVER:
    case SCALE:
    case KERN_SHRINK:
    case HCONTRACT:
    case VCONTRACT:
    case HLIMITED:
    case VLIMITED:
    case HEXPAND:
    case VEXPAND:
    case START_HVSPAN:
    case START_HSPAN:
    case START_VSPAN:
    case HSPAN:
    case VSPAN:
    case PADJUST:
    case HADJUST:
    case VADJUST:
    case ROTATE:
    case BACKGROUND:
    case YIELD:
    case BACKEND:
    case XCHAR:
    case FONT:
    case SPACE:
    case YUNIT:
    case ZUNIT:
    case SET_CONTEXT:
    case GET_CONTEXT:
    case BREAK:
    case UNDERLINE:
    case UNDERLINE_COLOUR:
    case COLOUR:
    case TEXTURE:
    case OUTLINE:
    case LANGUAGE:
    case CURR_LANG:
    case CURR_FAMILY:
    case CURR_FACE:
    case CURR_YUNIT:
    case CURR_ZUNIT:
    case COMMON:
    case RUMP:
    case MELD:
    case INSERT:
    case ONE_OF:
    case NEXT:
    case PLUS:
    case MINUS:
    case TAGGED:
    case INCGRAPHIC:
    case SINCGRAPHIC:
    case PLAIN_GRAPHIC:
    case GRAPHIC:
    case LINK_SOURCE:
    case LINK_DEST:
    case LINK_URL:
    case OPEN:
    case RAW_VERBATIM:
    case VERBATIM:

	if( has_rpar(actual(op)) )
	{ s2 = PopObj();
	  Link(op, s2);
	}
	if( has_lpar(actual(op)) )
	{ s1 = PopObj();
	  Link(Down(op), s1);
	}
	PushObj(op);
	break;


    case CASE:

	if( has_rpar(actual(op)) )
	{ s2 = PopObj();
	  Link(op, s2);
	}
	if( has_lpar(actual(op)) )
	{ s1 = PopObj();
	  Link(Down(op), s1);
	  if( type(s1) == BACKEND )
	  { op = OptimizeCase(op);
	  }
	}
	PushObj(op);
	break;


    case CROSS:
    case FORCE_CROSS:

	s2 = PopObj();
	Link(op, s2);
	s1 = PopObj();
	Link(Down(op), s1);
	if( type(s1) != CLOSURE )
	  Error(6, 3, "left parameter of %s is not a symbol (or not visible)",
	    WARN, &fpos(s1), Image(type(op)));
	PushObj(op);
	break;


    case CLOSURE:
    
	if( has_rpar(actual(op)) )
	{ New(s2, PAR);
	  tmp = PopObj();
	  Link(s2, tmp);
	  FposCopy(fpos(s2), fpos(tmp));
	  actual(s2) = ChildSym(actual(op), RPAR);
	  Link(op, s2);
	}
	if( has_lpar(actual(op)) )
	{ New(s1, PAR);
	  tmp = PopObj();
	  Link(s1, tmp);
	  FposCopy(fpos(s1), fpos(tmp));
	  actual(s1) = ChildSym(actual(op), LPAR);
	  Link(Down(op), s1);
	}
	PushObj(op);
	break;


    case LBR:
    
	Error(6, 4, "unmatched %s (inserted %s)", WARN, &fpos(op),
	  KW_LBR, KW_RBR);
	Dispose(op);
	obj_prev = PREV_RBR;
	break;


    case BEGIN:
    
	assert1(FALSE, "Reduce: unmatched", KW_BEGIN);
	break;


    case RBR:
    
	if( type(TokenTop) == LBR )
	{ /* *** FposCopy(fpos(ObjTop), fpos(TokenTop)); *** */
	  Dispose( PopToken() );
	}
	else if( type(TokenTop) == BEGIN )
	{ if( file_num(fpos(TokenTop)) > 0 )
	    Error(6, 5, "unmatched %s; inserted %s at%s (after %s)",
	      WARN, &fpos(op), KW_RBR, KW_LBR,
	      EchoFilePos(&fpos(TokenTop)), KW_BEGIN);
	  else
	    Error(6, 6, "unmatched %s not enclosed in anything",
	      FATAL, &fpos(op), KW_RBR);
	}
	else 
	{ assert1(FALSE, "Reduce: unmatched", KW_RBR);
	}
	Dispose(op);
	obj_prev = PREV_RBR;
	break;


    case END:
    
	if( type(TokenTop) != BEGIN )
	{ assert1(FALSE, "Reduce: unmatched", KW_END);
	}
	else
	{ if( actual(op) != actual(TokenTop) )
	  {
	    if( actual(op) == StartSym )
	      Error(6, 7, "%s %s appended at end of file to match %s at%s",
		WARN, &fpos(op), KW_END, SymName(actual(TokenTop)),
		KW_BEGIN, EchoFilePos(&fpos(TokenTop)) );
	    else if( actual(op) == nilobj )
	      Error(6, 8, "%s replaced by %s %s to match %s at%s",
	        WARN, &fpos(op), KW_END, KW_END,
		actual(TokenTop) == nilobj ? AsciiToFull("??") :
		  SymName(actual(TokenTop)),
		KW_BEGIN, EchoFilePos(&fpos(TokenTop)) );
	    else
	      Error(6, 9, "%s %s replaced by %s %s to match %s at%s",
	        WARN, &fpos(op), KW_END, SymName(actual(op)),
		KW_END, SymName(actual(TokenTop)),
		KW_BEGIN, EchoFilePos(&fpos(TokenTop)) );
	  }
	  Dispose( PopToken() );
	}
	Dispose(op);
	obj_prev = PREV_RBR;
	break;


    case GAP_OBJ:

	p1 = PopObj();
	Link(op, p1);
	PushObj(op);
	obj_prev = PREV_OP;
	break;


    case VCAT:
    case HCAT:
    case ACAT:
    
	p3 = PopObj();  p2 = PopObj();  p1 = PopObj();
	if( type(p1) == type(op) )
	{ Dispose(op);
	}
	else
	{ Link(op, p1);
	  p1 = op;
	}
	Link(p1, p2);
	Link(p1, p3);
	PushObj(p1);
	break;


    case TSPACE:
    case TJUXTA:

	p2 = PopObj();  p1 = PopObj();
	if( type(p1) != ACAT )
	{ New(tmp, ACAT);
	  Link(tmp, p1);
	  FposCopy(fpos(tmp), fpos(p1));
	  p1 = tmp;
	}
	type(op) = GAP_OBJ;
	Link(p1, op);
	Link(p1, p2);
	PushObj(p1);
	break;


    default:
    
	assert1(FALSE, "Reduce:", Image(type(op)));
	break;

  } /* end switch */
  debugcond1(DOP, DD, debug_now, "] end Reduce(), returning %s",
    obj_prev == PREV_OP ? "PREV_OP" : obj_prev == PREV_OBJ ? "PREV_OBJ" :
    obj_prev == PREV_RBR ? "PREV_RBR" : "???");
  return obj_prev;
} /* end Reduce */


/*@::SetScope(), InitParser()@************************************************/
/*                                                                           */
/*  SetScope(env, count, vis_only)                                           */
/*                                                                           */
/*  Push scopes required to parse object whose environment is env.           */
/*  Add to *count the number of scope pushes made.                           */
/*                                                                           */
/*  If vis_only is true, we only want visible things of the top-level        */
/*  element of env to be visible in this scope.                              */
/*                                                                           */
/*****************************************************************************/

void SetScope(OBJECT env, int *count, BOOLEAN vis_only)
{ OBJECT link, y, yenv;  BOOLEAN visible_only;
  debugcond2(DOP,DD, debug_now, "[ SetScope(%s, %d)", EchoObject(env), *count);
  assert( env != nilobj && type(env) == ENV, "SetScope: type(env) != ENV!" );
  if( Down(env) != env )
  { Child(y, Down(env));
    assert( LastDown(y) != y, "SetScope: LastDown(y)!" );
    link = LastDown(env) != Down(env) ? LastDown(env) : LastDown(y);
    Child(yenv, link);
    assert( type(yenv) == ENV, "SetScope: type(yenv) != ENV!" );
    SetScope(yenv, count, FALSE);
    visible_only = vis_only || (use_invocation(actual(y)) != nilobj);
    /* i.e. from @Use clause */
    PushScope(actual(y), FALSE, visible_only);  (*count)++;
    /*** this following was a bright idea that did not work owing to
	 allowing body parameters at times they definitely shouldn't be
    BodyParAllowed();
    ***/
  }
  debugcond1(DOP, DD, debug_now, "] SetScope returning, count = %d", *count);
} /* end SetScope */


/*****************************************************************************/
/*                                                                           */
/*  InitParser()                                                             */
/*                                                                           */
/*  Initialise the parser to contain just GstubExt.                          */
/*  Remember cross_db, the name of the cross reference database, for Parse.  */
/*                                                                           */
/*****************************************************************************/

void InitParser(FULL_CHAR *cross_db)
{
  otop = -1;
  ttop = -1;
  unknown_count = 0;
  InDefinitions = TRUE;
  debug0(DOP, D, "InitParser setting InDefinitions to TRUE");
#if DEBUG_ON
  debug_now = FALSE;
#endif
  if( StringLength(cross_db) >= MAX_WORD )
    Error(6, 10, "cross reference database file name %s is too long",
      FATAL, no_fpos, cross_db);
  cross_name = MakeWord(WORD, cross_db, no_fpos);
  PushToken( NewToken(GSTUB_EXT, no_fpos, 0, 0, DEFAULT_PREC, StartSym) );
} /* end InitParser */


/*@::ParseEnvClosure()@*******************************************************/
/*                                                                           */
/*  static OBJECT ParseEnvClosure(t, encl)                                   */
/*                                                                           */
/*  Parse an object which is a closure with environment.  Consume the        */
/*  concluding @LClos.                                                       */
/*                                                                           */
/*****************************************************************************/

static OBJECT ParseEnvClosure(OBJECT t, OBJECT encl)
{ OBJECT env, res, y;  int count, i;
  debugcond0(DOP, DDD, debug_now, "ParseEnvClosure(t, encl)");
  assert( type(t) == ENV, "ParseEnvClosure: type(t) != ENV!" );
  env = t;  t = LexGetToken();
  while( type(t) != CLOS )  switch( type(t) )
  {
    case LBR:	count = 0;
		SetScope(env, &count, FALSE);
		y = Parse(&t, encl, FALSE, FALSE);
		if( type(y) != CLOSURE )
		{
		  debug1(DIO, D, "  Parse() returning %s:", Image(type(y)));
		  ifdebug(DIO, D, DebugObject(y));
		  Error(6, 11, "syntax error in cross reference database",
		    FATAL, &fpos(y));
		}
		for( i = 1;  i <= count;  i++ )  PopScope();
		AttachEnv(env, y);
		debug0(DCR, DDD, "  calling SetEnv from ParseEnvClosure (a)");
		env = SetEnv(y, nilobj);
		t = LexGetToken();
		break;

    case ENV:	y = ParseEnvClosure(t, encl);
		debug0(DCR, DDD, "  calling SetEnv from ParseEnvClosure (b)");
		env = SetEnv(y, env);
		t = LexGetToken();
		break;

    default:	Error(6, 12, "error in cross reference database",
		  FATAL, &fpos(t));
		break;
  }
  Dispose(t);
  if( Down(env) == env || Down(env) != LastDown(env) )
    Error(6, 13, "error in cross reference database", FATAL, &fpos(env));
  Child(res, Down(env));
  DeleteNode(env);
  debugcond1(DOP, DDD, debug_now, "ParseEnvClosure ret. %s", EchoObject(res));
  assert( type(res) == CLOSURE, "ParseEnvClosure: type(res) != CLOSURE!" );
  return res;
} /* end ParseEnvClosure */


/*@::Parse()@*****************************************************************/
/*                                                                           */
/*  OBJECT Parse(token, encl, defs_allowed, transfer_allowed)                */
/*                                                                           */
/*  Parse input tokens, beginning with *token, looking for an object of the  */
/*  form { ... } or @Begin ... @End <sym>, and return the object.            */
/*  The parent definition is encl, and scope has been set appropriately.     */
/*  Parse reads up to and including the last token of the object             */
/*  (the right brace or <sym>), and returns nilobj in *token.                */
/*                                                                           */
/*  If defs_allowed == TRUE, there may be local definitions in the object.   */
/*  In this case, encl is guaranteed to be the enclosing definition.         */
/*                                                                           */
/*  If transfer_allowed == TRUE, the parser may transfer components to the   */
/*  galley handler as they are read.                                         */
/*                                                                           */
/*  Note: the lexical analyser returns "@End \Input" at end of input, so the */
/*  parser does not have to handle end of input separately.                  */
/*                                                                           */
/*****************************************************************************/

OBJECT Parse(OBJECT *token, OBJECT encl,
BOOLEAN defs_allowed, BOOLEAN transfer_allowed)
{ OBJECT t, x, tmp, xsym, env, y, link, res, imps, xlink;
  int i, offset, lnum, initial_ttop = ttop;
  int obj_prev, scope_count, compulsory_count;  BOOLEAN revealed;

  debugcond4(DOP, DD, debug_now, "[ Parse(%s, %s, %s, %s)", EchoToken(*token),
      SymName(encl), bool(defs_allowed), bool(transfer_allowed));
  assert( type(*token) == LBR || type(*token) == BEGIN, "Parse: *token!" );

  obj_prev = PREV_OP;
  Shift(*token, precedence(*token), 0, FALSE, TRUE);
  t = LexGetToken();
  if( defs_allowed )
  { ReadDefinitions(&t, encl, LOCAL);

    /* if error in definitions, stop now */
    if( ErrorSeen() )
      Error(6, 14, "exiting now (error in definitions)", FATAL, &fpos(t));

    if( encl == StartSym )
    {
      /* read @Use, @Database, and @Prepend commands and defs and construct env */
      New(env, ENV);
      for(;;)
      {
	if( type(t) == WORD && (
	    StringEqual(string(t), KW_DEF)     ||
	    /* StringEqual(string(t), KW_FONTDEF) || */
	    StringEqual(string(t), KW_LANGDEF) ||
	    StringEqual(string(t), KW_MACRO)   ||
	    StringEqual(string(t), KW_IMPORT)  ||
	    StringEqual(string(t), KW_EXTEND)  ||
	    StringEqual(string(t), KW_EXPORT)  ) )
	{
	  ReadDefinitions(&t, encl, LOCAL);

          /* if error in definitions, stop now */
          if( ErrorSeen() )
	    Error(6, 39, "exiting now (error in definitions)", FATAL, &fpos(t));

	}
	else if( type(t) == USE )
	{
	  OBJECT crs, res_env;  STYLE style;
	  Dispose(t);  t = LexGetToken();
	  if( type(t) != LBR )
	    Error(6, 15, "%s expected after %s", FATAL, &fpos(t),KW_LBR,KW_USE);
	  debug0(DOP, DD, "  Parse() calling Parse for @Use clause");
	  y = Parse(&t, encl, FALSE, FALSE);
	  if( is_cross(type(y)) )
	  { OBJECT z;
	    Child(z, Down(y));
	    if( type(z) == CLOSURE )
	    { crs = nilobj;
	      y = CrossExpand(y, env, &style, &crs, &res_env);
	      if( crs != nilobj )
	      { Error(6, 16, "%s or %s tag not allowed here",
		  FATAL, &fpos(y), KW_PRECEDING, KW_FOLLOWING);
	      }
	      HuntCommandOptions(y);
	      AttachEnv(res_env, y);
	      debug0(DCR, DDD, "  calling SetEnv from Parse (a)");
	      env = SetEnv(y, env);
	    }
	    else Error(6, 17, "invalid parameter of %s", FATAL, &fpos(y), KW_USE);
	  }
	  else if( type(y) == CLOSURE )
	  { if( use_invocation(actual(y)) != nilobj )
	      Error(6, 18, "symbol %s occurs in two %s clauses",
		FATAL, &fpos(y), SymName(actual(y)), KW_USE);
	    use_invocation(actual(y)) = y;
	    HuntCommandOptions(y);
	    AttachEnv(env, y);
	    debug0(DCR, DDD, "  calling SetEnv from Parse (b)");
	    env = SetEnv(y, nilobj);
	  }
	  else Error(6, 19, "invalid parameter of %s", FATAL, &fpos(y), KW_USE);
	  PushScope(actual(y), FALSE, TRUE);
	  t = LexGetToken();
        }
	else if( type(t) == PREPEND || type(t) == SYS_PREPEND )
	{ ReadPrependDef(type(t), encl);
	  Dispose(t);
	  t = LexGetToken();
	}
	else if( type(t) == INCG_REPEATED || type(t) == SINCG_REPEATED )
	{ ReadIncGRepeatedDef(type(t), encl);
	  Dispose(t);
	  t = LexGetToken();
	}
	else if( type(t) == DATABASE || type(t) == SYS_DATABASE )
	{ ReadDatabaseDef(type(t), encl);
	  Dispose(t);
	  t = LexGetToken();
	}
	else break;
      }

      /* transition point from defs to content; turn on debugging now */
#if DEBUG_ON
      debug_now = TRUE;
#endif
      InDefinitions = FALSE;
      debug0(DOP, D, "Parse() setting InDefinitions to FALSE");
      debugcond4(DOP, DD, debug_now, "[ Parse (first) (%s, %s, %s, %s)",
	EchoToken(*token), SymName(encl), bool(defs_allowed),
	bool(transfer_allowed));

      /* load cross-references from previous run, open new cross refs */
      if( AllowCrossDb )
      {
	  NewCrossDb = DbCreate(MakeWord(WORD, string(cross_name), no_fpos));
	  OldCrossDb = DbLoad(cross_name, SOURCE_PATH, FALSE, nilobj,
	    InMemoryDbIndexes);
      }
      else OldCrossDb = NewCrossDb = nilobj;

      /* tidy up and possibly print symbol table */
      FlattenUses();
      ifdebug(DST, DD, DebugObject(StartSym));

      TransferInit(env);
      debug0(DMA, D, "at end of definitions:");
      ifdebug(DMA, D, DebugMemory());
    }
  }

  for(;;)
  { 
    debugcond0(DOP, DD, debug_now, "");
    ifdebugcond(DOP, DD, debug_now, DebugStacks(0, obj_prev));
    debugcond0(DOP, DD, debug_now, "");
    debugcond2(DOP, DD, debug_now, ">> %s (precedence %d)", EchoToken(t), precedence(t));

    switch( type(t) )
    {

      case WORD:
      
	if( string(t)[0] == CH_SYMSTART &&
	  (obj_prev != PREV_OBJ || vspace(t) + hspace(t) > 0) )
	{
	  Error(6, 20, "symbol %s unknown or misspelt",
	    WARN, &fpos(t), string(t));
	  if( ++unknown_count > 25 )
	  {
	    Error(6, 21, "too many errors (%s lines missing or out of order?)",
	      FATAL, &fpos(t), KW_SYSINCLUDE);
	  }
	}
	ShiftObj(t, PREV_OBJ);
	t = LexGetToken();
	break;


      case QWORD:
      
	ShiftObj(t, PREV_OBJ);
	t = LexGetToken();
	break;


      case VCAT:
      case HCAT:
      case ACAT:
      
	/* clean up left context */
	Shift(t, precedence(t), LEFT_ASSOC, TRUE, TRUE);

	/* invoke transfer subroutines if appropriate */
	/* *** if( type(t) == VCAT && !has_join(actual(t)) *** */
	if( transfer_allowed && type(t) == VCAT && !has_join(actual(t))
		&& type(tok_stack[ttop-2]) == GSTUB_EXT )
	{
	  debug0(DGT, DD, "  calling TransferComponent from Parse:");
	  ifdebug(DGT, DD, DebugStacks(0, obj_prev));
	  TransferComponent( PopObj() );
	  New(tmp, NULL_CLOS);
	  FposCopy( fpos(tmp), fpos(t) );
	  PushObj(tmp);
	}

	/* push GAP_OBJ token, to cope with 3 parameters */
	New(x, GAP_OBJ);
	mark(gap(x)) = has_mark(actual(t));
	join(gap(x)) = has_join(actual(t));
	hspace(x) = hspace(t);
	vspace(x) = vspace(t);
	precedence(x) = GAP_PREC;
	FposCopy( fpos(x), fpos(t) );
	Shift(x, GAP_PREC, LEFT_ASSOC, FALSE, TRUE);

	/* if op is followed by space, insert {} */
	t = LexGetToken();
	if( hspace(t) + vspace(t) > 0 )
	{ ShiftObj(MakeWord(WORD, STR_EMPTY, &fpos(x)), PREV_OBJ);
	}
	break;


      case CROSS:
      case FORCE_CROSS:
      case NULL_CLOS:
      case PAGE_LABEL:
      case BEGIN_HEADER:
      case END_HEADER:
      case SET_HEADER:
      case CLEAR_HEADER:
      case ONE_COL:
      case ONE_ROW:
      case WIDE:
      case HIGH:
      case HSHIFT:
      case VSHIFT:
      case HMIRROR:
      case VMIRROR:
      case HSCALE:
      case VSCALE:
      case HCOVER:
      case VCOVER:
      case SCALE:
      case KERN_SHRINK:
      case HCONTRACT:
      case VCONTRACT:
      case HLIMITED:
      case VLIMITED:
      case HEXPAND:
      case VEXPAND:
      case START_HVSPAN:
      case START_HSPAN:
      case START_VSPAN:
      case HSPAN:
      case VSPAN:
      case PADJUST:
      case HADJUST:
      case VADJUST:
      case ROTATE:
      case BACKGROUND:
      case CASE:
      case YIELD:
      case BACKEND:
      case XCHAR:
      case FONT:
      case SPACE:
      case YUNIT:
      case ZUNIT:
      case SET_CONTEXT:
      case GET_CONTEXT:
      case BREAK:
      case UNDERLINE:
      case UNDERLINE_COLOUR:
      case COLOUR:
      case TEXTURE:
      case OUTLINE:
      case LANGUAGE:
      case CURR_LANG:
      case CURR_FAMILY:
      case CURR_FACE:
      case CURR_YUNIT:
      case CURR_ZUNIT:
      case COMMON:
      case RUMP:
      case MELD:
      case INSERT:
      case ONE_OF:
      case NEXT:
      case TAGGED:
      case INCGRAPHIC:
      case SINCGRAPHIC:
      case PLAIN_GRAPHIC:
      case GRAPHIC:
      case LINK_SOURCE:
      case LINK_DEST:
      case LINK_URL:

	/* clean up left context of t (these ops are all right associative) */
	Shift(t, precedence(t), RIGHT_ASSOC,
	  has_lpar(actual(t)), has_rpar(actual(t)));
	t = LexGetToken();
	break;


      case VERBATIM:
      case RAW_VERBATIM:

	/* clean up left context of t */
	x = t;
	Shift(t, precedence(t), RIGHT_ASSOC,
	  has_lpar(actual(t)), has_rpar(actual(t)));
	
	/* check for opening brace or begin following, and shift it onto the stacks */
	t = LexGetToken();
	if( type(t) != BEGIN && type(t) != LBR )
	  Error(6, 40, "right parameter of %s or %s must be enclosed in braces",
	    FATAL, &fpos(x), KW_VERBATIM, KW_RAWVERBATIM);
        actual(t) = type(x) == VERBATIM ? VerbatimSym : RawVerbatimSym;
	Shift(t, LBR_PREC, 0, FALSE, TRUE);

	/* read right parameter and add it to the stacks, and reduce */
	y = LexScanVerbatim( (FILE *) NULL, type(t) == BEGIN, &fpos(t),
	  type(x) == RAW_VERBATIM);
	ShiftObj(y, PREV_OBJ);

	/* carry on, hopefully to the corresponding right brace or @End @Verbatim */
	t = LexGetToken();
	break;


      case PLUS:
      case MINUS:

	/* clean up left context of t (these ops are all left associative) */
	Shift(t, precedence(t), LEFT_ASSOC,
	  has_lpar(actual(t)), has_rpar(actual(t)));
	t = LexGetToken();
	break;


      case UNEXPECTED_EOF:

	Error(6, 22, "unexpected end of input", FATAL, &fpos(t));
	break;


      case BEGIN:
      
	if( actual(t) == nilobj )
	{ Error(6, 23, "%s replaced by %s", WARN, &fpos(t), KW_BEGIN, KW_LBR);
	  type(t) = LBR;
	}
	/* NB NO BREAK! */


      case LBR:
      
	Shift(t, LBR_PREC, 0, FALSE, TRUE);
	t = LexGetToken();
	break;


      case END:
      
	if( actual(t) == nilobj )  /* haven't sought following symbol yet */
	{ x = LexGetToken();
	  if( type(x) == CLOSURE )
	  { actual(t) = actual(x);
	    Dispose(x);
	    x = nilobj;
	  }
	  else if( type(x) == VERBATIM )
	  { actual(t) = VerbatimSym;
	    Dispose(x);
	    x = nilobj;
	  }
	  else if( type(x) == RAW_VERBATIM )
	  { actual(t) = RawVerbatimSym;
	    Dispose(x);
	    x = nilobj;
	  }
	  else if( type(x) == WORD && string(x)[0] == CH_SYMSTART )
	  { Error(6, 24, "unknown or misspelt symbol %s after %s deleted",
	      WARN, &fpos(x), string(x), KW_END);
	    actual(t) = nilobj;
	    Dispose(x);
	    x = nilobj;
	  }
	  else
	  { Error(6, 25, "symbol expected after %s", WARN, &fpos(x), KW_END);
	    actual(t) = nilobj;
	  }
	}
	else x = nilobj;
	Shift(t, precedence(t), 0, TRUE, FALSE);
	t = (x != nilobj) ? x : LexGetToken();
	break;


      case RBR:
      
	Shift(t, precedence(t), 0, TRUE, FALSE);
	t = LexGetToken();
	break;
				

      case USE:
      case NOT_REVEALED:
      case PREPEND:
      case SYS_PREPEND:
      case INCG_REPEATED:
      case SINCG_REPEATED:
      case DATABASE:
      case SYS_DATABASE:
      
	Error(6, 26, "%s symbol out of place",
	  INTERN, &fpos(t), SymName(actual(t)));
	break;


      case ENV:
      
	/* only occurs in cross reference databases */
	res = ParseEnvClosure(t, encl);
	ShiftObj(res, PREV_OBJ);
	t = LexGetToken();
	break;


      case ENVA:
      
	/* only occurs in cross reference databases */
	offset = LexNextTokenPos() -StringLength(KW_ENVA)-StringLength(KW_LBR)-1;
	Dispose(t); t = LexGetToken();
	tmp = Parse(&t, encl, FALSE, FALSE);
	env = SetEnv(tmp, nilobj);
	ShiftObj(env, PREV_OBJ);
	t = LexGetToken();
	EnvReadInsert(file_num(fpos(t)), offset, env);
	break;


      case ENVB:
      
	/* only occurs in cross reference databases */
	offset = LexNextTokenPos() -StringLength(KW_ENVB)-StringLength(KW_LBR)-1;
	Dispose(t); t = LexGetToken();
	env = Parse(&t, encl, FALSE, FALSE);
	t = LexGetToken();
	res = Parse(&t, encl, FALSE, FALSE);
	/* env = SetEnv(res, env); fails sometimes, below is yukky patch JK */
	env = SetEnv(res, type(env) == ENV ? env : NULL);
	ShiftObj(env, PREV_OBJ);
	t = LexGetToken();
	EnvReadInsert(file_num(fpos(t)), offset, env);
	break;


      case ENVC:
      
	/* only occurs in cross reference databases */
	Dispose(t); t = LexGetToken();
	New(res, ENV);
	ShiftObj(res, PREV_OBJ);
	break;


      case ENVD:
      
	/* only occurs in cross reference databases */
	Dispose(t); t = LexGetToken();
	if( type(t) != QWORD ||
	  sscanf((char *) string(t), "%d %d", &offset, &lnum) != 2 )
	  Error(6, 37, "error in cross reference database", FATAL, &fpos(t));
	if( !EnvReadRetrieve(file_num(fpos(t)), offset, &env) )
	{ LexPush(file_num(fpos(t)), offset, DATABASE_FILE, lnum, TRUE);
	  Dispose(t);  t = LexGetToken();
	  env = Parse(&t, encl, FALSE, FALSE);
	  LexPop();
	}
	else
	{ Dispose(t);
	}
	ShiftObj(env, PREV_OBJ);
	t = LexGetToken();
	break;


      case CENV:
      
	/* only occurs in cross reference databases */
	Dispose(t); t = LexGetToken();
	env = Parse(&t, encl, FALSE, FALSE);
	scope_count = 0;
	SetScope(env, &scope_count, FALSE);
	t = LexGetToken();
	res = Parse(&t, encl, FALSE, FALSE);
	for( i = 0;  i < scope_count;  i++ ) PopScope();
	AttachEnv(env, res);
	ShiftObj(res, PREV_OBJ);
	t = LexGetToken();
	break;


      case LUSE:

	/* only occurs in cross-reference databases */
	/* copy invocation from use_invocation(xsym), don't read it */
	Dispose(t);  t = LexGetToken();
	if( type(t) != CLOSURE )
	  Error(6, 27, "symbol expected following %s", FATAL,&fpos(t),KW_LUSE);
	xsym = actual(t);
	if( use_invocation(xsym) == nilobj )
	  Error(6, 28, "%s clause(s) changed from previous run",
	    FATAL, &fpos(t), KW_USE);
	x = CopyObject(use_invocation(xsym), no_fpos);
	for( link = LastDown(x);  link != x;  link = PrevDown(link) )
	{ Child(y, link);
	  if( type(y) == ENV )
	  { DeleteLink(link);
	    break;
	  }
	}
	ShiftObj(x, PREV_OBJ);
	t = LexGetToken();
	break;


      case LVIS:
      
	/* only occurs in cross-reference databases */
	SuppressVisible();
	Dispose(t);  t = LexGetToken();
	UnSuppressVisible();
	if( type(t) != CLOSURE )
	  Error(6, 29, "symbol expected following %s", FATAL,&fpos(t),KW_LVIS);
	/* NB NO BREAK! */


      case CLOSURE:
      
	x = t;  xsym = actual(x);

	/* look ahead one token, which could be an NPAR */
	/* or could be @NotRevealed */
	PushScope(xsym, TRUE, FALSE);
	t = LexGetToken();
	if( type(t) == NOT_REVEALED )
	{ Dispose(t);
	  t = LexGetToken();
	  revealed = FALSE;
	}
	else revealed = TRUE;
	PopScope();

	/* if x starts a cross-reference, make it a CLOSURE */
	if( is_cross(type(t)) )
	{ ShiftObj(x, PREV_OBJ);
	  break;
	}

	/* clean up left context of x */
	Shift(x,precedence(x),right_assoc(xsym),has_lpar(xsym),has_rpar(xsym));

	/* update uses relation if required */
	if( encl != StartSym && encl != nilobj )
	{ if( has_target(xsym) )
	  { uses_galley(encl) = TRUE;
	    dirty(encl) = (dirty(encl) || dirty(xsym));
	  }
	  else if( revealed )  InsertUses(encl, xsym);
	}

	/* read named parameters */
	compulsory_count = 0;
	while( (type(t) == CLOSURE && enclosing(actual(t)) == xsym
				       && type(actual(t)) == NPAR)
	  || (type(t) == LBR && precedence(t) != LBR_PREC) )
	{	
	  OBJECT new_par;

	  /* check syntax and attach the named parameter to x */
	  if( type(t) == CLOSURE )
	  {
	    new_par = t;
	    t = LexGetToken();
	    if( type(t) != LBR )
	    { Error(6, 30, "%s must follow named parameter %s",
	        WARN, &fpos(new_par), KW_LBR, SymName(actual(new_par)));
	      Dispose(new_par);
	      break;
	    }
	  }
	  else
	  {
	    /* compressed form of named parameter */
	    new_par = NewToken(CLOSURE, &fpos(t), vspace(t), hspace(t),
	      NO_PREC, ChildSymWithCode(x, precedence(t)));
	    precedence(t) = LBR_PREC;
	  }

	  /* add import list of the named parameter to current scope */
	  scope_count = 0;
	  imps = imports(actual(new_par));
	  if( imps != nilobj )
	  { for( link = Down(imps);  link != imps;  link = NextDown(link) )
	    { Child(y, link);
	      PushScope(actual(y), FALSE, TRUE);
	      scope_count++;
	    }
	  }

	  /* read the body of the named parameter */
	  PushScope(actual(new_par), FALSE, FALSE);
	  tmp = Parse(&t, encl, FALSE, FALSE);
	  PopScope();
	  type(new_par) = PAR;
	  Link(new_par, tmp);

	  /* pop the scopes pushed for the import list */
	  for( i = 0;  i < scope_count;  i++ )
	    PopScope();

	  /* check that new_par has not already occurred, then link it to x */
	  for( link = Down(x);  link != x;  link = NextDown(link) )
	  { Child(y, link);
	    assert( type(y) == PAR, "Parse: type(y) != PAR!" );
	    if( actual(new_par) == actual(y) )
	    { Error(6, 31, "named parameter %s of %s appears twice", WARN,
		&fpos(new_par), SymName(actual(new_par)), SymName(actual(x)));
	      DisposeObject(new_par);
	      new_par = nilobj;
	      break;
	    }
	  }
	  if( new_par != nilobj )
	  {
	    /* keep track of the number of compulsory named parameters */
	    if( is_compulsory(actual(new_par)) )
	      compulsory_count++;

	    Link(x, new_par);
	  }

	  /* get next token, possibly another NPAR */
	  PushScope(xsym, TRUE, FALSE);	 /* allow NPARs only */
	  if( t == nilobj )  t = LexGetToken();
	  PopScope();

	} /* end while */

	/* report absence of compulsory parameters */
	debug4(DOP, DD, "%s %s %d : %d", EchoFilePos(&fpos(x)),
	  SymName(xsym), compulsory_count, has_compulsory(xsym));
	if( compulsory_count < has_compulsory(xsym) )
	{
	  for( xlink = Down(xsym);  xlink != xsym;  xlink = NextDown(xlink) )
	  { Child(tmp, xlink);
	    if( type(tmp) == NPAR && is_compulsory(tmp) )
	    { for( link = Down(x);  link != x;  link = NextDown(link) )
	      { Child(y, link);
		if( type(y) == PAR && actual(y) == tmp )
		  break;
	      }
	      if( link == x )
	      {
		Error(6, 38, "compulsory option %s missing from %s",
		  WARN, &fpos(x), SymName(tmp), SymName(xsym));
	      }
	    }
	  }
	}

	/* record symbol name in BEGIN following, if any */
	if( type(t) == BEGIN )
	{ if( !has_rpar(xsym) )
	    Error(6, 32, "%s out of place here (%s has no right parameter)",
	      WARN, &fpos(x), KW_BEGIN, SymName(xsym));
	  else actual(t) = xsym;
	}

	/* if x can be transferred, do so */
	if( transfer_allowed && has_target(xsym) &&
	    !has_key(xsym) && filter(xsym) == nilobj )
	{   
	  if( !has_rpar(xsym) || uses_count(ChildSym(xsym, RPAR)) <= 1 )
	  {
	    debug1(DGT, D, "examining transfer of %s", SymName(xsym));
	    ifdebug(DGT, D, DebugStacks(initial_ttop, obj_prev));
	    i = has_rpar(xsym) ? ttop -1 : ttop;
	    while( is_cat_op(type(tok_stack[i])) )   i--;
	    if( (type(tok_stack[i])==LBR || type(tok_stack[i])==BEGIN)
		  && type(tok_stack[i-1]) == GSTUB_EXT )
	    {
	      /* at this point it is likely that x is transferable */
	      if( has_rpar(xsym) )
	      { New(tmp, CLOSURE);
		actual(tmp) = InputSym;
		FposCopy( fpos(tmp), fpos(t) );
		ShiftObj(tmp, PREV_OBJ);
		obj_prev = Reduce();
	      }
	      x = PopObj();
	      x = TransferBegin(x);
	      if( type(x) == CLOSURE )	/* failure: unReduce */
	      {	if( has_rpar(xsym) )
		{ Child(tmp, LastDown(x));
		  assert(type(tmp)==PAR && type(actual(tmp))==RPAR,
				"Parse: cannot undo rpar" );
		  DisposeChild(LastDown(x));
		  if( has_lpar(xsym) )
		  { Child(tmp, Down(x));
		    assert(type(tmp)==PAR && type(actual(tmp))==LPAR,
				"Parse: cannot undo lpar" );
		    Child(tmp, Down(tmp));
		    PushObj(tmp);
		    DeleteLink(Up(tmp));
		    DisposeChild(Down(x));
		  }
		  PushToken(x);  obj_prev = PREV_OP;
		}
		else
		{ PushObj(x);
		  obj_prev = PREV_OBJ;
		}
	      }
	      else /* success */
	      { obj_prev = PREV_OP;
	        Shift(x, NO_PREC, 0, FALSE, has_rpar(xsym));
	      }
	    }
	  }
	} /* end if has_target */

	if( filter(xsym) != nilobj )
	{
	  if( type(t) == BEGIN || type(t) == LBR )
	  {
	    /* create filter object and copy parameter into temp file */
	    tmp = FilterCreate((BOOLEAN) (type(t) == BEGIN), xsym, &fpos(t));

	    /* push filter object onto stacks and keep going */
	    Shift(t, precedence(t), 0, FALSE, TRUE);
	    ShiftObj(tmp, PREV_OBJ);
	    t = LexGetToken();
	  }
	  else Error(6, 33, "right parameter of %s must be enclosed in braces",
		 FATAL, &fpos(x), SymName(xsym));
	}

	else if( has_body(xsym) )
	{ if( type(t) == BEGIN || type(t) == LBR )
	  { PushScope(xsym, FALSE, TRUE);
	    PushScope(ChildSym(xsym, RPAR), FALSE, FALSE);
	    PushObj( Parse(&t, encl, FALSE, TRUE) );
	    obj_prev = Reduce();
	    PopScope();
	    PopScope();
	    if( t == nilobj )  t = LexGetToken();
	  }
	  else
	  { Error(6, 34, "body parameter of %s must be enclosed in braces",
	      WARN, &fpos(t), SymName(xsym));
	  }
	}
	break;


      case OPEN:

	x = t;  xsym = nilobj;
	Shift(t, precedence(t), RIGHT_ASSOC, TRUE, TRUE);
	if( type(ObjTop) == CLOSURE )  xsym = actual(ObjTop);
	else if( is_cross(type(ObjTop)) && Down(ObjTop) != ObjTop )
	{ Child(tmp, Down(ObjTop));
	  if( type(tmp) == CLOSURE )  xsym = actual(tmp);
	}
	t = LexGetToken();

	if( xsym == nilobj )
	  Error(6, 35, "invalid left parameter of %s", WARN, &fpos(x), KW_OPEN);
	else if( type(t) != BEGIN && type(t) != LBR )
	  Error(6, 36, "right parameter of %s must be enclosed in braces",
	    WARN, &fpos(t), KW_OPEN);
	else
	{ PushScope(xsym, FALSE, TRUE);
	  tmp = Parse(&t, encl, FALSE, FALSE);
	  ShiftObj(tmp, PREV_RBR);
	  PopScope();
	  if( t == nilobj )  t = LexGetToken();
	  obj_prev = Reduce();
	}
	break;


      default:
      
	assert1(FALSE, "Parse:", Image(type(t)));
	break;

    } /* end switch */
  } /* end for */

} /* end Parse */