%{

/*
 *	Copyright (c) 2002 by Laboratoire Spécification et Vérification (LSV),
 *	CNRS UMR 8643 & ENS Cachan.
 *	Written by Jean Goubault-Larrecq.  Not derived from licensed software.
 *
 *	Permission is granted to anyone to use this software for any
 *	purpose on any computer system, and to redistribute it freely,
 *	subject to the following restrictions:
 *
 *	1. Neither the author nor its employer is responsible for the consequences of use of
 *		this software, no matter how awful, even if they arise
 *		from defects in it.
 *
 *	2. The origin of this software must not be misrepresented, either
 *		by explicit claim or by omission.
 *
 *	3. Altered versions must be plainly marked as such, and must not
 *		be misrepresented as being the original software.
 *
 *	4. This software is restricted to non-commercial use only.  Commercial
 *		use is subject to a specific license, obtainable from LSV.
 *		This was developed as part of the EVA project; as such, access
 *		to this software by partners of the RNTL EVA Project (Trusted
 *		Logic S.A., Verimag) is defined by the intellectual property
 *		agreement signed as part of this project.
 */

#include <stdlib.h>
#include <stdio.h>
#include <setjmp.h>
#include "yyltype.h"

extern char *yytext;
extern char string_buf[];

extern void yyerr(char *msg, char *more); /* in spec.l */
extern void yywarn(char *msg, char *more); /* in spec.l */
#define YYERROR_VERBOSE
static struct cell *theCommand = NULL;
extern int theSpecLineno;

jmp_buf errbuf;
int yyparse (void);
extern int yylex (void);

#define X_FUNC 0
#define X_INT 1
#define X_STRING 2
#define X_CONS 3

typedef struct cell {
  unsigned int type:2;
  unsigned int n:30;
  union {
    struct func { struct cell *(*fun) (struct cell *, struct cell *); struct cell *env; } f;
    int i;
    struct str { struct str *next; char *text; } s;
    struct cons { struct cell *car, *cdr; } c;
  } what;
} cell;

#define NCELLS 1024

struct cellblock {
  struct cellblock *next;
  cell c[NCELLS];
};

void *Malloc(size_t size)
{
  void *p;

  p = malloc(size);
  if (p==NULL)
    {
      fprintf (stderr, "Sorry, cannot allocate %d bytes.\n", size);
      exit(10);
    }
  return p;
}

 static void yyerror(char *msg);

static struct cellblock *theCellBlocks = NULL;
static cell *theFreeCells = NULL;
static struct str *theStrs = NULL;

static cell *theReturn;

struct yyltype;

static void end_parse (void)
  {
    struct cellblock *cb;
    struct str *str;

    for (str = theStrs; str!=NULL; str = str->next)
      free (str->text);
    theStrs = NULL;
    while (theCellBlocks!=NULL)
      {
	cb = theCellBlocks->next;
	free (cb);
	theCellBlocks = cb;
      }
  }

static cell *newcell (void)
  {
    cell *c, *cc;
    struct cellblock *cb;
    int i;

    c = theFreeCells;
    if (c!=NULL)
      {
	theFreeCells = c->what.c.cdr;
	return c;
      }
    cb = Malloc (sizeof (struct cellblock));
    cb->next = theCellBlocks;
    theCellBlocks = cb;
    for (i=0, cc=cb->c; i<NCELLS; i++, cc++)
      {
	cc->what.c.cdr = c;
	c = cc;
      }
    theFreeCells = c->what.c.cdr;
    return c;
  }

static cell *newfun (struct cell *(*fun)(struct cell *, struct cell *),
		     struct cell *env)
  {
    cell *c = newcell ();

    c->type = X_FUNC;
    c->n = 0;
    c->what.f.fun = fun;
    c->what.f.env = env;
    return c;
  }

static cell *newint (int n)
  {
    cell *c = newcell ();

    c->type = X_INT;
    c->n = 0;
    c->what.i = n;
    return c;
  }

static cell *newstring (char *text)
  {
    cell *c = newcell ();

    c->type = X_STRING;
    c->n = 0;
    c->what.s.next = theStrs;
    c->what.s.text = Malloc (strlen (text)+1);
    strcpy (c->what.s.text, text);
    theStrs = &c->what.s;
    return c;
  }

static cell *cons (cell *car, cell *cdr)
  {
    cell *c = newcell ();

    c->type = X_CONS;
    c->n = 0;
    c->what.c.car = car;
    c->what.c.cdr = cdr;
    return c;
  }

static char *tags[] = {
#define T_DUMMY 0
  "",
#define T_LINE 1
  "line",
#define T_SPEC 2
  "spec",
#define T_DECLARE 3
  "declare",
#define T_SESSIONS 4
  "sessions",
#define T_PROP 5
  "prop",
#define T_TYPE 6
  "type",
#define T_FUNCTION 7
  "function",
#define T_ONE_WAY_FUNCTION 8
  "one-way-function",
#define T_SECRET 9
  "secret",
#define T_N 10
  "N",
#define T_ALIAS 11
  "alias",
#define T_KNOWS 12
  "knows",
#define T_PRIVATE 13
  "private",
#define T_AXIOM 14
  "axiom",
#define T_BLOCK 15
  "block",
#define T_COMM 16
  "comm",
#define T_TST_EQUAL 17
  "equals",
#define T_ASSIGN 18
  "assign",
#define T_SWITCH 19
  "switch",
#define T_CASE 20
  "case",
#define T_TUPLE 21
  "tuple",
#define T_CRYPT 22
  "crypt",
#define T_PERCENT 23
  "percent",
#define T_APP 24
  "apply",
#define T_VANILLA 25
  "vanilla",
#define T_SESSION 26
  "session",
#define T_BIND 27
  "bind",
#define T_CLAIM 28
  "claim",
#define T_KEYPAIR 29
  "keypair",
#define T_SIGN 30
  "sign",
#define T_ASSUME 31
  "assume",
#define T_PR_ONLY 32
  "principals-only",
#define T_PR_EXCEPT 33
  "principals-except",
#define T_SESSION_REPEAT 34
  "session-repeat",
#define T_LOCAL_ALIAS 35
  "local-alias",
#define T_IMPLIES 36
  "implies",
#define T_AND 37
  "and",
#define T_OR 38
  "or",
#define T_NOT 39
  "not",
#define T_E 40
  "E",
#define T_A 41
  "A",
#define T_F 42
  "F",
#define T_G 43
  "G",
#define T_P 44
  "P",
#define T_Q 45
  "Q",
#define T_U 46
  "U",
#define T_W 47
  "W",
#define T_S 48
  "S",
#define T_B 49
  "B",
#define T_AT 50
  "at",
#define T_OWNS 51
  "owns",
#define T_LOCATE 52
  "locate",
#define T_BASETYPE 53
  "basetype",
#define T_EVERYBODY_KNOWS 54
  "everybody-knows",
#define T_SECRET_FUNCTION 55
  "secret-function",
#define T_SECRET_ONE_WAY_FUNCTION 56
  "secret-one-way-function",
#define T_TYPE_SHARED 57
  "type-shared",
};

static cell *apply (int n, cell *args)
  {
    return cons (newint (n), args);
  }

static cell *newlineinfo (struct yyltype *start, struct yyltype *end, cell *c);

static cell *applylineinfo (cell *lineinfo, cell *c)
  {
    return apply (T_LINE,
		  cons (c, lineinfo->what.c.cdr->what.c.cdr));
  }

static cell *reverse (cell *c, cell *tail)
  {
    while (c!=NULL)
      {
	tail = cons (c->what.c.car, tail);
	c = c->what.c.cdr;
      }
    return tail;
  }

static cell *append (cell *c, cell *tail)
{
  if (c==NULL)
    return tail;
  return cons (c->what.c.car, append (c->what.c.cdr, tail));
}

#ifdef OBSOLETE
static cell *type_prod (struct yyltype *start, struct yyltype *end, cell *tlst)
  {
    if (tlst==NULL)
      return newlineinfo (start, end, apply (T_UNIT, NULL));
    if (tlst->what.c.cdr==NULL)
      return tlst->what.c.car;
    return newlineinfo (start, end,
			apply (T_PRODUCT,
			       reverse (tlst, NULL)));
  }
#endif

static cell *mktuple (struct yyltype *start, struct yyltype *end, cell *tlst)
  {
    if (tlst==NULL)
      return newlineinfo (start, end, apply (T_TUPLE, NULL));
    if (tlst->what.c.cdr==NULL)
      return tlst->what.c.car;
    return newlineinfo (start, end,
			apply (T_TUPLE,
			       reverse (tlst, NULL)));
  }

static unsigned int session_counter = 0;

static cell *newsession ()
{
  char buf[128], *s, *s0, *t;
  unsigned int n, i;

  s = buf;
  *s++ = '\'';
  s0 = s;
  n = session_counter++;
  do
    {
      i = n % 26;
      n /= 26;
      *s++ = (char)('a' + i);
    }
  while (n!=0);
  for (t=s-1; s0<t; )
    {
      char c = *s0;
      *t-- = *s0;
      *s0++ = c;
    }
  *s++ = '.';
  *s = 0;
  return newstring (buf);
}

%}

