[unix-history] / usr / src / cmd / lisp / fex3.c

static char *sccsid = "@(#)fex3.c	34.2 10/13/80";

#include "global.h"
#include <vadvise.h>

/* chkarg ***************************************************************/
/* This insures that there are at least expnum arguments passed to the	*/
/* BCD function that calls this.  If there are fewer, nil arguments	*/
/* are pushed onto the name stack and np adjusted accordingly.		*/
#ifdef chkarg
#undef chkarg
#endif
chkarg(expnum,string)
int	expnum;			/* expected number of args	*/
char string[];
{
	register struct argent *work;
	register r10,r9,r8;
	register struct argent *lbot, *np;
	saveonly(1);

	for(work = np,np = lbot + expnum; work < np; )
		work++->val = nil;
}


/*
 *Ndumplisp -- create executable version of current state of this lisp.
 */
#include "a.out.h"

asm("	.globl	Dlast")
lispval
Ndumplisp()
{
	register struct exec *workp;
	register lispval argptr, temp;
	register char *fname;
	extern lispval reborn;
	struct exec work, old;
	extern etext;
	extern int dmpmode,holend,curhbeg,usehole;
	extern int end;
	int descrip, des2, count, ax,mode;
	char tbuf[BUFSIZ];
	snpand(4);


#ifndef UNIXTS
	vadvise(VA_ANOM);
#endif

	/* dump mode is kept in decimal (which looks like octal in dmpmode)
	   and is changeable via (sstatus dumpmode n) where n is 413 or 410
	   base 10		
	*/
	if(dmpmode == 413) mode = 0413;
	else mode = 0410;

	workp = &work;
	workp->a_magic	= mode;
	if(usehole)
		workp->a_text = curhbeg & (~PAGRND);
	else
	workp->a_text	= ((((unsigned) (&holend)) - 1) & (~PAGRND)) + PAGSIZ;
#ifndef VMS
	workp->a_data	= (unsigned) sbrk(0) - workp->a_text;
#else
	workp->a_data   = ((int)&end) - workp->a_text;
#endif
	workp->a_bss	= 0;
	workp->a_syms	= 0;
	workp->a_entry	= (unsigned) gstart();
	workp->a_trsize	= 0;
	workp->a_drsize	= 0;

	fname = "savedlisp"; /*set defaults*/
	reborn = CNIL;
	argptr = lbot->val;
	if (argptr != nil) {
		temp = argptr->d.car;
		if((TYPE(temp))==ATOM)
			fname = temp->a.pname;
	}
	des2 = open(gstab(),0);
	if(des2 >= 0) {
		if(read(des2,&old,sizeof(old))>=0)
			work.a_syms = old.a_syms;
	}
	descrip=creat(fname,0777); /*doit!*/
	if(-1==write(descrip,workp,sizeof(work)))
	{
		close(descrip);
		error("Dumplisp failed",FALSE);
	}
	if(mode == 0413) lseek(descrip,PAGSIZ,0); 
	if( -1==write(descrip,0,workp->a_text)    ||
	    -1==write(descrip,workp->a_text,workp->a_data) ) {
		close(descrip);
		error("Dumplisp failed",FALSE);
	}
	if(des2>0  && work.a_syms) {
		count = old.a_text + old.a_data + sizeof(old);
		if(-1==lseek(des2,count,0))
			error("Could not seek to stab",FALSE);
		asm("Dlast:");
		for(count = old.a_syms;count > 0; count -=BUFSIZ) {
			ax = read(des2,tbuf,BUFSIZ);
			if(ax==0) {
				printf("Unexpected end of syms",count);
				fflush(stdout);
				break;
			}
			if(ax >  0)
				write(descrip,tbuf,ax);
			else 
				error("Failure to write dumplisp stab",FALSE);
		}
	}
	close(descrip);
	if(des2>0) close(des2);
	reborn = 0;

#ifndef UNIXTS
	vadvise(VA_NORM);
#endif
	return(nil);
}

