#include "lisp.h"

#define MAXCALL 100	/* maximum number of nested macro calls (for error checking) */

/* object _eval(),_car(),_cdr(),_cons(),_memq(),_list(); */
object _eval(),_car(),_cdr(),_cons(),_memq(),_list(),_rcar(),_rcdr();
object _cond(),_prog(),_defun(),_do();
object _load(),_prnt(),_prn1(),_prnc(),_terpri(),_printf();
object _iopen(),_oopen(),_lclose(),_rread();
object _quote(),_setq(),_fset(),_set(),_symeval(),_fsymeval(),_msym(),_ssym();
object _add(),_sub(),_mul(),_div(),_rem(),_inc(),_dec(),_max(),_min(),_abs();
object _fix(),_float();
object _lt(),_le(),_eqeq(),_ne(),_ge(),_gt();
object _and(),_or(),_null(),_eq(),_equal(),_atom(),_numberp(),_stringp();

object ev_next();
object t;

/* primitive routines for NET */

int oldfmt = 0;		/* <>0 means size are length/width rather than width/length */
double elength = 2.0;	/* default channel length for enhancement device */
double ewidth = 2.0;	/* default channel width for enhancement device */
double ilength = 2.0;	/* default channel length for intrinsic device */
double iwidth = 2.0;	/* default channel width for intrinsic device */
double llength = 2.0;	/* default channel length for low-power device */
double lwidth = 2.0;	/* default channel width for low-power device */
double plength = 2.0;	/* default channel length for p-channel device */
double pwidth = 2.0;	/* default channel width for p-channel device */
double dlength = 8.0;	/* default channel length for depletion device */
double dwidth = 2.0;	/* default channel width for depletion device */

char buff[1000];	/* buffer for temporary string generation */
char *bptr;		/* pointer to next free slot in buff */
int _internal = 0;	/* used for gensyming internal node names */
object strobj;		/* set to symbol "-struct-" */
object macobj;		/* set to symbol "macro" */
object locobj;		/* set to symbol "local" */
object eofobj;		/* set to what read returns on end of file */

FILE *ifile,*ofile;	/* current input and output files */

extern int lineno;	/* current line number */
char *inname;		/* name of current input file */
char *calls[MAXCALL];	/* stack of names of pending macro calls */
int cindex = 0;		/* index into calls[] */
char nflag = 0;		/* <>0 -> don't output warnings for undefined signals */

object expand(),eval();

struct trans {		/* transistor structure */
  char *tg,*ts,*td;	/* names of gate, source, and drain */
  double tl,tw;		/* length and width */
  char ttype;		/* type of transistor */
};

/* make a temporary copy of an asciz string in free storage */
char *tmpstring(p)
  register char *p;
  {	register char *q = p;
	register char *ans;

	while (*q++);
	ans = q = (char *)malloc(q - p);
	while (*q++ = *p++);
	return(ans);
}

/* output transistor to network file */
outtrans(t)
  register struct trans *t;
  {	fprintf(ofile,"%c %s %s %s %4.2f %4.2f",
		t->ttype,t->tg,t->ts,t->td,t->tl,t->tw);
	if (t->ttype != 'b') fprintf(ofile, " 0 0");
	fprintf(ofile,"\n");
}

/* return node name */
char *nodename(n)
  object n;
  {	register char *ans = bptr;
	register symbol *s;

	if (n == NULL) return(NULL);
	switch (TYPE(n)) {
	  case STRING:	return((char *)ADDR(n));

	  case FIXNUM:	sprintf(bptr,"%d",SVALUE(n));
			while (*bptr++);
			return(ans);

	  case SYMBOL:	s = (symbol *)ADDR(n);
			return((char *)ADDR(s->sym_pname));

	  default:	*bptr++ = '?';
			*bptr++ = 0;
			return(ans);
	}
}


/* return number of CONS's in list passed as arg */
int length(list)
  object list;
  {	register cons *l = (struct Cons *)ADDR(list);
	register int i = 0;

        /* second half of && is a hack -- why is it segmentation
           faulting here? (Tim 8/9/92) */

	while ((l != (cons *)ADDR(nil)) && (l != NULL)) {
	  i++;
	  l = (cons *)ADDR(l->cdr);
	}
	return(i);
}

object lambda_exp(),ev_list();

/* evaluator is simpleminded:
 *	FIXNUM, STRING, ..., and SUBR are self-evaluating
 *	SYMBOL evaluates to contents of sym_value cell (if NULL, then error)
 *	CONS examines the car as possible operator:
 *	  if operator is a SYMBOL
 *	    if sym_function cell is not null, apply it to cdr
 *	    if sym_value cell is not null, pretend it was operator
 *	  if operator is a CONS
 *	    if car of operator is 'lambda, apply lambda exp to cdr
 *	    eval operator and use answer as new operator
 *	  if operator is a SUBR, apply it to cdr
 *	  complain about ;illegal function object
 *	otherwise complain about ;bad arg to eval
 */