%union {
  struct cell *c;
  int i;
}

%token kw_int kw_id kw_label kw_alias kw_axiom kw_basetype kw_case kw_everybody kw_hash
%token kw_knows kw_session kw_secret kw_switch kw_arrow kw_assign kw_eof
%token kw_string_constant kw_keypair kw_assume kw_claim kw_tst_equal kw_true kw_false
%token kw_shared

%right ','
%right kw_implies
%right kw_or kw_U kw_W kw_S kw_B
%right kw_and
%nonassoc '!' kw_E kw_A kw_F kw_G kw_P kw_Q kw_N

%start spec
/* type <term>: */
%type <c> spec type term block atomic_term atomic_term_or_ciphertext optional_encryption_algorithm session assignment
%type <c> principals property id label optional_label assumptions claims optional_repeat
/* type <term list>: */
%type <c> declarations declaration typing_declaration type_list optional_type_list non_empty_type_list
%type <c> tuple term_list environment properties optional_quantification typing_declarations
%type <c> assignments ids
/* type <bool>: */
%type <i> optional_hash_or_secret optional_shared
/* type <int>: */
%type <i> equals_or_assign_operator
/* type <term list>: */
%type <c> messages
/* type <term>: */
%type <c> message case
/* type <term list>: */
%type <c> cases