lispval
Nndumplisp()
{
	register struct exec *workp;
	register lispval argptr, temp;
	register char *fname;
	extern lispval reborn;
	struct exec work, old;
	extern etext;
	extern int dmpmode,holend,curhbeg,usehole;
	int descrip, des2, count, ax,mode;
	char tbuf[BUFSIZ];
	snpand(4);


#ifndef UNIXTS
	vadvise(VA_ANOM);
#endif

	/* dump mode is kept in decimal (which looks like octal in dmpmode)
	   and is changeable via (sstatus dumpmode n) where n is 413 or 410
	   base 10		
	*/
	if(dmpmode == 413) mode = 0413;
	else mode = 0410;

	workp = &work;
	workp->a_magic	= mode;
	if(usehole)
		workp->a_text = curhbeg & (~PAGRND);
	else
	workp->a_text	= ((((unsigned) (&holend)) - 1) & (~PAGRND)) + PAGSIZ;
	workp->a_data	= (unsigned) sbrk(0) - workp->a_text;
	workp->a_bss	= 0;
	workp->a_syms	= 0;
	workp->a_entry	= (unsigned) gstart();
	workp->a_trsize	= 0;
	workp->a_drsize	= 0;

	fname = "savedlisp"; /*set defaults*/
	reborn = CNIL;
	argptr = lbot->val;
	if (argptr != nil) {
		temp = argptr->d.car;
		if((TYPE(temp))==ATOM)
			fname = temp->a.pname;
	}
	des2 = open(gstab(),0);
	if(des2 >= 0) {
		if(read(des2,&old,sizeof(old))>=0)
			work.a_syms = old.a_syms;
	}
	descrip=creat(fname,0777); /*doit!*/
	if(-1==write(descrip,workp,sizeof(work)))
	{
		close(descrip);
		error("Dumplisp failed",FALSE);
	}
	if(mode == 0413) lseek(descrip,PAGSIZ,0); 
	if( -1==write(descrip,0,workp->a_text)    ||
	    -1==write(descrip,workp->a_text,workp->a_data) ) {
		close(descrip);
		error("Dumplisp failed",FALSE);
	}
	if(des2>0  && work.a_syms) {
		count = old.a_text + old.a_data + (old.a_magic == 0413 ? PAGSIZ 
							       : sizeof(old));
		if(-1==lseek(des2,count,0))
			error("Could not seek to stab",FALSE);
		for(count = old.a_syms;count > 0; count -=BUFSIZ) {
			ax = read(des2,tbuf,(count < BUFSIZ ? count : BUFSIZ));
			if(ax==0) {
				printf("Unexpected end of syms",count);
				fflush(stdout);
				break;
			} else if(ax >  0)
				write(descrip,tbuf,ax);
			else 
				error("Failure to write dumplisp stab",FALSE);
		}
		if(-1 == lseek(des2,
			(old.a_magic == 0413 ? PAGSIZ : sizeof(old))
			+ old.a_text + old.a_data
				+ old.a_trsize + old.a_drsize + old.a_syms,
			       0))
			error(" Could not seek to string table ",FALSE);
		for( ax = 1 ; ax > 0;) {
		     ax = read(des2,tbuf,BUFSIZ);
		     if(ax > 0)
			 write(descrip,tbuf,ax);
		     else if (ax < 0)
			 error("Error in string table read ",FALSE);
		}
	}
	close(descrip);
	if(des2>0) close(des2);
	reborn = 0;

#ifndef UNIXTS
	vadvise(VA_NORM);
#endif
	return(nil);
}
lispval
typred(typ,ptr)
int 	typ;
lispval	ptr;

{   int tx;
	if ((tx = TYPE(ptr)) == typ) return(tatom);
	if ((tx == INT) && (typ == ATOM)) return(tatom);
	return(nil);
}
lispval
Nfunction()
{
	register lispval handy;

	snpand(1);
	handy = lbot->val->d.car;
	if(TYPE(handy)==ATOM && handy->a.fnbnd!=nil)
		return(handy->a.fnbnd);
	else
		return(handy);
}
Commit	Line	Data
31cef89c BJ	1	static char *sccsid = "@(#)fex3.c 34.2 10/13/80";
31cef89c BJ	2
414b5b6c	3	#include "global.h"
31cef89c	4	#include <vadvise.h>
414b5b6c JF	5
	6	/* chkarg ***************************************************************/
	7	/* This insures that there are at least expnum arguments passed to the */
	8	/* BCD function that calls this. If there are fewer, nil arguments */
	9	/* are pushed onto the name stack and np adjusted accordingly. */
31cef89c BJ	10	#ifdef chkarg
	11	#undef chkarg
	12	#endif
	13	chkarg(expnum,string)