object eval(arg)
  object arg;
  {	register symbol *s;
	register cons *c;
	object operator,osave;
	object operands;
	object (*subr)();
	extern object t;

	if (arg==nil || arg==t) return(arg);

	switch (TYPE(arg)) {
	  default:	error(";bad arg to eval\n%S",arg);
			return(NULL);

	  case NODE:
	  case TRANS:
	  case FIXNUM:
	  case FLONUM:
	  case STRING:
	  case SUBR:	return(arg);

	  case SYMBOL:	s = (symbol *)ADDR(arg);
			if (s->sym_value != NULL) return(s->sym_value);
			if (!nflag) error("use of undeclared name: %S",arg);
			return(arg);

	  case CONS:	c = (cons *)ADDR(arg);
			operator = c->car;
			operands = c->cdr;
	  		while (1) switch (TYPE(operator)) {
			  default:
			  badoper:	error(";illegal function object\n%S",operator);
					return(NULL);

			  case SUBR:	subr = (object (*)())ADDR(operator);
					return((*subr)(operands));

			  case SYMBOL:	s = (symbol *)ADDR(operator);
					osave = operator;
					if ((operator = s->sym_value) != NULL) { 
					    if (operator == osave) {
						error("macro name used as node name?\n%S", operator);
						return(NULL);
                                            }
					    continue;
					}
					if ((operator = s->sym_function) != NULL) continue;
					operator = osave;
					goto badoper;

			  case CONS:	if (operator == nil) goto badoper;
					c = (cons *)ADDR(operator);
					if (c->car == intern("lambda"))
					  return(lambda_exp(operator,operands));
					if (c->car == intern("macro"))
					  return(expand(operator,operands));
					push(operands);
					operator = eval(operator);
					pop(1);
					continue;
			}
	}
}

/* apply lambda expression to arguments */
object lambda_exp(operator,operands)
  object operator,operands;
  {	register cons *c;
	register int i;
	object bvl,body,param,arg,result;
	int argcount = 0;

	/* protect operands and lambda exp from gc */
	push(operands);
	push(operator);
	result = NULL;

	/* get pointers to bvl, body, and operand list */
	body = ((cons *)ADDR(operator))->cdr;
	if (!ISCONS(body)) goto badlambda;
	c = (cons *)ADDR(body);
	body = c->cdr;
	bvl = c->car;
	if (!ISCONS(body)) goto badlambda;

	/* run down bvl evaling args, saving results for later binding */
	while (ISCONS(bvl) && bvl!=nil) {
	  c = (cons *)ADDR(bvl);
	  bvl = c->cdr;
	  param = c->car;
	  if (!ISSYMBOL(param) || !ISCONS(operands)) goto badlambda;
	  if (operands == nil) goto badargcnt;
	  c = (cons *)ADDR(operands);
	  operands = c->cdr;
	  if ((arg = eval(c->car)) == NULL) goto unwind;
	  push(param);
	  push(arg);
	  argcount++;
	}

	/* make sure number of args and params match */
	if (bvl != nil) goto badlambda;
	if (operands != nil) goto badargcnt;

	/* do binding for all the args */
	bind(argcount);

	/* evaluate body saving answer for later */
	result = ev_list(body);

	/* undo all the bindings, pop args from stack and return */
	bind(argcount);
  unwind:
	pop((2*argcount)+2);
	return(result);

  badlambda:
	error(";syntax error in lambda expression or combination\n%S",operator);
	goto unwind;

  badargcnt:
	error(";wrong number of args for lambda expression\n%S",operator);
	goto unwind;
}

/* do bindings for specified number of <value,symbol> pairs found on stack */
bind(cnt)
  register int cnt;
  {	register symbol *s;
	object temp;

	if (cnt <= 0) return;
	while (cnt--) {
	  temp = nth_stack(2*cnt + 1);
	  s = (symbol *)ADDR(temp);
	  s->sym_value = nth_exch(2*cnt,s->sym_value);
	}
}

/* evaluate each form in a list of forms, returning value of last one */
object ev_list(list)
  object list;
  {	register cons *c;
	object last = nil;

	push(list);
	while (ISCONS(list)) {
	  if (list == nil) { pop(1); return(last); }
	  c = (cons *)ADDR(list);
	  list = c->cdr;
	  if ((last = eval(c->car)) == NULL) { pop(1); return(NULL); }
	}
	error(";syntax error in form list\n");
	pop(1);
	return(NULL);
}