%%

spec : id declarations block environment assumptions claims kw_eof
{ $$ = newlineinfo (&@1, &@5,
		    apply (T_SPEC,
			   cons (newlineinfo (&@2, &@2, apply (T_DECLARE, reverse ($2, NULL))),
			   cons (newlineinfo (&@3, &@3, $3),
			   cons (newlineinfo (&@4, &@4, apply (T_SESSIONS, reverse ($4, NULL))),
			   cons (newlineinfo (&@5, &@5, $5),
			   cons (newlineinfo (&@6, &@6, $6),
				 NULL)))))));
 theReturn = $$;
 YYACCEPT; 
}
;

id : kw_id { $$ = newlineinfo (&yylloc, &yylloc, newstring (yytext)); }
;

/* declarations est une liste inversee de declarations. */
declarations : { $$ = NULL; }
| declarations declaration { $$ = reverse ($2, $1); }
;

declaration : typing_declaration
| kw_keypair optional_encryption_algorithm id ',' id optional_type_list /* note: no 'hash' keyword, every keypair is assumed to be hash. */
{
  cell *type = newlineinfo (&@1, &@1, newstring ("number"));

  if ($6!=NULL)
    type = newlineinfo (&@1, &@6, apply (T_ONE_WAY_FUNCTION, cons (type, reverse ($6, NULL))));
  $$ = cons (newlineinfo (&@1, &@5, apply (T_KEYPAIR, cons ($2, cons ($3, cons ($5, cons (type, NULL)))))),
	     NULL);
}
| kw_alias id '=' term
{
  $$ = cons (newlineinfo (&@1, &@4,
			  apply (T_ALIAS,
				 cons ($2, cons ($4, NULL)))),
	     NULL);
}
| ids ':' kw_alias id '=' term
{
  $$ = cons (newlineinfo (&@1, &@6,
  apply (T_LOCAL_ALIAS,
	 cons ($4, cons ($6, reverse ($1, NULL))))),
	     NULL);
}
| kw_basetype id
{
  $$ = cons (newlineinfo (&@1, &@2,
			  apply (T_BASETYPE,
				 cons ($2, NULL))),
	     NULL);
}
| kw_everybody kw_knows tuple
{
  cell *c, **cp;

  $$ = reverse ($3, NULL);
  for (c=$$, cp = &$$, *cp=NULL; c!=NULL; c=c->what.c.cdr, cp = &(*cp)->what.c.cdr)
    *cp = cons (newlineinfo (&@1, &@3,
			     apply (T_EVERYBODY_KNOWS, cons (c->what.c.car, NULL))),
		NULL);
}
| id kw_knows tuple
{
  cell *c, **cp;

  $$ = reverse ($3, NULL);
  for (c=$$, cp = &$$, *cp=NULL; c!=NULL; c=c->what.c.cdr, cp = &(*cp)->what.c.cdr)
    *cp = cons (newlineinfo (&@1, &@3,
			     apply (T_KNOWS, cons ($1, cons (c->what.c.car, NULL)))),
		NULL);
}
| kw_axiom term '=' term optional_quantification
{
  $$ = cons (newlineinfo (&@1, &@5,
			  apply (T_AXIOM, cons ($2, cons ($4, $5)))),
	     NULL);
}
;

