register lispval aptr
, temp
;
return(error("syscall", FALSE
));
args
[acount
++] = temp
->i
;
while( aptr
!= nil
&& acount
< 49) {
args
[acount
++] = (int)temp
->a
.pname
;
args
[acount
++] = (int)temp
->i
;
return(error("syscall", FALSE
));
if (acount
==0) chkarg(2); /* produce arg count message */
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
)->car
; handy
!= nil
; handy
= handy
->cdr
)
if (handy
->car
== (lispval
) Veval
) { lbot
=np
;
protect(((lbot
-1)->val
)->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_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
register lispval handy
,curitm
,valarg
;
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
->car
); /* look for feature */
if( curitm
== nil
) return(nil
); /* non existant */
if( handy
->cdr
== nil
) valarg
= (lispval
) CNIL
;
else valarg
= handy
->cdr
->car
;
/* now do the processing with curitm pointing to the requested
switch( typ
= curitm
->cdr
->car
->i
) { /* look at readcode */
curitm
= Istsrch(handy
->car
); /* look for name */
if(curitm
== nil
) return(nil
);
if( valarg
!= (lispval
) CNIL
)
error("status: Second arg not allowed.",FALSE
);
else return(curitm
->cdr
->cdr
->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
->cdr
->cdr
->cdr
;
return(typ
== ST_FEATR
? tatom
: nil
);
return(typ
== ST_FEATR
? nil
: tatom
);
case ST_SYNT
: /* want characcter syntax */
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
->pname
[0]; /* get first char */
if(valarg
->pname
[1] != '\0')
error("status: only one character atom allowed",FALSE
);
(handy
= newint())->i
= ctable
[indx
] & 0377;
return(stattab
[curitm
->cdr
->cdr
->cdr
->i
]);
return(inewint(dmpmode
));
while( TYPE(handy
) != DTPR
|| TYPE(handy
->cdr
) != DTPR
)
handy
= error("sstatus: Bad args",TRUE
);
return(Isstatus(handy
->car
,handy
->cdr
->car
));
/* Isstatus - internal routine to do a set status. */
register lispval curitm
,head
;
lispval
Istsrch(),Iaddstat();
extern int uctolc
, dmpmode
;
curitm
= Istsrch(curnam
);
/* if doesnt exist, make one up */
if(curitm
== nil
) curitm
= Iaddstat(curnam
,ST_READ
,ST_SET
,nil
);
switch (curitm
->cdr
->cdr
->car
->i
) {
case ST_NO
: error("sstatus: cannot set this status",FALSE
);
case ST_FEATW
: curitm
= Istsrch(matom("features"));
(curnam
= newdot())->car
= curval
;
curnam
->cdr
= curitm
->cdr
->cdr
->cdr
; /* old val */
curitm
->cdr
->cdr
->cdr
= curnam
;
case ST_NFETW
: /* remove from features list */
curitm
= Istsrch(matom("features"))->cdr
->cdr
;
for(head
= curitm
->cdr
; head
!= nil
; head
= head
->cdr
)
if(head
->car
== curval
) curitm
->cdr
= head
->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
->cdr
->cdr
->cdr
->i
] = curval
;
if(TYPE(curval
) != INT
||
curval
->i
!= 410)) errorh(Vermisc
,"sstatus: bad dump mode:",
setit
: /* store value in status list */
curitm
->cdr
->cdr
->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
->cdr
)
if(handy
->car
->car
== nam
) return(handy
->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())->car
= name
;
((handy2
->cdr
= newdot())->car
= newint())->i
= readcode
;
((handy2
->cdr
= newdot())->car
= newint())->i
= setcode
;
return(handy
->car
); /* return new item in stlist */