/* macro expansion */
object expand(macro,args)
  object macro,args;
  {	register cons *c,*d;
	register symbol *s;
	register int i;
	object obj;
	symbol *name;
	cons *body,*bvl;
	int len;
	char *errmsg = "syntax error in macro call";

	bptr = buff;
	c = (cons *)ADDR(macro);
	if (c==(cons *)ADDR(nil) || c->car!=macobj)
	  { error("bad macro definition: %S",macro); return(macro); }

	c = (cons *)ADDR(c->cdr);
	if (c==(cons *)ADDR(nil)) { error("%s: %S",errmsg,macro); return(macro); }
	name = (symbol *)ADDR(c->car);

	calls[cindex++] = (char *)ADDR(name->sym_pname);
	if (cindex == MAXCALL) {
	  cindex--;
	  error("warning: excessive macro call nesting (infinite recursion?)\n");
	}

	c = (cons *)ADDR(c->cdr);
	if (c==(cons *)ADDR(nil) || (len = length(args))!=length(c->car))
	  { errmsg = "wrong number of args"; goto err; }
	bvl = (cons *)ADDR(c->car);

	body = (cons *)ADDR(c->cdr);

	/* add alist cells for each parameter to stack */
	i = len;
	c = bvl;
	d = (cons *)ADDR(args);
	while (i--) {
	  if ((obj = eval(d->car)) == NULL) obj = nil;
	  if (TYPE(obj) == STRING) SETVALUE(obj,tmpstring((char *)ADDR(obj)));
	  push(obj);
	  push(c->car);
	  c = (cons *)ADDR(c->cdr);
	  d = (cons *)ADDR(d->cdr);
	}

	/* do local symbol processing */
	c = (cons *)ADDR(body->car);
	if (c->car == locobj) {
	  body = (cons *)ADDR(body->cdr);
	  c = (cons *)ADDR(c->cdr);
	  while (c != (cons *)ADDR(nil)) {
	    if (TYPE(c->car)!=SYMBOL) {
	      error("bad local symbol name in macro: %S",c->car);
	      goto next;
	    }
	    SETTYPE(obj,FIXNUM);
	    SETVALUE(obj,++_internal);
	    push(obj);
	    len++;
	    push(c->car);
      next: c = (cons *)ADDR(c->cdr);
	  }
	}

	/* do binding */
	i = 2*len;
	while (i) {
	  i = i-2;
	  obj = nth_stack(i);
	  s = (symbol *)ADDR(obj);
	  s->sym_value = nth_exch(i+1,s->sym_value);
	}
	c = body;
	while (c != (cons *)ADDR(nil)) {
	  eval(c->car);
	  c = (cons *)ADDR(c->cdr);
	}

	/* undo bindings */
	i = len;
	while (i--) {
	  obj = pop(1);
	  s = (symbol *)ADDR(obj);
	  if (TYPE(s->sym_value) == STRING) free((char *)ADDR(s->sym_value));
	  s->sym_value = pop(1);
	}
	cindex--;
	return(macro);

err:	error("%s in macro call to %s: %S",errmsg,name->sym_pname,args);
	cindex--;
	return(macro);
}

object _sname(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	register char *p,*q;
	char *result;

	result = p = bptr;
	while (c != (cons *)ADDR(nil)) {
	  if ((args = eval(c->car)) == NULL) args = nil;
	  switch (TYPE(args)) {
	    case FIXNUM:	sprintf(p,"%d",VALUE(args));
				while (*p++);
				--p;
				break;

	    case STRING:	q = (char *)ADDR(args);
				goto copy;

	    case SYMBOL:	q = (char *)ADDR(((symbol *)ADDR(args))->sym_pname);
	    copy:		while (*p++ = *q++);
				--p;
				if (*(p-1) == '!') { --p; goto done; }
				break;

	    default:		*p++ = '?';
				break;
	  }
	  if ((c = (cons *)ADDR(c->cdr)) != (cons *)ADDR(nil)) *p++ = '.';
	}
done:	*p++ = 0;
	bptr = p;
	SETTYPE(args,STRING);
	SETVALUE(args,result);
	return(args);
}

