/**********************************************************************/
/*                                                                    */
/*	CRISP - Programmable editor                                   */
/*	===========================                                   */
/*                                                                    */
/*  File:          new.c                                              */
/*  Author:        P. D. Fox                                          */
/*  Created:       17 Apr 1991                     		      */
/*                                                                    */
/*  Copyright (c) 1990, 1991 Paul Fox                                 */
/*                All Rights Reserved.                                */
/*                                                                    */
/*                                                                    */
/*--------------------------------------------------------------------*/
/*  Description:  Code to handle lists.                               */
/*                                                                    */
/**********************************************************************/

/*static char sccs_id[] = "%Z% %M% %R%.%L%";*/
# include	"list.h"

int	copy_atom_seq PROTO((LIST *, LIST *));
static void	append_to_list PROTO((SYMBOL *, LISTV *, int));
void	replace_list_element PROTO((SYMBOL *, int, LISTV *));
int	atom_size PROTO((LIST *lp));
LIST	*next_atom PROTO((LIST *));
LIST	*next_linear_atom PROTO((LIST *));
int	length_of_list_in_bytes PROTO((LIST *));
void	free_list PROTO((LIST *));
LIST	*copy_list PROTO((LIST *, int));
int	copy_atom PROTO((LIST *, LIST *));
int	copy_argv_atom PROTO((LIST *, LISTV *));
void	file_glob PROTO((void));
static void	first_atom PROTO((LIST *));
static int	null_list PROTO((LIST *));
void	car PROTO((void));
void	cdr PROTO((void));
void	macro_list PROTO((void));