optional_quantification : { $$ = NULL; }
| '[' typing_declarations ']' { $$ = reverse ($2, NULL); }
;

typing_declarations : typing_declaration { $$ = $1; }
| typing_declarations ',' typing_declaration { $$ = append ($3, $1); }
;

typing_declaration : ids ':' type optional_shared
{
  cell *c, **cp;
  for (c = $1, cp = &$$, *cp=NULL; c!=NULL; c=c->what.c.cdr, cp = &(*cp)->what.c.cdr)
    *cp = cons (newlineinfo (&@1, &@3, apply ($4?T_TYPE_SHARED:T_TYPE,
					      cons (c->what.c.car,
						    cons ($3, NULL)))),
		NULL);
}
| id '(' type_list ')' ':' type optional_hash_or_secret
{
  cell *ctype;
  int tag;

  switch ($7)
    {
    case 0: tag = T_FUNCTION; break;
    case 1: tag = T_ONE_WAY_FUNCTION; break;
    case 2: tag = T_SECRET_FUNCTION; break;
    case 3: tag = T_SECRET_ONE_WAY_FUNCTION; break;
    }
  ctype = apply (tag,
		 cons ($6, reverse ($3, NULL)));
  ctype = newlineinfo (&@2, &@7, ctype);
  $$ = cons (newlineinfo (&@1, &@7,
			  apply (T_TYPE_SHARED,
				 cons ($1, cons (ctype, NULL)))),
	     NULL);
}
;

optional_shared : { $$ = 0; }
| kw_shared { $$ = 1; }
;

optional_type_list : '(' type_list ')' { $$ = $2; }
| { $$ = NULL; }
;

/* ids est une liste inversee d'identificateurs. */
ids : id { $$ = cons ($1, NULL); }
| ids ',' id { $$ = cons ($3, $1); }
;

type : id { $$ = $1; }
;

/* type_list est une liste inversee de types. */
type_list : { $$ = NULL; }
| non_empty_type_list { $$ = $1; }
;

/* non_empty_type_list est une liste inversee de types. */
non_empty_type_list : type { $$ = cons ($1, NULL); }
| non_empty_type_list ',' type { $$ = cons ($3, $1); }
;

optional_hash_or_secret : optional_hash_or_secret kw_hash { $$ = $1 | 1; }
| optional_hash_or_secret kw_secret { $$ = $1 | 2; }
| { $$ = 0; }
;

block : '{' messages '}' { $$ = newlineinfo (&@1, &@3, apply (T_BLOCK, reverse ($2, NULL))); }
;

/* messages est une liste inversee de messages. */
messages : { $$ = NULL; }
| messages message { $$ = cons ($2, $1); }
;