trans(args,type,l,w)
  object args;
  char type;
  double l,w;
  {	struct trans t;

	bptr = buff;
	t.ttype = type;
	t.tl = l;
	t.tw = w;

	push(args);
	if ((t.tg = nodename(ev_next(0,"trans",1,0))) == NULL) return(NULL);
	if ((t.ts = nodename(ev_next(0,"trans",1,0))) == NULL) return(NULL);
	if ((t.td = nodename(ev_next(0,"trans",1,0))) == NULL) return(NULL);
	if (nth_stack(0) != nil) {
	  if ((args = ev_next(0,"trans",1,0)) == NULL) return(NULL);
	  if (ISFIX(args)) {
	    if (oldfmt) t.tl = VALUE(args);
	    else t.tw = VALUE(args);
	  } else if (ISFLOAT(args)) {
	    if (oldfmt) t.tl = ((flonum *)ADDR(args))->flo_value;
	    else t.tw = ((flonum *)ADDR(args))->flo_value;
	  } else goto err;
	  if (nth_stack(0) != nil) {
	    if ((args = ev_next(0,"trans",1,1)) == NULL) return(NULL);
	    if (ISFIX(args)) {
	      if (oldfmt) t.tw = VALUE(args);
	      else t.tl = VALUE(args);
	    } else if (ISFLOAT(args)) {
	      if (oldfmt) t.tw = ((flonum *)ADDR(args))->flo_value;
	      else t.tl = ((flonum *)ADDR(args))->flo_value;
	    } else goto err;
	    goto out;
	  }
	}
	pop(1);

out:	outtrans(&t);
	return(nil);

err:	error("bad length/width in trans\n");
	return(nil);
}

object _btrans(args)
  object args;
  {	trans(args,'b',elength,ewidth);
	return(args);
}

object _etrans(args)
  object args;
  {	trans(args,'e',elength,ewidth);
	return(args);
}

object _ntrans(args)
  object args;
  {	trans(args,'n',elength,ewidth);
	return(args);
}

object _itrans(args)
  object args;
  {	trans(args,'i',elength,ewidth);
	return(args);
}

object _ltrans(args)
  object args;
  {	trans(args,'l',elength,ewidth);
	return(args);
}

object _ptrans(args)
  object args;
  {	trans(args,'p',plength,pwidth);
	return(args);
}

object _dtrans(args)
  object args;
  {	trans(args,'d',dlength,dwidth);
	return(args);
}

fixup(t,obj,type,l,w)
  register struct trans *t;
  object obj;
  char type;
  double l,w;
  {	register cons *c = (struct Cons *)ADDR(obj);

	t->ttype = type;
	t->tl = l;
	t->tw = w;
	if (TYPE(obj)==CONS && c->car!=strobj) {
	  t->tg = nodename(eval(c->car));
	  c = (cons *)ADDR(c->cdr);
	  if (c != (cons *)ADDR(nil)) {
	    obj = eval(c->car);
	    if (ISFIX(obj)) {
	      if (oldfmt) t->tl = VALUE(obj);
	      else t->tw = VALUE(obj);
	    } else if (ISFLOAT(obj)) {
	      if (oldfmt) t->tl = ((flonum *)ADDR(obj))->flo_value;
	      else t->tw = ((flonum *)ADDR(obj))->flo_value;
	    } else goto err;
	    c = (cons *)ADDR(c->cdr);
	    if (c != (cons *)ADDR(nil)) {
	      obj = eval(c->car);
	      if (ISFIX(obj)) {
	        if (oldfmt) t->tw = VALUE(obj);
	        else t->tl = VALUE(obj);
	      } else if (ISFLOAT(obj)) {
	        if (oldfmt) t->tw = ((flonum *)ADDR(obj))->flo_value;
	        else t->tl = ((flonum *)ADDR(obj))->flo_value;
	      } else goto err;
	    }
	  }
	} else t->tg = nodename(eval(obj));
	if (t->tg == NULL) t->tg = "???";
	return;

err:	error("bad length/width in fixup\n");
}

object _pup(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	struct trans t;

	bptr = buff;
	if (c == (cons *)ADDR(nil)) goto err;
	fixup(&t,c->car,'d',dlength,dwidth);
	t.ts = t.tg;
	t.td = "vdd";
	outtrans(&t);
	return(args);

err:	error("bad argument to pullup: %S",args);
	return(args);
}

pulldown(top,c)
  char *top;
  register cons *c;
  {	struct trans t;

	while (c != (cons *)ADDR(nil)) {
	  t.td = top;
	  fixup(&t,c->car,'e',elength,ewidth);
	  c = (cons *)ADDR(c->cdr);
	  if (c == (cons *)ADDR(nil)) t.ts = "gnd";
	  else {
	    t.ts = bptr;
	    sprintf(bptr,"%d",++_internal);
	    while(*bptr++);
	  }
	  outtrans(&t);
	  top = t.ts;
	}
}

object _pdown(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	char *top;

	bptr = buff;
	if (c == (cons *)ADDR(nil)) goto err;
	if ((top = nodename(eval(c->car))) == NULL) top = "???";
	c = (cons *)ADDR(c->cdr);
	pulldown(top,c);
	return(args);

err:	error("bad argument to pulldown: %S",args);
	return(args);
}

