franz/fex4.c
/*	Status functions. 
 *  These operate on the statuslist stlist which has the form:
 *	( status_elem_1 status_elem_2 status_elem_3 ...)
 *  where each status element has the form:
 *	( name readcode setcode .  readvalue)
 *  where
 *	name - name of the status feature (the first arg to the status
 *		function).
 *	readcode - fixnum which tells status how to read the value of
 *		this status name.  The codes are #defined.
 *	setcode - fixnum which tells sstatus how to set the value of
 *		this status name
 *	readvalue - the value of the status feature is usually stored
 *		here.
 *	
 * Readcodes:
 *
 *	ST_READ - if no second arg, return readvalue.
 *		  if the second arg is given, we return t if it is eq to
 *		  the readvalue.
 *	ST_FEATR - used in (status feature xxx) where we test for xxx being
 *		  in the status features list
 *	ST_SYNT - used in (status syntax c) where we return c's syntax code
 *	ST_INTB - read stattab entry
 *	ST_NFETR - used in (status nofeature xxx) where we test for xxx not
 *		  being in the status features list
 *	ST_DMPR - read the dumpmode 
 *	ST_UNDEF - return the undefined functions in the transfer table
 * 
 * Setcodes:
 *	ST_NO -  if not allowed to set this status through sstatus.
 *	ST_SET - if the second arg is made the readvalue.
 *	ST_FEATW - for (sstatus feature xxx), we add xxx to the 
 *		  (status features) list.
 *	ST_TOLC - if non nil, map upper case chars in atoms to lc.
 *	ST_CORE - if non nil, have bus errors and segmentation violations
 *		  dump core, if nil have them produce a bad-mem err msg
 *	ST_INTB - set stattab table entry
 *	ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
 *		   from the status feature list.
 *	ST_DMPW - set the dumpmode
 *	ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
 *		   calls from BCD functions to BCD functions
 *	ST_GCSTR - (ifdef GCSTRINGS) garbage collect strings
 */
Status functions.
These operate on the statuslist stlist which has the form:
( status_elem_1 status_elem_2 status_elem_3 ...)
where each status element has the form:
( name readcode setcode .  readvalue)
where
name - name of the status feature (the first arg to the status
function).
readcode - fixnum which tells status how to read the value of
this status name.  The codes are #defined.
setcode - fixnum which tells sstatus how to set the value of
this status name
readvalue - the value of the status feature is usually stored
here.



if no second arg, return readvalue.
if the second arg is given, we return t if it is eq to
the readvalue.