message : label id kw_arrow id ':' term
{
  $$ = newlineinfo (&@1, &@6, apply (T_COMM, cons ($1, cons ($2, cons ($4, cons ($6, NULL))))));
}
| id ':' id equals_or_assign_operator atomic_term_or_ciphertext
{
  $$ = newlineinfo (&@1, &@5, apply ($4, cons ($1, cons ($3, cons ($5, NULL)))));
}
| block
| kw_switch term '{' cases '}'
{
  $$ = newlineinfo (&@1, &@5, apply (T_SWITCH, cons ($2, reverse ($4, NULL))));
}
;

label : kw_label { $$ = newstring (yytext); }
;

equals_or_assign_operator : kw_tst_equal { $$ = T_TST_EQUAL; }
| kw_assign { $$ = T_ASSIGN; }
;

/* cases est une liste inversee de cas. */
cases : { $$ = NULL; }
| cases case { $$ = cons ($2, $1); }
;

case : kw_case term ':' messages
{
  $$ = newlineinfo (&@1, &@4, apply (T_CASE, cons ($2, reverse ($4, NULL))));
}
;

term : tuple { $$ = mktuple (&@1, &@1, $1); }
;

/* tuple est une liste inversee de termes. */
tuple : atomic_term_or_ciphertext { $$ = cons ($1, NULL); }
| tuple ',' atomic_term_or_ciphertext { $$ = cons ($3, $1); }
;

/* term_list est une liste inversee de terms. */
term_list : '(' ')' { $$ = NULL; }
| '(' tuple ')' { $$ = $2; }
;

atomic_term_or_ciphertext : atomic_term { $$ = $1; }
| '{' term '}' '_' atomic_term optional_encryption_algorithm
{
  $$ = newlineinfo (&@1, &@6, apply (T_CRYPT,
				     cons ($2, cons ($5, cons ($6, NULL)))));
}
| '{' term '}' '^' atomic_term '_' atomic_term
{
  $$ = newlineinfo (&@1, &@6, apply (T_CRYPT,
				     cons ($2, cons ($7, cons ($5, NULL)))));
}
| '[' term ']' '_' atomic_term optional_encryption_algorithm
{
  $$ = newlineinfo (&@1, &@6, apply (T_SIGN,
				     cons ($2, cons ($5, cons ($6, NULL)))));
}
| '[' term ']' '^' atomic_term '_' atomic_term
{
  $$ = newlineinfo (&@1, &@6, apply (T_SIGN,
				     cons ($2, cons ($7, cons ($5, NULL)))));
}
| atomic_term '%' atomic_term
{
  $$ = newlineinfo (&@1, &@3, apply (T_PERCENT,
				     cons ($1, cons ($3, NULL))));
}
| atomic_term_or_ciphertext '@' label id
{
  $$  = newlineinfo (&@1, &@4, apply (T_LOCATE,
				      cons ($3, cons ($4, cons ($1, NULL)))));
}
;

atomic_term : id term_list
{
  $$ = newlineinfo (&@1, &@2, apply (T_APP,
				     cons ($1, reverse ($2, NULL))));
}
| id { $$ = $1; }
| '(' term ')' { $$ = $2; }
| '(' ')'
{
  $$ = newlineinfo (&@1, &@2, apply (T_TUPLE, NULL));
}
;

optional_encryption_algorithm : { $$ = apply (T_VANILLA, NULL); }
| '^' atomic_term { $$ = $2; }
;

/* environment est une liste inversee de sessions. */
environment : { $$ = NULL; }
| environment session { $$ = cons ($2, $1); }
;

session : optional_label kw_session optional_repeat principals assignments
{
  $$ = cons ($1, cons ($4, reverse ($5, NULL)));
  if ($3!=NULL)
    $$ = apply (T_SESSION_REPEAT, cons ($3, $$));
  else $$ = apply (T_SESSION, $$);
  $$ = newlineinfo (&@1, &@5, $$);
}
;

optional_label : label
| { $$ = newsession (); }
;