object _nand(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	struct trans t;

	bptr = buff;
	if (c == (cons *)ADDR(nil)) goto err;
	fixup(&t,c->car,'d',dlength,dwidth);
	t.ts = t.tg;
	t.td = "vdd";
	outtrans(&t);
	pulldown(t.ts,(cons *)ADDR(c->cdr));
	return(args);

err:	error("bad argument to invert or nand: %S",args);
	return(args);
}

object _nor(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	struct trans t;
	char *top;

	bptr = buff;
	if (c == (cons *)ADDR(nil)) goto err;
	fixup(&t,c->car,'d',dlength,dwidth);
	top = t.ts = t.tg;
	t.td = "vdd";
	outtrans(&t);
	c = (cons *)ADDR(c->cdr);
	while (c != (cons *)ADDR(nil)) {
	  fixup(&t,c->car,'e',elength,ewidth);
	  t.td = top;
	  t.ts = "gnd";
	  outtrans(&t);
	  c = (cons *)ADDR(c->cdr);
	}
	return(args);

err:	error("bad argument to nor: %S",args);
	return(args);
}

object _aoi(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	struct trans t;

	bptr = buff;
	if (c == (cons *)ADDR(nil)) goto err;
	fixup(&t,c->car,'d',dlength,dwidth);
	t.ts = t.tg;
	t.td = "vdd";
	outtrans(&t);
	c = (cons *)ADDR(c->cdr);
	while (c != (cons *)ADDR(nil)) {
	  pulldown(t.ts,(cons *)ADDR(c->car));
	  c = (cons *)ADDR(c->cdr);
	}
	return(args);

err:	error("bad argument to and-or-invert: %S",args);
	return(args);
}

object _repeat(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	register symbol *index;
	cons *body;
	symbol *s;
	int low,high,i,len;
	object oindex,obj;
	char *errmsg = "syntax error in repeat statement";

	/* get pointer to index variable */
	if (c == (cons *)ADDR(nil)) goto err;
	if (TYPE(c->car) != SYMBOL) { errmsg = "repeat index not a symbol"; goto err; }
	index = (symbol *)ADDR(c->car);
	c = (cons *)ADDR(c->cdr);

	/* get low index */
	if (c == (cons *)ADDR(nil)) goto err;
	args = eval(c->car);
	if (TYPE(args) != FIXNUM) { errmsg = "low index of repeat not a fixnum"; goto err; }
	low = SVALUE(args);
	c = (cons *)ADDR(c->cdr);

	/* get high index */
	if (c == (cons *)ADDR(nil)) goto err;
	args = eval(c->car);
	if (TYPE(args) != FIXNUM) { errmsg = "high index of repeat not a fixnum"; goto err; }
	high = SVALUE(args);
	c = (cons *)ADDR(c->cdr);
	body = c;

	/* do local symbol processing -- save old values on stack */
	len = 0;
	c = (cons *)ADDR(c->car);
	if (c->car == locobj) {
	  body = (cons *)ADDR(body->cdr);
	  c = (cons *)ADDR(c->cdr);
	  while (c != (cons *)ADDR(nil)) {
	    if (TYPE(c->car)!=SYMBOL) {
	      error("bad local symbol name in repeat: %S",c->car);
	      goto next;
	    }
	    s = (symbol *)ADDR(c->car);
	    push(s->sym_value);
	    SETTYPE(s->sym_value,FIXNUM);
	    push(c->car);
      next: c = (cons *)ADDR(c->cdr);
	  }
	}

	/* save old value of index, and initialize to low value */
	oindex = index->sym_value;
	SETTYPE(index->sym_value,FIXNUM);
	SETVALUE(index->sym_value,low);
	
	/* expand body, statement by statement for each index value */
	while (1) {
	  /* get new values for locals var for this iteration */
	  i = 2*len;
	  while (i) {
	    i = i-2;
	    obj = nth_stack(i);
	    s = (symbol *)ADDR(obj);
	    SETVALUE(s->sym_value,++_internal);
	  }

	  c = body;
	  while (c != (cons *)ADDR(nil)) { eval(c->car); c = (cons *)ADDR(c->cdr); }
	  if (low < high) {
	    SETVALUE(index->sym_value,SVALUE(index->sym_value) + 1);
	    if (SVALUE(index->sym_value) > high) break;
	  } else {
	    SETVALUE(index->sym_value,SVALUE(index->sym_value) - 1);
	    if (SVALUE(index->sym_value) < high) break;
	  }
	}

	/* undo bindings */
	while (len--) {
	  obj = pop(1);
	  s = (symbol *)ADDR(c->car);
	  s->sym_value = pop(1);
	}

	index->sym_value = oindex;
	return(args);

err:	error("%s: %S",errmsg,args);
	return(args);
}