/**********************************************************************/
/*   Function to return the size of the current atom pointed to.      */
/**********************************************************************/
int
atom_size(lp)
LIST	*lp;
{
	if (*lp == F_LIST)
		return LGET16(lp);
	return sizeof_atoms[*lp];
}
/**********************************************************************/
/*   Function  to  return  pointer  to next atom in a list. If we're  */
/*   pointing to the F_HALT at the end of the list then stick there.  */
/**********************************************************************/
LIST *
next_atom(lp)
LIST	*lp;
{
	switch (*lp) {
	  case F_HALT:
		return lp;
	  case F_LIST:
	  	return lp + LGET16(lp);
	  default:
	  	return lp + sizeof_atoms[*lp];
	  }
}
/**********************************************************************/
/*   This  function  is  like  next_atom()  but returns a pointer to  */
/*   the  next  atom  in  a list, WITHOUT skipping over sub-lists in  */
/*   one jump.							      */
/**********************************************************************/
LIST *
next_linear_atom(lp)
LIST	*lp;
{
	if (*lp == F_HALT)
		return lp;
	return lp + sizeof_atoms[*lp];
}
/**********************************************************************/
/*   Function  to  append  a  list  to  the  end  of  a  symbol.  If  */
/*   acc_lvalue  is  TRUE  then  put  the lvalue in the accumulator,  */
/*   otherwise put the rvalue in the accumulator.		      */
/**********************************************************************/
static void
append_to_list(sp, lvp, acc_lvalue)
SYMBOL	*sp;
LISTV	*lvp;
int	acc_lvalue;
{	int	newlen;
	LIST	*new_list;
	ref_t	*rp;
	
	new_list = append_list((LIST *) sp->s_obj->r_ptr, 
		sp->s_obj->r_used, lvp, &newlen);
	/***********************************************/
	/*   Convert  list  into  a  reference  so we  */
	/*   can assign it two ways.		       */
	/***********************************************/
	rp = r_init(F_RLIST, (char *) new_list, newlen);
	/***********************************************/
	/*   Assign new list to symbol.		       */
	/***********************************************/
	ref_assign(sp, rp);
	if (acc_lvalue)
		acc_assign_ref(rp);
	else
		acc_assign_argv(lvp);
	/***********************************************/
	/*   Lose our local reference to it.	       */
	/***********************************************/
	r_dec(rp);
}
/**********************************************************************/
/*   Function  to  append  two  lists together -- one of which is an  */
/*   argument return new list and length of new list.		      */
/**********************************************************************/
LIST *
append_list(lp, len, lvp, lenp)
LIST	*lp;
int	len;
LISTV	*lvp;
int	*lenp;
{	int	n;
	int	len1;
	int	newlen;
	LIST	*new_list;
	LIST	*ptr = NULL;
	register LIST	*dst_lp, *src_lp;
	
	/***********************************************/
	/*   Work  out  how  much space is needed for  */
	/*   new list.				       */
	/***********************************************/
	if (len < 0)
		len = length_of_list_in_bytes(lp);
	/***********************************************/
	/*   Need  to  strip  off  outer  coating  of  */
	/*   lists.				       */
	/***********************************************/
	switch (lvp->l_flags) {
	  case F_LIST:
	  	ptr = lvp->l_list;
	  	len1 = length_of_list_in_bytes(ptr) - sizeof_atoms[F_HALT];
	  	break;
	  case F_RLIST:
	  	ptr = (LIST *) lvp->l_ref->r_ptr;
		len1 = lvp->l_ref->r_used - sizeof_atoms[F_HALT];
	  	break;
	  default:
		len1 = sizeof_atoms[lvp->l_flags];
		break;
	  }
	newlen = len + len1;
	new_list = (LIST *) chk_alloc(newlen);
	if (new_list == NULL)
		return NULL;
	
	/***********************************************/
	/*   First take a copy of the old list.	       */
	/***********************************************/
	dst_lp = new_list;
	if (lp) {
		src_lp = lp;
		while (*src_lp != F_HALT) {
			n = copy_atom(dst_lp, src_lp);
			dst_lp += n;
			src_lp += n;
			}
		}
		
	/***********************************************/
	/*   Append  the  argument  and terminate the  */
	/*   list.				       */
	/***********************************************/
	switch (lvp->l_flags) {
	  case F_RLIST:
	  case F_LIST:
	  	n = copy_atom_seq(dst_lp, ptr);
		break;
	  default:
		n = copy_argv_atom(dst_lp, lvp);
		break;
	  }
	dst_lp[n] = F_HALT;

	*lenp = newlen;
	return new_list;
}
/**********************************************************************/
/*   Function  to  copy  a  list to another list, but do not include  */
/*   the terminating F_HALT.					      */
/**********************************************************************/
int
copy_atom_seq(dst_lp, src_lp)
register LIST	*dst_lp;
register LIST	*src_lp;
{
	LIST	*start = dst_lp;
	register int n;
	
	while (*src_lp != F_HALT) {
		n = copy_atom(dst_lp, src_lp);
		dst_lp += n;
		src_lp += n;
		}
	return dst_lp - start;
}
/**********************************************************************/
/*   Function  to  assign a new value to a list element in a symbol.  */
/*   If  the  place  to  assign doesn't currently exist (i.e. beyond  */
/*   the  end  of  the  list),  then tack it on the end. May need to  */
/*   fill in with F_NULLs ?					      */
/**********************************************************************/
void
replace_list_element(sp, n, lvp)
SYMBOL	*sp;
int	n;
LISTV	*lvp;
{	int	len_sp;
	int	len_lp;
	int	i;
	LIST	*ptr;
	register LIST	*lp1, *lp2;
	register LIST *lp = (LIST *) sp->s_obj->r_ptr;
	LIST	*new_list;
	int	new_len;
			
	/***********************************************/
	/*   Try  and  find  the  nth  element in the  */
	/*   list.				       */
	/***********************************************/
	for (i = 0; i < n && *lp != F_HALT; i++) {
		switch (*lp) {
		  case F_HALT:
			break;
	  	  case F_LIST:
	  		lp += LGET16(lp);
			break;
		  default:
		  	lp += sizeof_atoms[*lp];
			break;
		  }
		}
	/***********************************************/
	/*   If  index  is  beyond  end  of list then  */
	/*   tack it on the end.		       */
	/***********************************************/
	if (*lp == F_HALT) {
		append_to_list(sp, lvp, FALSE);
		return;
		}
	/***********************************************/
	/*   If   atom   we're   assigning  is  of  a  */
	/*   similar    size   to   the   one   we're  */
	/*   replacing  then  avoid  creating  a  new  */
	/*   list.  Also  need  to  make  sure no-one  */
	/*   else is pointing to it.		       */
	/***********************************************/
	if (sp->s_obj->r_ref == 1 && *lp == lvp->l_flags && *lp != F_LIST) {
		switch (*lp) {
		  case F_INT:
		  	LPUT32(lp, lvp->l_int);
			acc_assign_int(lvp->l_int);
			return;
		  case F_FLOAT:
		  	LPUT_FLOAT(lp, lvp->l_float);
			acc_assign_float(lvp->l_float);
			return;
		  }
		}
		
	/***********************************************/
	/*   Calculate lengths of two lists.	       */
	/***********************************************/
	len_sp = (lp - (LIST *) sp->s_obj->r_ptr) + length_of_list_in_bytes(lp);
	switch (lvp->l_flags) {
	  case F_LIST:
	  	ptr = lvp->l_list;
	  	len_lp = length_of_list_in_bytes(ptr) - sizeof_atoms[F_HALT];
	  	break;
	  case F_RLIST:
	  	ptr = (LIST *) lvp->l_ref->r_ptr;
		len_lp = lvp->l_ref->r_used - sizeof_atoms[F_HALT];
	  	break;
	  default:
		len_lp = sizeof_atoms[lvp->l_flags];
		ptr = NULL;
		break;
	  }
	
	/***********************************************/
	/*   Allocate memory for the new list.	       */
	/***********************************************/
	new_len = len_sp - atom_size(lp) + len_lp;
	new_list = (LIST *) chk_alloc(new_len);
	if (new_list == NULL)
		return;
		
	/***********************************************/
	/*   Now  copy  in  the  bit  before the atom  */
	/*   we're replacing.			       */
	/***********************************************/
	lp1 = new_list;
	lp2 = (LIST *) sp->s_obj->r_ptr;
	while (lp2 != lp) {
		i = copy_atom(lp1, lp2);
		lp1 += i;
		lp2 += i;
		}
	/***********************************************/
	/*   Now copy in the new element.	       */
	/***********************************************/
	switch (lvp->l_flags) {
	  case F_RLIST:
	  case F_LIST:
	  	lp1 += copy_atom_seq(lp1, ptr);
		break;
	  default:
		lp1 += copy_argv_atom(lp1, lvp);
		break;
	  }
	
	/***********************************************/
	/*   Now  copy  in  the  bit  after  the  new  */
	/*   element.				       */
	/***********************************************/
	lp2 += atom_size(lp2);
	while (*lp2 != F_HALT) {
		i = copy_atom(lp1, lp2);
		lp1 += i;
		lp2 += i;
		}
	*lp1 = F_HALT;

	/***********************************************/
	/*   Assign new list to symbol.		       */
	/***********************************************/
	list_assign(sp, new_list, new_len);
	acc_assign_argv(lvp);
}
/**********************************************************************/
/*   Encapsulate arguments in a new list.			      */
/**********************************************************************/
void
make_list()
{
	LIST	*list;
	register int	i;
	register LIST *lp;
	int	l_len = 0;
	
	/***********************************************/
	/*   First  work  out  how  long  the list is  */
	/*   going to be.			       */
	/***********************************************/
	for (i = 1; i < argc; i++) {
		switch (argv[i].l_flags) {
		  case F_INT:
		  case F_FLOAT:
		  case F_LIT:
		  case F_STR:
		  case F_RSTR:
		  case F_NULL:
		  case F_RLIST:
		  	l_len += sizeof_atoms[argv[i].l_flags];
			break;
		  case F_LIST:
		  	l_len += sizeof_atoms[F_LIST]
				+ length_of_list_in_bytes(argv[i].l_list)
				+ sizeof_atoms[F_HALT];
			break;
		  default:
		  	panic("make_list: don't understand type.");
		  }
		}
		
	l_len += sizeof_atoms[F_HALT];
	/***********************************************/
	/*   Allocate memory for new list.	       */
	/***********************************************/
	list = (LIST *) chk_alloc(l_len);
	if (list == NULL) 
		return;
	lp = list;
	for (i = 1; i < argc; i++) {
		if (argv[i].l_flags == F_LIST) {
			*lp = F_LIST;
			LPUT16(lp, sizeof_atoms[F_LIST] + 
				length_of_list_in_bytes(argv[i].l_list));
			lp += sizeof_atoms[F_LIST];
			lp += copy_argv_atom(lp, &argv[i]);
			}
		else
			lp += copy_argv_atom(lp, &argv[i]);
		}
	*lp = F_HALT;
	acc_donate_list(list, l_len);
}
/**********************************************************************/
/*   Return the length of a list in allocated bytes.		      */
/**********************************************************************/
int
length_of_list_in_bytes(list)
LIST	*list;
{	register LIST *lp = list;

	if (lp == NULL)
		return 0;
	while (*lp != F_HALT) {
		if (*lp == F_LIST)
			lp += LGET16(lp);
		else
			lp += sizeof_atoms[*lp];
		}
	return lp - list + sizeof_atoms[F_HALT];
}
/**********************************************************************/
/*   Function  to  free  a list and any strings which are pointed to  */
/*   by the elements in a list.					      */
/**********************************************************************/
void
free_list(lp)
register LIST *lp;
{
	register LIST *lp1;

	for (lp1 = lp; lp1; lp1 = next_linear_atom(lp1)) {
		switch (*lp1) {
		  case F_RLIST:
		  case F_RSTR:
		  	r_dec((ref_t *) LGET32(lp1));
			break;
		  case F_HALT:
			chk_free((void *) lp);
			return;
		  }
		}
}
/**********************************************************************/
/*   This  function  creates a clone of a list including duplicating  */
/*   all the internal pointers and reference counts.		      */
/**********************************************************************/
LIST *
copy_list(list, extra)
LIST *list;
int	extra;
{	LIST	*new_list;
	LIST	*lp;
	int	list_len;

	list_len = length_of_list_in_bytes(list);

	if (list_len == 0)
		return NULL;

	new_list = (LIST *) chk_alloc(list_len + extra + 1);
	memcpy(new_list, list, list_len);
	new_list[list_len] = F_HALT;
	for (lp = new_list; lp; lp = next_linear_atom(lp)) {
		switch (*lp) {
		  case F_RLIST:
		  case F_RSTR:
			r_inc((ref_t *) LGET32(lp));
			break;
		  case F_HALT:
		  	return new_list;
		  }
		}
	return NULL;
}
/**********************************************************************/
/*   Copy  an  atom  from  one  list  to another list. Sub-lists are  */
/*   copied   over   as   a  single  atom.  Reference  counters  are  */
/*   incremented where necessary.				      */
/**********************************************************************/
int
copy_atom(lp, lp1)
LIST	*lp;
LIST	*lp1;
{	LIST	*start_lp;
	
	lp[0] = lp1[0];
	switch (*lp1) {
	  case F_INT:
	  case F_LIT:
	  	LPUT32(lp, LGET32(lp1));
		break;
	  case F_FLOAT: {
	  	double	d;
		LGET_FLOAT(lp1, &d);
	  	LPUT_FLOAT(lp, d);
	  	break;
		}
	  case F_STR: {
	  	char	*str = (char *) LGET32(lp1);
	  	lp[0] = F_RSTR;
	  	LPUT32(lp, (long) r_init(F_STR, str, strlen(str) + 1));
	  	break;
		}
	  case F_RLIST:
	  case F_RSTR:
	  	LPUT32(lp, (long) r_inc((ref_t *) LGET32(lp1)));
	  	break;
	  case F_ID:
	  	LPUT16(lp, LGET16(lp1));
		break;
	  case F_LIST: {
	  	int	n = atom_size(lp1);
		LIST	*end_lp;
		
		start_lp = lp;
		end_lp = lp1 + n;
	  	LPUT16(lp, LGET16(lp1));
		lp += sizeof_atoms[F_LIST];
		lp1 += sizeof_atoms[F_LIST];
		while (lp1 < end_lp) {
			int i = copy_atom(lp, lp1);
			lp += i;
			lp1 += i;
			}
		return lp - start_lp;
		}
	  case F_NULL:
	  case F_HALT:
	  	break;
	  default:
	  	panic("copy_atom");
	  }
	return sizeof_atoms[*lp];
}
/**********************************************************************/
/*   Copies an argument from the argv array to the destination list.  */
/**********************************************************************/
int
copy_argv_atom(lp, lvp)
LIST	*lp;
LISTV	*lvp;
{	LIST	*start_lp;
	
	lp[0] = (LIST) lvp->l_flags;
	switch ((int) lp[0]) {
	  case F_INT:
	  	LPUT32(lp, lvp->l_int);
		break;
	  case F_FLOAT:
	  	LPUT_FLOAT(lp, lvp->l_float);
	  	break;
	  case F_LIT:
	  	LPUT32(lp, (long) lvp->l_str);
		break;
	  case F_STR:
	  	lp[0] = F_RSTR;
	  	LPUT32(lp, (long) r_init(F_STR, lvp->l_str, strlen(lvp->l_str) + 1));
	  	break;
	  case F_RLIST:
	  case F_RSTR:
	  	LPUT32(lp, (long) r_inc(lvp->l_ref));
	  	break;
	  case F_LIST: {
		LIST	*lp1 = lvp->l_list;
	  	int	n = length_of_list_in_bytes(lp1);
		LIST	*end_lp;
		
		start_lp = lp;
		end_lp = lp1 + n;
		while (lp1 < end_lp) {
			int i = copy_atom(lp, lp1);
			lp += i;
			lp1 += i;
			}
		return lp - start_lp;
		}
	  case F_NULL:
	  case F_HALT:
	  	break;
	  default:
	  	panic("copy_argv_atom");
	  }
	return sizeof_atoms[*lp];
}
/**********************************************************************/
/*   Function  to  implement  filename globbing. We create a list of  */
/*   matching filenames.					      */
/**********************************************************************/
void
file_glob()
{	char	**files;
	LIST	*file_list;
	int	l_len;
	register LIST	*lp;
	int	num_files = 0;
	int	i;

	files = shell_expand(get_str(1));
	if (files) {
		for (i = 0; files[i]; i++)
			if (files[i][0])
				num_files++;
		}

	l_len = num_files * sizeof_atoms[F_RSTR] + 2;
	file_list = (LIST *) chk_alloc(l_len);
	if (file_list == NULL)
		return;
	lp = file_list;
	for (i = 0; files && files[i]; i++) {
		if (files[i][0]) {
			*lp = F_RSTR;
			LPUT32(lp, (long) r_init(F_STR, files[i], strlen(files[i]) + 1));
			lp += sizeof_atoms[F_RSTR];
			}
		chk_free((void *) files[i]);
		}
	*lp = F_HALT;
	acc_donate_list(file_list, l_len);
	if (files)
		chk_free((void *) files);
}
/**********************************************************************/
/*   Function to split a string into tokens and assign to a list.     */
/**********************************************************************/
void
split()
{	char	*str = get_str(1);
	char	*delims = get_str(2);
	int	numerics = argv[3].l_flags == F_INT && argv[3].l_int != 0;
	char	*cp1, *cp2;
	LIST	*res_list;
	LIST	*lp;
	int	num_strings = 0;
	int	l_len;
	int	ch;
		
	/***********************************************/
	/*   We  have  to  split  the  token  in  two  */
	/*   loops,  first  time we can calculate how  */
	/*   much  space  to  allocate  for list, and  */
	/*   second  time  we  can  actually  fill in  */
	/*   the list.				       */
	/***********************************************/
	for (cp1 = str; *cp1; cp1++) {
		/***********************************************/
		/*   Skip blanks before next token.	       */
		/***********************************************/
		while (*cp1 && strchr(delims, *cp1) != NULL)
			cp1++;
		if (*cp1 == NULL)
			break;
		/***********************************************/
		/*   Skip over this token.		       */
		/***********************************************/
		while (*cp1 && strchr(delims, *cp1) == NULL)
			cp1++;
		num_strings++;
		if (*cp1 == NULL)
			break;
		}
	/***********************************************/
	/*   Allocate memory the list.		       */
	/***********************************************/
	l_len = num_strings * sizeof_atoms[F_RSTR] + 2;
	res_list = (LIST *) chk_alloc(l_len);
	if (res_list == NULL)
		return;
		
	/***********************************************/
	/*   Now we can actually fill in the list.     */
	/***********************************************/
	for (lp = res_list, cp1 = str; *cp1; cp1++) {
		/***********************************************/
		/*   Skip blanks before next token.	       */
		/***********************************************/
		while (*cp1 && strchr(delims, *cp1) != NULL)
			cp1++;
		if (*cp1 == NULL)
			break;
		/***********************************************/
		/*   Remember where this word starts.	       */
		/***********************************************/
		cp2 = cp1;
		/***********************************************/
		/*   Skip over this token.		       */
		/***********************************************/
		while (*cp1 && strchr(delims, *cp1) == NULL)
			cp1++;
		if (numerics && (isdigit(*cp2) || *cp2 == '+' || *cp2 == '-')) {
			*lp = F_INT;
			LPUT32(lp, (long) atoi(cp2));
			}
		else {
			*lp = F_RSTR;
			if (*cp1 == NULL)
				LPUT32(lp, (long) r_init(F_STR, cp2, strlen(cp2) + 1));
			else {
				ch = *cp1;
				*cp1 = NULL;
				LPUT32(lp, (long) r_init(F_STR, cp2, strlen(cp2) + 1));
				*cp1 = ch;
				}
			}
		lp += sizeof_atoms[*lp];
		/***********************************************/
		/*   Check to see if we've finished.	       */
		/***********************************************/
		if (*cp1 == NULL)
			break;
		}
	/***********************************************/
	/*   Copy list to the accumulator.	       */
	/***********************************************/
	*lp = F_HALT;
	acc_donate_list(res_list, l_len);
}