optional_repeat : { $$ = NULL; }
| '*' '{' ids '}' { $$ = newlineinfo (&@2, &@4, apply (T_PRIVATE, reverse ($3, NULL))); }
| '*' '{' '}' { $$ = newlineinfo (&@2, &@3, apply (T_PRIVATE, NULL)); }
| '*' { $$ = newlineinfo (&@1, &@1, apply (T_PRIVATE, NULL)); }
;

/* assignments est une liste inversee d'affectations de noms de principaux a des roles. */
assignments : assignment { $$ = cons ($1, NULL); }
| assignments ',' assignment { $$ = cons ($3, $1); }
;

assignment : id '=' atomic_term_or_ciphertext
{
  $$ = newlineinfo (&@1, &@3, apply (T_BIND, cons ($1, cons ($3, NULL))));
}
;

principals : '[' ids ']' { $$ = newlineinfo (&@1, &@3, apply (T_PR_ONLY, reverse ($2, NULL))); }
| '[' '^' ids ']' { $$ = newlineinfo (&@1, &@4, apply (T_PR_EXCEPT, reverse ($3, NULL))); }
| { $$ = newlineinfo (&yylloc, &yylloc, apply (T_PR_EXCEPT, NULL)); }
;

assumptions : kw_assume properties
{
  $$ = apply (T_ASSUME, reverse ($2, NULL));
}
| { $$ = apply (T_ASSUME, NULL); }
;

claims : kw_claim properties
{
  $$ = apply (T_CLAIM, reverse ($2, NULL));
}
| { $$ = apply (T_CLAIM, NULL); }
;

/* properties est une liste inversee de proprietes a verifier. */
properties : property { $$ = cons ($1, NULL); }
| properties ',' property { $$ = cons ($3, $1); }
;

property : id term_list
{ $$ = newlineinfo (&@1, &@2, apply (T_PROP, cons ($1, reverse ($2, NULL)))); }
| label id '@' label
{ $$ = newlineinfo (&@1, &@4, apply (T_AT, cons ($1, cons ($2, cons ($4, NULL))))); }
| label id '(' term ')'
{ $$ = newlineinfo (&@1, &@5, apply (T_OWNS, cons ($1, cons ($2, reverse ($4, NULL))))); }
| kw_secret '(' term ')'
{ $$ = newlineinfo (&@1, &@4, apply (T_SECRET, cons ($3, NULL))); }
| property kw_and property
{ $$ = newlineinfo (&@1, &@3, apply (T_AND, cons ($1, cons ($3, NULL)))); }
| kw_true
{ $$ = newlineinfo (&@1, &@1, apply (T_AND, NULL)); }
| property kw_or property
{ $$ = newlineinfo (&@1, &@3, apply (T_OR, cons ($1, cons ($3, NULL)))); }
| kw_false
{ $$ = newlineinfo (&@1, &@1, apply (T_OR, NULL)); }
| property kw_implies property
{ $$ = newlineinfo (&@1, &@3, apply (T_IMPLIES, cons ($1, cons ($3, NULL)))); }
| '!' property
{ $$ = newlineinfo (&@1, &@2, apply (T_NOT, cons ($2, NULL))); }
| '(' property ')'
{ $$ = $2; }
| kw_E property
{ $$ = newlineinfo (&@1, &@2, apply (T_E, cons ($2, NULL))); }
| kw_A property
{ $$ = newlineinfo (&@1, &@2, apply (T_A, cons ($2, NULL))); }
| kw_N property
{ $$ = newlineinfo (&@1, &@2, apply (T_N, cons ($2, NULL))); }
| kw_F property
{ $$ = newlineinfo (&@1, &@2, apply (T_F, cons ($2, NULL))); }
| kw_G property
{ $$ = newlineinfo (&@1, &@2, apply (T_G, cons ($2, NULL))); }
| kw_P property
{ $$ = newlineinfo (&@1, &@2, apply (T_P, cons ($2, NULL))); }
| kw_Q property
{ $$ = newlineinfo (&@1, &@2, apply (T_Q, cons ($2, NULL))); }
| property kw_U property
{ $$ = newlineinfo (&@1, &@3, apply (T_U, cons ($1, cons ($3, NULL)))); }
| property kw_W property
{ $$ = newlineinfo (&@1, &@3, apply (T_W, cons ($1, cons ($3, NULL)))); }
| property kw_S property
{ $$ = newlineinfo (&@1, &@3, apply (T_S, cons ($1, cons ($3, NULL)))); }
| property kw_B property
{ $$ = newlineinfo (&@1, &@3, apply (T_B, cons ($1, cons ($3, NULL)))); }
;