/* (node a b c ...) declare identifier to be a node */
object _node(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);

	/* define each symbol on the list to have itself as its value */
	while (c != (cons *)ADDR(nil)) {
	  if (TYPE(c->car)!=SYMBOL) error("bad symbol name in node: %S",c->car);
	  else ((symbol *)ADDR(c->car))->sym_value = c->car;
	  c = (cons *)ADDR(c->cdr);
	}

	return(args);
}

object _macro(args)
  object args;
  {	register cons *c = (struct Cons *)ADDR(args);
	register cons *m;
	register symbol *s;
	char *errmsg = "syntax error in macro definition";

	/* get pointer to macro name */
	if (c == (cons *)ADDR(nil)) goto err;
	if (TYPE(c->car) != SYMBOL) { errmsg = "macro name not a symbol"; goto err; }
	s = (symbol *)ADDR(c->car);
	if (s->sym_function != NULL)
	  error("Warning -- redefinition of built-in function %s\n",ADDR(s->sym_pname));
	s->sym_value = al_obj(CONS);
	m = (cons *)ADDR(s->sym_value);
	m->car = macobj;
	m->cdr = args;

	/* see if bvl is really there */
	c = (cons *)ADDR(c->cdr);
	if (TYPE(c->car) != CONS) { errmsg = "parameter declaration missing"; goto err; }
	return(args);

err:	error("%s: %S",errmsg,args);
	return(args);
}

object _conn(args)
  object args;
  {	register char *name;

	bptr = buff;
	push(args);
	putc('=',ofile);
	while (nth_stack(0) != nil) {
	  if ((name = nodename(ev_next(0,"connect",1,0))) == NULL) goto done;
	  fprintf(ofile," %s",name);
	}
	pop(1);
 done:	putc('\n',ofile);
	return(nil);
}

/* output capacitance record for node */
object _cap(args)
  object args;
  {	register char *name;

	bptr = buff;
	push(args);
	if ((name = nodename(ev_next(0,"capacitance",1,0))) == NULL) return(NULL);
	if ((args = ev_next(0,"capacitance",1,1)) == NULL) return(NULL);
	if (TYPE(args) == FIXNUM)
	  fprintf(ofile,"c %s %d\n",name,SVALUE(args));
	else if (TYPE(args) == FLONUM)
	  fprintf(ofile,"c %s %e\n",name,((flonum *)ADDR(args))->flo_value);
	else error("bad argument(s) to capacitance: %S",args);

	return(nil);
}	

/* output explicit capacitor record */
object _cap2(args)
  object args;
  {	register char *s, *d;

	bptr = buff;
	push(args);
	if ((s = nodename(ev_next(0,"capacitor",1,0))) == NULL) return(NULL);
	if ((d = nodename(ev_next(0,"capacitor",1,0))) == NULL) return(NULL);
	if ((args = ev_next(0,"capacitor",1,1)) == NULL) return(NULL);
	if (TYPE(args) == FIXNUM)
	  fprintf(ofile,"C %s %s %d\n",s,d,SVALUE(args));
	else if (TYPE(args) == FLONUM)
	  fprintf(ofile,"C %s %s %e\n",s,d,((flonum *)ADDR(args))->flo_value);
	else error("bad argument(s) to capacitor: %S",args);
	
	return(nil);
}

/* output resistor record */
object _res(args)
  object args;
  {	register char *s,*d;

	bptr = buff;
	push(args);
	if ((s = nodename(ev_next(0,"resistor",1,0))) == NULL) return(NULL);
	if ((d = nodename(ev_next(0,"resistor",1,0))) == NULL) return(NULL);
	if ((args = ev_next(0,"resistor",1,1)) == NULL) return(NULL);
	if (TYPE(args) == FIXNUM)
	  fprintf(ofile,"r %s %s %d\n",s,d,SVALUE(args));
	else if (TYPE(args) == FLONUM)
	  fprintf(ofile,"r %s %s %e\n",s,d,((flonum *)ADDR(args))->flo_value);
	else error("bad argument(s) to resistor: %S",args);

	return(nil);
}	

object _thresh(args)
  object args;
  {	register char *name;
	double low,high;
	object obj;

	push(args);
	if ((name = nodename(ev_next(0,"threshold",1,0))) == NULL) return(NULL);
	if ((obj = ev_next(FLONUM,"threshold",1,0)) == NULL) return(NULL);
	low = ((flonum *)ADDR(obj))->flo_value;
	if (low<0 || low>1.0) goto badval;
	if ((obj = ev_next(FLONUM,"threshold",1,1)) == NULL) return(NULL);
	high = ((flonum *)ADDR(obj))->flo_value;
	if (high<0 || high>1.0) goto badval;

	fprintf(ofile,"t %s %f %f\n",name,low,high);
	return(args);

badval:	error("threshold not in the range [0,1]\n");
	return(NULL);
}