/**********************************************************************/
/*   Primitive to return the nth element of a list.		      */
/**********************************************************************/
void
nth()
{	LIST *lp = get_list(2);
	int	n = argv[1].l_int;

	if (lp == NULL) {
		acc_assign_null();
		return;
		}
	while (n-- > 0 && *lp != F_HALT)
		lp = next_atom(lp);
	first_atom(lp);
}

/**********************************************************************/
/*   Function  to  return  the first atom in a list, i.e. copy it to  */
/*   the accumulator.						      */
/**********************************************************************/
static void
first_atom(lp)
register LIST *lp;
{	int	len;

	if (null_list(lp))
		return;
	switch (*lp) {
	  case F_INT:
		acc_assign_int(LGET32(lp));
		return;
	  case F_FLOAT: {
	  	double	dval;
		LGET_FLOAT(lp, &dval);
		acc_assign_float(dval);
	  	return;
		}
	  case F_STR:
	  case F_LIT: {
		char *cp = (char *) LGET32(lp);
		acc_assign_str(cp, -1);
		return;
		}
	  case F_ID:
		acc_assign_str(builtin[LGET16(lp)].name, -1);
		return;
	  case F_RSTR: {
		ref_t *rp = (ref_t *) LGET32(lp);
		acc_assign_str(rp->r_ptr, rp->r_used);
		return;
		}
	  case F_LIST: {
	  	LIST l;
		len = LGET16(lp) + 1;
		len -= sizeof_atoms[F_LIST];
		lp += sizeof_atoms[F_LIST];
		l = lp[len - 1];
		lp[len - 1] = F_HALT;
		acc_assign_list(lp, len);
		lp[len - 1] = l;
		return;
		}
	  case F_RLIST: {
	  	acc_assign_ref((ref_t *) LGET32(lp));
	  	return;
		}
	  case F_NULL:
	  	acc_assign_null();
		return;
	  default:
		errorf("car: empty list.");
		return;
	  }
}
/**********************************************************************/
/*   Function  to  check  to see whether list is blank. If so assign  */
/*   it to the accumulator.					      */
/**********************************************************************/
static int
null_list(lp)
register LIST *lp;
{
	if (lp && *lp != F_HALT)
		return FALSE;
	acc_assign_null();
	return TRUE;
}
/**********************************************************************/
/*   Primitive to return the first element of a list.		      */
/**********************************************************************/
void
car()
{
	first_atom(get_list(1));
}
/**********************************************************************/
/*   Function to return everything but the head of a list.	      */
/**********************************************************************/
void
cdr()
{	register LIST *lp = get_list(1);

	if (null_list(lp))
		return;
	lp = next_atom(lp);
	acc_assign_list(lp, length_of_list_in_bytes(lp));
}
/**********************************************************************/
/*   Return argument list unchanged and unevaluated.		      */
/**********************************************************************/
void
quote()
{
	acc_assign_list(argv[1].l_list, length_of_list_in_bytes(argv[1].l_list));
}
/**********************************************************************/
/*   Primitive  to  return  a list of all builtin primitives and the  */
/*   currently defined macros.					      */
/**********************************************************************/
void
command_list()
{	static LIST	*l_cmds = NULL;
	static int l_len;
	register LIST *lp;
	register BUILTIN *bp;
	extern int sizeof_builtin;
	extern int macro_cnt;
	int	c_index, m_index;
	int	len;
	char	**mac_list;
	char	**get_macro_list();
	char	**cpp;
	ref_t	*rp;
	
	l_len = (sizeof_builtin + macro_cnt) * sizeof_atoms[F_LIT] + 2;
	if ((l_cmds = (LIST *) chk_alloc(l_len)) == NULL) {
		acc_assign_int(-1L);
		return;
		}
	if ((mac_list = get_macro_list()) == NULL) {
		acc_assign_int(-1L);
		chk_free((void *) l_cmds);
		return;
		}
	lp = l_cmds;
	bp = builtin;
	cpp = mac_list;
	len = 0;
	c_index = m_index = 0;
	while (c_index < sizeof_builtin && m_index < macro_cnt) {
		int diff = strcmp(bp->name, *cpp);
		if (diff < 0) {
			*lp = F_LIT;
			LPUT32(lp, (long) bp->name);
			bp++, c_index++;
			}
		else if (diff == 0) {
			*lp = F_LIT;
			LPUT32(lp, (long) bp->name);
			cpp++, m_index++, bp++, c_index++;
			}
		else {
			*lp = F_LIT;
			LPUT32(lp, (long) *cpp);
			cpp++, m_index++;
			}
		lp += sizeof_atoms[*lp];
		len++;
		}
	while (c_index < sizeof_builtin) {
		*lp = F_LIT;
		LPUT32(lp, (long) bp->name);
		lp += sizeof_atoms[F_LIT];
		bp++, len++, c_index++;
		}
	while (m_index < macro_cnt) {
		*lp = F_LIT;
		LPUT32(lp, (long) *cpp);
		lp += sizeof_atoms[F_LIT];
		cpp++, len++, m_index++;
		}
	*lp = F_HALT;
	rp = r_init(F_RLIST, (char *) l_cmds, len * sizeof_atoms[F_LIT] + 2);
	acc_assign_ref(rp);
	r_dec(rp);
	chk_free((void *) mac_list);
	
}
static char **global_cp;
static void
mac_list2(sp, arg)
register SPBLK *sp;
void *arg;
{	MACRO *mp = (MACRO *) sp->data;
	*global_cp++ = mp->m_name;
}
char **
get_macro_list()
{	extern int macro_cnt;
	extern SPTREE *macro_tbl;
	char **mac_list;
	
	if ((mac_list = (char **) chk_alloc((macro_cnt + 1) * sizeof (char *))) == NULL)
		return NULL;
	global_cp = mac_list;
	spapply(macro_tbl, (int (*)()) mac_list2, (long) global_cp);
	return mac_list;
}
/**********************************************************************/
/*   The  following  function returns a list of all macros which are  */
/*   defined.							      */
/**********************************************************************/
void
macro_list()
{	LIST	*l_macs;
	int l_len;
	char	**mac_list;
	extern int macro_cnt;
	register int i;
	register LIST	*lp;
	ref_t	*rp;

	if ((mac_list = get_macro_list()) == NULL) {
		acc_assign_int(-1L);
		return;
		}
	l_len = macro_cnt * sizeof_atoms[F_LIT] + 2;
	if ((l_macs = (LIST *) chk_alloc(l_len)) == NULL) {
		acc_assign_int(-1L);
		chk_free((void *) mac_list);
		return;
		}
	lp = l_macs;
	for (i = 0; i < macro_cnt; i++) {
		*lp = F_LIT;
		LPUT32(lp, (long) mac_list[i]);
		lp += sizeof_atoms[F_LIT];
		}
	*lp = F_HALT;
	rp = r_init(F_RLIST, (char *) l_macs, l_len);
	acc_assign_ref(rp);
	r_dec(rp);
	chk_free((void *) mac_list);
}
/**********************************************************************/
/*   Primitive to return length of list in atoms.		      */
/**********************************************************************/
void
list_length()
{	register LIST	*lp = get_list(1);
	register long len = 0;
	
	if (lp) {
		while (*lp != F_HALT) {
			len++;
			if (*lp == F_LIST)
				lp += LGET16(lp);
			else
				lp += sizeof_atoms[*lp];
			}
		}
	acc_assign_int(len);
}
/**********************************************************************/
/*   Primitive to check the type of a polymorphic expression.	      */
/**********************************************************************/
void
is_type(type)
int	type;
{	SYMBOL	*sp = argv[1].l_sym;

	if (type == F_NULL && argv[1].l_flags == F_LIST) {
		LIST *lp = (LIST *) sp->s_obj->r_ptr;
		if (lp == NULL || lp[0] == F_HALT)
			acc_assign_int(1L);
		else
			acc_assign_int(0L);
		return;
		}
	acc_assign_int((long) (argv[1].l_flags == (long) type));
}

/**********************************************************************/
/*   Primitive to return the type of an expression.		      */
/**********************************************************************/
void
typeof()
{
	switch (argv[1].l_flags) {
	  case F_INT:
		acc_assign_str("integer", 7);
		break;
	  case F_FLOAT:
		acc_assign_str("float", 5);
		break;
	  case F_LIT:
	  case F_STR:
	  case F_RSTR:
		acc_assign_str("string", 6);
	  	break;
	  case F_NULL:
		acc_assign_str("NULL", 4);
	  	break;
	  case F_RLIST:
	  case F_LIST:
		acc_assign_str("list", 4);
		break;
	  default:
		acc_assign_str("unknown-type", 12);
		break;
	  }
	  	
}
/**********************************************************************/
/*   Primitive to modify an element in a list.			      */
/**********************************************************************/
void
put_nth()
{
	replace_list_element(argv[2].l_sym, 
		(int) argv[1].l_int,
		&argv[3]);
}
/**********************************************************************/
/*   Append an expression to the end of a list.			      */
/**********************************************************************/
void
append()
{
	append_to_list(argv[1].l_sym, &argv[2], TRUE);
}