%%

static void yyerror(char *msg)
  {
    int len;
    char *more, *s;

    len = strlen(yytext) + 48;
    if (theCommand!=NULL)
      len += strlen (theCommand->what.s.text) + 16;
    s = more = (char *)Malloc(len+16);
    more[0] = 0;
    if (theCommand!=NULL)
      {
	sprintf (more, " in '%s'", theCommand->what.s.text);
	s = more + strlen (more);
      }
    sprintf (s, ", line %d", yylloc.last_line);
    s += strlen (s);
    if (yytext[0])
      sprintf(s, " (at '%s')", yytext);
    yyerr (msg, more);
    /*
    free(more);
    */
  }

static cell *newlineinfo (struct yyltype *start, struct yyltype *end, cell *c)
  {
    return apply (T_LINE,
		  cons (c,
			cons (newint (start->first_line),
			      cons (newint (start->first_column),
				    cons (newint (end->last_line),
					  cons (newint (end->last_column),
						cons (newstring (end->text?end->text:
								 (start->text?start->text:"")),
						      NULL)))))));
  }

static void usage (void)
{
  fprintf (stderr, "evaparse [input-file].\n");
}

void print_string1 (FILE *f, char *s, int len)
{
  char *send = s+len;
  char c;

  for (; s<send; )
    {
      c = *s++;
      if ((c & 0x60)!=0)
	{
	  if (c=='\\' || c=='\"')
	    fputc ('\\', f);
	  fputc (c, f);
	}
      else switch (c)
	{
	case '\n': fputc ('\\', f); fputc ('n', f); break;
	case '\t': fputc ('\\', f); fputc ('t', f); break;
#if '\n'!='\r'
	case '\r': fputc ('\\', f); fputc ('r', f); break;
#endif
	case '\b': fputc ('\\', f); fputc ('b', f); break;
	case '\f': fputc ('\\', f); fputc ('f', f); break;
	default: fputc ('\\', f);
	  fputc (((c >> 6) & 7)+'0', f);
	  fputc (((c >> 3) & 7)+'0', f);
	  fputc (((c >> 0) & 7)+'0', f);
	  break;
	}
    }
}

void print_string (FILE *f, char *s, int len)
{
  fputc ('\"', f);
  print_string1 (f, s, len);
  fputc ('\"', f);
}

static void pcell (FILE *f, cell *c)
{
  if (c==NULL)
    fputs ("(nil)", f);
  else switch (c->type)
    {
    case X_FUNC:
      fputs ("<fun>", f);
      break;
    case X_INT:
      fprintf (f, "%d", c->what.i);
      break;
    case X_STRING:
      print_string (f, c->what.s.text, strlen (c->what.s.text));
      break;
    default: /* case X_CONS: */
      fputc ('(', f);
      fputs (tags[c->what.c.car->what.i], f);
      for (; c = c->what.c.cdr, c!=NULL; )
	{
	  fputc (' ', f);
	  pcell (f, c->what.c.car);
	}
      fputc (')', f);
      break;
    }
}

extern FILE *yyin;

int main (int argc, char *argv[])
{
  int i;
  char *infname = NULL;

  yyin = stdin;
  for (i=1; i<argc; i++)
    {
      switch (argv[i][0])
	{
	case '-':
	  usage ();
	  exit (1);
	  break;
	default:
	  if (infname!=NULL)
	    {
	      fprintf (stderr,
		       "evaparse: input file already specified ('%s').\n",
		       infname);
	      exit (1);
	    }
	  yyin = fopen (infname = argv[i], "r");
	  break;
	}
    }
  if (setjmp (errbuf)!=0)
    exit (1);
  (void) yyparse ();
  pcell (stdout, theReturn);
  fputs ("\n", stdout);
  fflush (stdout);
  return 0;
}