if not allowed to set this status through sstatus.
ST_SET - if the second arg is made the readvalue.
ST_FEATW - for (sstatus feature xxx), we add xxx to the
(status features) list.
ST_TOLC - if non nil, map upper case chars in atoms to lc.
ST_CORE - if non nil, have bus errors and segmentation violations
dump core, if nil have them produce a bad-mem err msg
ST_INTB - set stattab table entry
ST_NFETW - use in (sstatus nofeature xxx) where we wish to remove xxx
from the status feature list.
ST_DMPW - set the dumpmode
ST_BCDTR - (ifdef RSET) if non nil, creat trace stack entries for
calls from BCD functions to BCD functions
ST_GCSTR - (ifdef GCSTRINGS) garbage collect strings
Status functions . These operate on the statuslist stlist which has the form : ( status_elem_1 status_elem_2 status_elem_3 ... ) where each status element has the form : ( name readcode setcode . readvalue ) where name - name of the status feature ( the first arg to the status function ) . readcode - fixnum which tells status how to read the value of this status name . The codes are #defined . setcode - fixnum which tells sstatus how to set the value of this status name readvalue - the value of the status feature is usually stored here . if no second arg return readvalue . if the second arg is given we return t if it is eq to the readvalue . if not allowed to set this status through sstatus . ST_SET - if the second arg is made the readvalue . ST_FEATW - for ( sstatus feature xxx ) we add xxx to the ( status features ) list . ST_TOLC - if non nil map upper case chars in atoms to lc . ST_CORE - if non nil have bus errors and segmentation violations dump core if nil have them produce a bad - mem err msg ST_INTB - set stattab table entry ST_NFETW - use in ( sstatus nofeature xxx ) where we wish to remove xxx from the status feature list . ST_DMPW - set the dumpmode ST_BCDTR - ( ifdef RSET ) if non nil creat trace stack entries for calls from BCD functions to BCD functions ST_GCSTR - ( ifdef GCSTRINGS ) garbage collect strings
lispval
Nstatus()
{
	register lispval handy,curitm,valarg;
	int indx,ctim;
	int typ;
	char *cp;
	char *ctime();
	struct tm *lctime,*localtime();
	extern unsigned char *ctable;
	extern int dmpmode;
	extern lispval chktt();
	lispval Istsrch();
	Savestack(3);
	if(lbot->val == nil) return(nil);
	handy = lbot->val;		
	while(TYPE(handy) != DTPR) handy = error("status: bad arg list",TRUE); 
	curitm = Istsrch(handy->d.car);	
	if( curitm == nil ) return(nil);	
	if( handy->d.cdr == nil ) valarg = (lispval) CNIL;
	else valarg = handy->d.cdr->d.car;
	switch( typ = curitm->d.cdr->d.car->i ) {	
	case ST_READ:
		curitm = Istsrch(handy->d.car);	
		if(curitm == nil) return(nil);
		if( valarg != (lispval) CNIL) 
		    error("status: Second arg not allowed.",FALSE);
		else return(curitm->d.cdr->d.cdr->d.cdr);
	case ST_NFETR:				
	case ST_FEATR:				
		curitm = Istsrch(matom("features"));
		if( valarg == (lispval) CNIL) 
		    error("status: need second arg",FALSE);
		for( handy = curitm->d.cdr->d.cdr->d.cdr;
		     handy != nil;
		     handy = handy->d.cdr)
		   if(handy->d.car == valarg) 
			 return(typ == ST_FEATR ? tatom : nil);
		return(typ == ST_FEATR ? nil : tatom);
	case ST_SYNT:				
		handy = Vreadtable->a.clb;
		chkrtab(handy);
		if( valarg == (lispval) CNIL)
			error("status: need second arg",FALSE);
		while (TYPE(valarg) != ATOM) 
		    valarg = error("status: second arg must be atom",TRUE);
		indx = valarg->a.pname[0];	
		if(valarg->a.pname[1] != '\0')
			error("status: only one character atom allowed",FALSE);
		handy = inewint((long) ctable[indx]);
		return(handy);
	case ST_RINTB:
		return(stattab[curitm->d.cdr->d.cdr->d.cdr->i]);
	case ST_DMPR:
		return(inewint(dmpmode));
	case ST_CTIM:
		 ctim = time((time_t *)0);
		 cp = ctime(&ctim);
		 cp[24] = '\0';
		 return(matom(cp));
	case ST_LOCT:
		 ctim = time((time_t *)0);
		 lctime = localtime(&ctim);
		 (handy = newdot())->d.car = inewint(lctime->tm_sec);
		 protect(handy);
		 handy->d.cdr =  (valarg = newdot());
		 valarg->d.car = inewint(lctime->tm_min);
		 valarg->d.cdr = (curitm = newdot());
		 curitm->d.car = inewint(lctime->tm_hour);
		 curitm->d.cdr = (valarg = newdot());
		 valarg->d.car = inewint(lctime->tm_mday);
		 valarg->d.cdr = (curitm = newdot());
		 curitm->d.car = inewint(lctime->tm_mon);
		 curitm->d.cdr = (valarg = newdot());
		 valarg->d.car = inewint(lctime->tm_year);
		 valarg->d.cdr = (curitm = newdot());
		 curitm->d.car = inewint(lctime->tm_wday);
		 curitm->d.cdr = (valarg = newdot());
		 valarg->d.car = inewint(lctime->tm_yday);
		 valarg->d.cdr = (curitm = newdot());
		 curitm->d.car = inewint(lctime->tm_isdst);
		 Restorestack();
		 return(handy);
	case ST_ISTTY:
		return( (isatty(0) == TRUE ? tatom : nil));
	case ST_UNDEF:
		return(chktt());
	}
	error("Internal error in status: Couldn't figure out request",FALSE);
}
lispval Nstatus ( ) { register lispval handy , curitm , valarg ; int indx , ctim ; int typ ; char * cp ; char * ctime ( ) ; struct tm * lctime , * localtime ( ) ; extern unsigned char * ctable ; extern int dmpmode ; extern lispval chktt ( ) ; lispval Istsrch ( ) ; Savestack ( 3 ) ; if ( lbot -> val == nil ) return ( nil ) ; handy = lbot -> val ; while ( TYPE ( handy ) != DTPR ) handy = error ( " " , TRUE ) ; curitm = Istsrch ( handy -> d . car ) ; if ( curitm == nil ) return ( nil ) ; if ( handy -> d . cdr == nil ) valarg = ( lispval ) CNIL ; else valarg = handy -> d . cdr -> d . car ; switch ( typ = curitm -> d . cdr -> d . car -> i ) { case ST_READ : curitm = Istsrch ( handy -> d . car ) ; if ( curitm == nil ) return ( nil ) ; if ( valarg != ( lispval ) CNIL ) error ( " " , FALSE ) ; else return ( curitm -> d . cdr -> d . cdr -> d . cdr ) ; case ST_NFETR : case ST_FEATR : curitm = Istsrch ( matom ( " " ) ) ; if ( valarg == ( lispval ) CNIL ) error ( " " , FALSE ) ; for ( handy = curitm -> d . cdr -> d . cdr -> d . cdr ; handy != nil ; handy = handy -> d . cdr ) if ( handy -> d . car == valarg ) return ( typ == ST_FEATR ? tatom : nil ) ; return ( typ == ST_FEATR ? nil : tatom ) ; case ST_SYNT : handy = Vreadtable -> a . clb ; chkrtab ( handy ) ; if ( valarg == ( lispval ) CNIL ) error ( " " , FALSE ) ; while ( TYPE ( valarg ) != ATOM ) valarg = error ( " " , TRUE ) ; indx = valarg -> a . pname [ 0 ] ; if ( valarg -> a . pname [ 1 ] != ' \0 ' ) error ( " " , FALSE ) ; handy = inewint ( ( long ) ctable [ indx ] ) ; return ( handy ) ; case ST_RINTB : return ( stattab [ curitm -> d . cdr -> d . cdr -> d . cdr -> i ] ) ; case ST_DMPR : return ( inewint ( dmpmode ) ) ; case ST_CTIM : ctim = time ( ( time_t * ) 0 ) ; cp = ctime ( & ctim ) ; cp [ 24 ] = ' \0 ' ; return ( matom ( cp ) ) ; case ST_LOCT : ctim = time ( ( time_t * ) 0 ) ; lctime = localtime ( & ctim ) ; ( handy = newdot ( ) ) -> d . car = inewint ( lctime -> tm_sec ) ; protect ( handy ) ; handy -> d . cdr = ( valarg = newdot ( ) ) ; valarg -> d . car = inewint ( lctime -> tm_min ) ; valarg -> d . cdr = ( curitm = newdot ( ) ) ; curitm -> d . car = inewint ( lctime -> tm_hour ) ; curitm -> d . cdr = ( valarg = newdot ( ) ) ; valarg -> d . car = inewint ( lctime -> tm_mday ) ; valarg -> d . cdr = ( curitm = newdot ( ) ) ; curitm -> d . car = inewint ( lctime -> tm_mon ) ; curitm -> d . cdr = ( valarg = newdot ( ) ) ; valarg -> d . car = inewint ( lctime -> tm_year ) ; valarg -> d . cdr = ( curitm = newdot ( ) ) ; curitm -> d . car = inewint ( lctime -> tm_wday ) ; curitm -> d . cdr = ( valarg = newdot ( ) ) ; valarg -> d . car = inewint ( lctime -> tm_yday ) ; valarg -> d . cdr = ( curitm = newdot ( ) ) ; curitm -> d . car = inewint ( lctime -> tm_isdst ) ; Restorestack ( ) ; return ( handy ) ; case ST_ISTTY : return ( ( isatty ( 0 ) == TRUE ? tatom : nil ) ) ; case ST_UNDEF : return ( chktt ( ) ) ; } error ( " " , FALSE ) ; }
Status functions.
Status functions .
/* arg list */ /* look for feature */ /* non existant */ /* now do the processing with curitm pointing to the requested
	   item in the status list 
	 */ /* look at readcode */ /* look for name */ /* look for feature present */ /* look for feature */ /* want character syntax */ /* get first char */ /* NOTREACHED */