object _delay(args)
  object args;
  {	register char *name;
	int plh,phl;
	object obj;

	push(args);
	if ((name = nodename(ev_next(0,"delay",1,0))) == NULL) return(NULL);
	if ((obj = ev_next(FIXNUM,"delay",1,0)) == NULL) return(NULL);
	plh = VALUE(obj);
	if ((obj = ev_next(FIXNUM,"delay",1,1)) == NULL) return(NULL);
	phl = VALUE(obj);

	fprintf(ofile,"D %s %d %d\n",name,plh,phl);
	return(args);
}

object _include(args)
  object args;
  {	register int n;
	register cons *c = (struct Cons *)ADDR(args);
	char temp[100],*savename,*fname;
	int saveline;
	FILE *savefile;
	object obj;

	push(args);
	if ((fname = nodename(ev_next(0,"include",1,1))) == NULL) return(NULL);

	/* remember where we are */
	saveline = lineno;
	savename = inname;
	savefile = ifile;
	for (n = 0; n < cindex; n++) if (calls[n] == NULL) {
	  sprintf(temp,"[%s, line %d]",inname,lineno);
	  calls[n] = temp;
	  break;
	}

	if ((ifile = fopen(inname = fname,"r")) == NULL) {
	  error("cannot open include file %s\n",inname);
	  goto done;
	}
	lineno = 1;
	calls[cindex++] = NULL;
	while ((obj = obj_read(ifile,0)) != eofobj) {
	  push(obj);
	  eval(obj);
	  pop(1);
	}
	cindex--;
	fclose(ifile);

done:	lineno = saveline;
	ifile = savefile;
	inname = savename;
	calls[n] = NULL;
	return(args);
}

/* table of initializers */
struct subr_init { char *sname; object (*sfun)(); } stable[] = {
  "eval", _eval,
  "car", _car,
  "cdr", _cdr,
  "rplaca", _rcar,	/* added 890229 */
  "rplacd", _rcdr,	/* added 890229 */
  "cons", _cons,
  "list", _list,
  "memq", _memq,
  "cond", _cond,
  "prog", _prog,
  "defun", _defun,
  "do", _do,
  "load", _load,
  "print", _prnt,
  "prin1", _prn1,
  "princ", _prnc,
  "terpri", _terpri,
  "printf", _printf,
  "openi", _iopen,
  "openo", _oopen,
  "close", _lclose,
  "read", _rread,
  "quote", _quote,
  "+", _add,
  "-", _sub,
  "*", _mul,
  "/", _div,
  "%", _rem,
  "1+", _inc,
  "1-", _dec,
  "max", _max,
  "min", _min,
  "abs", _abs,
  "fix", _fix,
  "float", _float,
  "setq", _setq,
  "fset", _fset,
  "symeval", _symeval,
  "fsymeval", _fsymeval,
  "make-symbol", _msym,
/*  "-struct-", _ssym, */
  "<", _lt,
  "<=", _le,
  "==", _eqeq,
  "!=", _ne,
  ">=", _ge,
  ">", _gt,
  "and", _and,
  "or", _or,
  "not", _null,
  "null", _null,
  "eq", _eq,
  "equal", _equal,
  "atom", _atom,
  "numberp", _numberp,
  "stringp", _stringp,
  "trans", _etrans,
  "etrans", _etrans,
  "btrans", _btrans,
  "ntrans", _ntrans,
  "itrans", _itrans,
  "ltrans", _ltrans,
  "ptrans", _ptrans,
  "dtrans", _dtrans,
  "pullup", _pup,
  "pulldown", _pdown,
  "invert", _nand,
  "nor", _nor,
  "nand", _nand,
  "and-or-invert", _aoi,
  "repeat", _repeat,
  "macro", _macro,
  "-struct-", _sname,
  "connect", _conn,
  "node", _node,
  "capacitance", _cap,
  "capacitor", _cap2,
  "resistor", _res,
  "threshold", _thresh,
  "delay", _delay,
  "include", _include,
  0, 0
};

/* run through init table and set sym_function for each subr name */
i_subrs()
  {	register struct subr_init *p;
	register symbol *s;
	object sym;

	for (p = stable; p->sname; p++) {
	  sym = intern(p->sname);
	  s = (symbol *)ADDR(sym);
	  SETVALUE(s->sym_function,(p->sfun));
	  SETTYPE(s->sym_function,SUBR);
	}

	/* t is a symbol which evaluates to itself */
	t = intern("t");
	s = (symbol *)ADDR(t);
	s->sym_value = t;
}