414b5b6c	14	int expnum; /* expected number of args */
31cef89c	15	char string[];
414b5b6c JF	16	{
	17	register struct argent *work;
	18	register r10,r9,r8;
	19	register struct argent lbot, np;
	20	saveonly(1);
	21
	22	for(work = np,np = lbot + expnum; work < np; )
	23	work++->val = nil;
414b5b6c JF	24	}
	25
	26
	27	/*
	28	*Ndumplisp -- create executable version of current state of this lisp.
	29	*/
31cef89c	30	#include "a.out.h"
414b5b6c JF	31
	32	asm(" .globl Dlast")
	33	lispval
	34	Ndumplisp()
	35	{
	36	register struct exec *workp;
	37	register lispval argptr, temp;
	38	register char *fname;
	39	extern lispval reborn;
	40	struct exec work, old;
	41	extern etext;
31cef89c BJ	42	extern int dmpmode,holend,curhbeg,usehole;
31cef89c BJ	43	extern int end;
414b5b6c JF	44	int descrip, des2, count, ax,mode;
	45	char tbuf[BUFSIZ];
	46	snpand(4);
	47
31cef89c BJ	48
	49	#ifndef UNIXTS
	50	vadvise(VA_ANOM);
	51	#endif
	52
414b5b6c JF	53	/* dump mode is kept in decimal (which looks like octal in dmpmode)
	54	and is changeable via (sstatus dumpmode n) where n is 413 or 410
	55	base 10
	56	*/
	57	if(dmpmode == 413) mode = 0413;
	58	else mode = 0410;
	59
	60	workp = &work;
	61	workp->a_magic = mode;
31cef89c BJ	62	if(usehole)
	63	workp->a_text = curhbeg & (~PAGRND);
	64	else
	65	workp->a_text = ((((unsigned) (&holend)) - 1) & (~PAGRND)) + PAGSIZ;
	66	#ifndef VMS
414b5b6c	67	workp->a_data = (unsigned) sbrk(0) - workp->a_text;
31cef89c BJ	68	#else
	69	workp->a_data = ((int)&end) - workp->a_text;
	70	#endif
414b5b6c JF	71	workp->a_bss = 0;
	72	workp->a_syms = 0;
	73	workp->a_entry = (unsigned) gstart();
	74	workp->a_trsize = 0;
	75	workp->a_drsize = 0;
	76
	77	fname = "savedlisp"; /set defaults/
	78	reborn = CNIL;
	79	argptr = lbot->val;
	80	if (argptr != nil) {
31cef89c	81	temp = argptr->d.car;
414b5b6c	82	if((TYPE(temp))==ATOM)
31cef89c	83	fname = temp->a.pname;
414b5b6c JF	84	}
	85	des2 = open(gstab(),0);
	86	if(des2 >= 0) {
	87	if(read(des2,&old,sizeof(old))>=0)
	88	work.a_syms = old.a_syms;
	89	}
	90	descrip=creat(fname,0777); /doit!/
	91	if(-1==write(descrip,workp,sizeof(work)))
	92	{
	93	close(descrip);
	94	error("Dumplisp failed",FALSE);
	95	}
	96	if(mode == 0413) lseek(descrip,PAGSIZ,0);
	97	if( -1==write(descrip,0,workp->a_text) \|\|
	98	-1==write(descrip,workp->a_text,workp->a_data) ) {
	99	close(descrip);
	100	error("Dumplisp failed",FALSE);
	101	}
	102	if(des2>0 && work.a_syms) {
	103	count = old.a_text + old.a_data + sizeof(old);
	104	if(-1==lseek(des2,count,0))
	105	error("Could not seek to stab",FALSE);
	106	asm("Dlast:");
	107	for(count = old.a_syms;count > 0; count -=BUFSIZ) {
	108	ax = read(des2,tbuf,BUFSIZ);
	109	if(ax==0) {
	110	printf("Unexpected end of syms",count);
	111	fflush(stdout);
	112	break;
	113	}
	114	if(ax > 0)
	115	write(descrip,tbuf,ax);
	116	else
	117	error("Failure to write dumplisp stab",FALSE);
	118	}
	119	}
	120	close(descrip);
	121	if(des2>0) close(des2);
	122	reborn = 0;
31cef89c BJ	123
	124	#ifndef UNIXTS
	125	vadvise(VA_NORM);
	126	#endif
	127	return(nil);
	128	}
	129
	130	lispval
	131	Nndumplisp()
	132	{
	133	register struct exec *workp;
	134	register lispval argptr, temp;
	135	register char *fname;
	136	extern lispval reborn;
	137	struct exec work, old;
	138	extern etext;
	139	extern int dmpmode,holend,curhbeg,usehole;
	140	int descrip, des2, count, ax,mode;
	141	char tbuf[BUFSIZ];
	142	snpand(4);
	143
	144
	145	#ifndef UNIXTS
	146	vadvise(VA_ANOM);
	147	#endif
	148
	149	/* dump mode is kept in decimal (which looks like octal in dmpmode)
	150	and is changeable via (sstatus dumpmode n) where n is 413 or 410
	151	base 10
	152	*/
	153	if(dmpmode == 413) mode = 0413;
	154	else mode = 0410;
	155
	156	workp = &work;
	157	workp->a_magic = mode;
	158	if(usehole)
	159	workp->a_text = curhbeg & (~PAGRND);
	160	else
	161	workp->a_text = ((((unsigned) (&holend)) - 1) & (~PAGRND)) + PAGSIZ;
	162	workp->a_data = (unsigned) sbrk(0) - workp->a_text;
	163	workp->a_bss = 0;
	164	workp->a_syms = 0;
	165	workp->a_entry = (unsigned) gstart();
	166	workp->a_trsize = 0;
	167	workp->a_drsize = 0;
	168
	169	fname = "savedlisp"; /set defaults/
	170	reborn = CNIL;
	171	argptr = lbot->val;
	172	if (argptr != nil) {
	173	temp = argptr->d.car;
	174	if((TYPE(temp))==ATOM)
	175	fname = temp->a.pname;
	176	}
	177	des2 = open(gstab(),0);
	178	if(des2 >= 0) {
	179	if(read(des2,&old,sizeof(old))>=0)
	180	work.a_syms = old.a_syms;
	181	}
	182	descrip=creat(fname,0777); /doit!/
	183	if(-1==write(descrip,workp,sizeof(work)))
	184	{
	185	close(descrip);
	186	error("Dumplisp failed",FALSE);
187	}
188	if(mode == 0413) lseek(descrip,PAGSIZ,0);
189	if( -1==write(descrip,0,workp->a_text) \|\|
190	-1==write(descrip,workp->a_text,workp->a_data) ) {
191	close(descrip);
192	error("Dumplisp failed",FALSE);
193	}
194	if(des2>0 && work.a_syms) {
195	count = old.a_text + old.a_data + (old.a_magic == 0413 ? PAGSIZ
196	: sizeof(old));
197	if(-1==lseek(des2,count,0))
198	error("Could not seek to stab",FALSE);
199	for(count = old.a_syms;count > 0; count -=BUFSIZ) {
200	ax = read(des2,tbuf,(count < BUFSIZ ? count : BUFSIZ));
201	if(ax==0) {
202	printf("Unexpected end of syms",count);
203	fflush(stdout);
204	break;
205	} else if(ax > 0)
206	write(descrip,tbuf,ax);
207	else
208	error("Failure to write dumplisp stab",FALSE);
209	}
210	if(-1 == lseek(des2,
211	(old.a_magic == 0413 ? PAGSIZ : sizeof(old))
212	+ old.a_text + old.a_data
213	+ old.a_trsize + old.a_drsize + old.a_syms,
214	0))
215	error(" Could not seek to string table ",FALSE);
216	for( ax = 1 ; ax > 0;) {
217	ax = read(des2,tbuf,BUFSIZ);
218	if(ax > 0)
219	write(descrip,tbuf,ax);
220	else if (ax < 0)
221	error("Error in string table read ",FALSE);
222	}
223	}
224	close(descrip);
225	if(des2>0) close(des2);
226	reborn = 0;
227
228	#ifndef UNIXTS
229	vadvise(VA_NORM);
230	#endif
414b5b6c JF	231	return(nil);
	232	}
	233	lispval
	234	typred(typ,ptr)
	235	int typ;
	236	lispval ptr;
	237
	238	{ int tx;
	239	if ((tx = TYPE(ptr)) == typ) return(tatom);
	240	if ((tx == INT) && (typ == ATOM)) return(tatom);
	241	return(nil);
	242	}
	243	lispval
	244	Nfunction()
	245	{
	246	register lispval handy;
	247
	248	snpand(1);
31cef89c BJ	249	handy = lbot->val->d.car;
	250	if(TYPE(handy)==ATOM && handy->a.fnbnd!=nil)
	251	return(handy->a.fnbnd);
414b5b6c JF	252	else
	253	return(handy);
	254	}