static char *sccsid
= "@(#)fex4.c 34.1 10/3/80";
/* this is now a lambda function instead of a nlambda.
the only reason that it wasn't a lambda to begin with is that
the person who wrote it didn't know how to write a lexpr
register struct argent
*aptr
;
/* there must be at least one argument */
if (np
==lbot
) { chkarg(1,"syscall"); }
return(error("syscall: bad first argument ", FALSE
));
args
[acount
++] = temp
->i
;
while( ++aptr
< np
&& acount
< 49) {
args
[acount
++] = (int)temp
->a
.pname
;
args
[acount
++] = (int) temp
;
args
[acount
++] = (int)temp
->i
;
return(error("syscall: arg not symbol, string or fixnum", FALSE
));
temp
->i
= vsyscall(args
);
/* eval-when: this has the form (eval-when <list> <form1> <form2> ...)
where the list may contain any combination of `eval', `load', `compile'.
The interpreter (us) looks for the atom `eval', if it is present
we treat the rest of the forms as a progn.
for(handy
=(lbot
->val
)->d
.car
; handy
!= nil
; handy
= handy
->d
.cdr
)
if (handy
->d
.car
== (lispval
) Veval
) { lbot
=np
;
protect(((lbot
-1)->val
)->d
.cdr
);
return(nil
); /* eval not seen */
* 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)
* name - name of the status feature (the first arg to the status
* 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
* readvalue - the value of the status feature is usually stored
* ST_READ - if no second arg, return readvalue.
* if the second arg is given, we return t if it is eq to
* 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
* 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
register lispval handy
,curitm
,valarg
;
struct tm
*lctime
,*localtime();
if(lbot
->val
== nil
) return(nil
);
handy
= lbot
->val
; /* arg list */
while(TYPE(handy
) != DTPR
) handy
= error("status: bad arg list",TRUE
);
curitm
= Istsrch(handy
->d
.car
); /* look for feature */
if( curitm
== nil
) return(nil
); /* non existant */
if( handy
->d
.cdr
== nil
) valarg
= (lispval
) CNIL
;
else valarg
= handy
->d
.cdr
->d
.car
;
/* now do the processing with curitm pointing to the requested
switch( typ
= curitm
->d
.cdr
->d
.car
->i
) { /* look at readcode */
curitm
= Istsrch(handy
->d
.car
); /* look for name */
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
: /* look for feature present */
case ST_FEATR
: /* look for feature */
curitm
= Istsrch(matom("features"));
if( valarg
== (lispval
) CNIL
)
error("status: need second arg",FALSE
);
for( handy
= curitm
->d
.cdr
->d
.cdr
->d
.cdr
;
if(handy
->d
.car
== valarg
)
return(typ
== ST_FEATR
? tatom
: nil
);
return(typ
== ST_FEATR
? nil
: tatom
);
case ST_SYNT
: /* want character syntax */
handy
= Vreadtable
->a
.clb
;
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]; /* get first char */
if(valarg
->a
.pname
[1] != '\0')
error("status: only one character atom allowed",FALSE
);
handy
= inewint(ctable
[indx
] & 0377);
return(stattab
[curitm
->d
.cdr
->d
.cdr
->d
.cdr
->i
]);
return(inewint(dmpmode
));
lctime
= localtime(&ctim
);
(handy
= newdot())->d
.car
= inewint(lctime
->tm_sec
);
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());
valarg
->d
.car
= inewint(lctime
->tm_isdst
);
return( (isatty(0) == TRUE
? tatom
: nil
));
while( TYPE(handy
) != DTPR
|| TYPE(handy
->d
.cdr
) != DTPR
)
handy
= error("sstatus: Bad args",TRUE
);
return(Isstatus(handy
->d
.car
,handy
->d
.cdr
->d
.car
));
/* Isstatus - internal routine to do a set status. */
register lispval curitm
,head
;
lispval
Istsrch(),Iaddstat();
extern int uctolc
, dmpmode
, bcdtrsw
;
curitm
= Istsrch(curnam
);
/* if doesnt exist, make one up */
if(curitm
== nil
) curitm
= Iaddstat(curnam
,ST_READ
,ST_SET
,nil
);
switch (curitm
->d
.cdr
->d
.cdr
->d
.car
->i
) {
case ST_NO
: error("sstatus: cannot set this status",FALSE
);
case ST_FEATW
: curitm
= Istsrch(matom("features"));
(curnam
= newdot())->d
.car
= curval
;
curnam
->d
.cdr
= curitm
->d
.cdr
->d
.cdr
->d
.cdr
; /* old val */
curitm
->d
.cdr
->d
.cdr
->d
.cdr
= curnam
;
case ST_NFETW
: /* remove from features list */
curitm
= Istsrch(matom("features"))->d
.cdr
->d
.cdr
;
for(head
= curitm
->d
.cdr
; head
!= nil
; head
= head
->d
.cdr
)
if(head
->d
.car
== curval
) curitm
->d
.cdr
= head
->d
.cdr
;
case ST_TOLC
: if(curval
== nil
) uctolc
= FALSE
;
case ST_CORE
: if(curval
== nil
)
signal(SIGBUS
,badmemr
); /* catch bus errors */
signal(SIGSEGV
,badmemr
); /* and segmentation viols */
signal(SIGBUS
,SIG_DFL
); /* let them core dump */
stattab
[curitm
->d
.cdr
->d
.cdr
->d
.cdr
->i
] = curval
;
if(TYPE(curval
) != INT
||
curval
->i
!= 410)) errorh(Vermisc
,"sstatus: bad dump mode:",
if(curval
!= nil
) Sautor
= (lispval
) TRUE
;
/* the atom `on' set to set up all table
* to their bcd fcn if possible
if(curval
== matom("on")) clrtt(1);
Strans
= (lispval
) FALSE
;
clrtt(0); /* clear all transfer tables */
if(curval
== nil
) bcdtrsw
= FALSE
;
setit
: /* store value in status list */
curitm
->d
.cdr
->d
.cdr
->d
.cdr
= curval
;
/* Istsrch - utility routine to search the status list for the
name given as an argument. If such an entry is not found,
for(handy
= stlist
; handy
!= nil
; handy
= handy
->d
.cdr
)
if(handy
->d
.car
->d
.car
== nam
) return(handy
->d
.car
);
/* Iaddstat - add a status entry to the status list */
/* return new entry in status list */
Iaddstat(name
,readcode
,setcode
,valu
)
register lispval handy
,handy2
;
protect(handy
=newdot()); /* build status list here */
(handy2
= newdot())->d
.car
= name
;
((handy2
->d
.cdr
= newdot())->d
.car
= newint())->i
= readcode
;
((handy2
->d
.cdr
= newdot())->d
.car
= newint())->i
= setcode
;
handy2
->d
.cdr
->d
.cdr
= valu
;
return(handy
->d
.car
); /* return new item in stlist */