main(argc,argv)
  char **argv;
  {	object obj;
	register int i,j,k;
	register char *p;

	ifile = stdin;
	calls[cindex++] = NULL;
	lineno = 1;
	inname = "tty";

	if (argc < 2) {
	  fprintf(stderr,"usage: net infile [outfile] [-s#] [-o] [-d#,#] [-e#,#] [-p#,#]\n");
	  exit(1);
	}

	if (argc>=2) {
	  if ((ifile = fopen(argv[1],"r")) == NULL) {
	    fprintf(stderr,"net: cannot open %s for input\n",argv[1]);
	    exit(1);
	  }
	  inname = argv[1];
	}

	ofile = stdout;
	if (argc>=3  && argv[2][0]!='-' && (ofile = WOPEN(argv[2])) == NULL) {
	    fprintf(stderr,"net: cannot open %s for output\n",argv[2]);
	    exit(1);
	}

	/* process remaining args */
	for (i = 2; i<argc; i++) {
	  if (argv[i][0] != '-') continue;
	  switch (argv[i][1]) {
	    default:	fprintf(stderr,"net: unrecognized argument ignored: %s\n",argv[i]);
			break;

	    case 's':	if ((_internal = atoi(&argv[i][2])) < 0) _internal = 0;
			break;

	    case 'o':	oldfmt = 1;
			break;

	    case 'n':	nflag = 1;
			break;

	    case 'e':	sscanf(&argv[i][2],"%f,%f",&ewidth,&elength);
			break;

	    case 'i':	sscanf(&argv[i][2],"%f,%f",&iwidth,&ilength);
			break;

	    case 'l':	sscanf(&argv[i][2],"%f,%f",&lwidth,&llength);
			break;

	    case 'p':	sscanf(&argv[i][2],"%f,%f",&pwidth,&plength);
			break;

	    case 'd':	sscanf(&argv[i][2],"%f,%f",&dwidth,&dlength);
			break;
	  }
	}

	i_storage();
	i_stack();
	i_symbol();
	i_subrs();

	eofobj = intern("end-of-file");
	strobj = intern("-struct-");
	macobj = intern("macro");
	locobj = intern("local");

	/* define vdd and gnd as the two nodes we always know about */
	obj = intern("vdd");
	((symbol *)ADDR(obj))->sym_value = obj;
	obj = intern("gnd");
	((symbol *)ADDR(obj))->sym_value = obj;

	while ((obj = obj_read(ifile,0)) != eofobj) {
	  push(obj);
	  eval(obj);
	  pop(1);
	}

	fclose(ofile);

	exit(0);	/* all done */
}

/* error handler */
error(format,firstarg)
  register char *format;
  {	register char ch;
	register int *ap = &firstarg;
	char *p;
	int n,col;
	object o;
	char temp[100];

	/* tell user where he is */
	for (n = 0, col = 0; n < cindex; n++) {
	  if ((p = calls[n]) == NULL) {
	    sprintf(temp,"[%s, line %d]",inname,lineno);
	    p = temp;
	  }
	  if (strlen(p) + col > 70) { putc('\n',stderr); col = 0; }
	  col += strlen(p) + 4;
	  fprintf(stderr,"%s -> ",p);
	}
	fprintf(stderr,"\n  ");

	/* now tell him what he did wrong */
#ifndef pdp10
	while (ch = *format++) {
	  if (ch != '%') putc(ch,stderr);
	  else switch (ch = *format++) {
	    case 's':	p = (char *)(*ap++);
			while (*p) putc(*p++,stderr);
			break;

	    case 'd':	n = *ap++;
			if (n < 0) { p_char('-'); n = -n; }
			fprintf(stderr,"%d",n);
			break;

	    case 'S':	o = *((object *)ap);
			ap += sizeof(object)/sizeof(*ap);
			obj_print(o,stderr,0);
			break;
	  }
	}
#endif
#ifdef pdp10
	while (ch = *format++) {
	  if (ch != '%') putc(ch,stderr);
	  else switch (ch = *format++) {
	    case 's':	p = (char *)(*ap); ap--;
			while (*p) putc(*p++,stderr);
			break;

	    case 'd':	n = *ap; ap--;
			if (n < 0) { p_char('-'); n = -n; }
			fprintf(stderr,"%d",n);
			break;

	    case 'S':	o = *((object *)ap); ap--;
			obj_print(o,stderr,0);
			break;
	  }
	}
#endif
}

/* dummy routine to keep print happy */
char pchars()
  {	return('?');
}