/* Nprog ****************************************************************/
/* This first sets the local variables to nil while saving their old */
/* values on the name stack. Then, pointers to various things are */
/* saved as this function may be returned to by an "Ngo" or by a */
/* "Lreturn". At the end is the loop that cycles through the contents */
register struct nament
*mybnp
= bnp
;
register struct argent
*savednp
;
register lispval where
, temp
;
register struct argent
*lbot
, *np
;
struct argent
*savedlbot
;
int myerrp
; extern int errp
;
temp
= where
= (lbot
->val
)->car
;
while (TYPE(temp
) == DTPR
)
temp
= where
= where
->cdr
;
if (where
!= nil
) return(CNIL
);
temp
= where
= savedlbot
->val
->cdr
;
while (retval
= setexit()) {
case BRRETN
: resexit(saveme
);
case BRGOTO
: where
= (savedlbot
->val
)->cdr
;
while ((TYPE(where
) == DTPR
) && (where
->car
!= contval
))
if (where
->car
== contval
) {
while (TYPE(where
) == DTPR
)
if((TYPE(temp
))!=ATOM
) eval(temp
);
return((where
== nil
) ? nil
: CNIL
);
Ncatch is now actually *catch , which has the form
tag is evaluated and then the catch entry is set up.
finally the catch entry is removed.
(catch form [tag]) is translated to (*catch 'tag form)
struct argent
*savednp
,*savedlbot
;
register lispval where
, tag
, todo
;
register struct argent
*lbot
, *np
;
if((TYPE(where
))!=DTPR
) return(nil
);
tag
= error("Non symbolic tag in *catch.",TRUE
);
asm(" subl2 $40,sp"); /* THIS IS A CROCK ....
saves current environment
asm(" movc3 $40,_setsav,(sp)");
if present, flag determines if the error message will be printed
if an error reaches the errset.
if no error occurs, errset returns a list of one element, the
value returned from form.
if an error occurs, nil is usually returned although it could
be non nil if err threw a non nil value
register lispval flag
,where
,todo
; /* order important */
register lispval handy
= Vlerall
; /* to access this easily */
register struct argent
*lbot
, *np
;
if(TYPE(where
) != DTPR
) return(nil
); /* no form */
todo
= where
->car
; /* form to eval */
if(flag
!= nil
) flag
= eval(flag
->car
); /* tag to tell if er messg */
else flag
= tatom
; /* if not present , assume t */
/* push on a catch frame */
asm(" pushab On2"); /* where to jump if error */
asm(" subl2 $40,sp"); /* THIS IS A CROCK ....
saves current environment
asm(" movc3 $40,_setsav,(sp)");
asm(" pushl r8"); /* tag , (ER%all) */
asm(" pushl r11"); /* flag */
asm(" pushl _errp"); /* link in */
asm(" movl sp,_errp"); /* " */
/* evaluate form, and if ok, listify */
asm(" movl (sp),_errp"); /* unlink this frame */
protect(handy
); /* may gc on nxt call */
(flag
= newdot()) ->car
= handy
; /* listify arg */
asm("On2: ret"); /* if error occured */
/* this was changed from throw to *throw 21nov79
it really should be called Lthrow
register lispval todo
, where
;
snpand(2); /* save register mask */
Idothrow(globtag
,contval
);
error("Uncaught throw",FALSE
);
typedef struct catchfr
*cp
;
register cp curp
; /* must be first register */
for (curp
=(cp
)errp
; curp
!= (cp
) nil
; curp
=curp
->link
)
if(curp
->labl
== nil
|| curp
->labl
== tag
)
asm(" addl3 $16,r11,sp");
/* account for current (return) */
asm(" movc3 $40,(sp),_setsav");
/* Ngo ******************************************************************/
/* First argument only is checked - and must be an atom or evaluate */
contval
= (lbot
->val
)->car
;
while (TYPE(contval
) != ATOM
)
while (TYPE(contval
) != ATOM
) contval
= error("GO ARG NOT ATOM",TRUE
);
/* Nreset ***************************************************************/
/* All arguments are ignored. This just returns-from-break to depth 0. */
/* Nresetio *************************************************************/
for(p
= &_iob
[3]; p
< _iob
+ _NFILE
; p
++) {
if(p
->_flag
& (_IOWRT
| _IOREAD
)) fclose(p
);
/* Nbreak ***************************************************************/
/* If first argument is not nil, this is evaluated and printed. Then */
/* error is called with the "breaking" message. */
register lispval hold
; register FILE *port
;
port
= okport(Vpoport
->clb
,stdout
);
fprintf(port
,"Breaking:");
if ((hold
= lbot
->val
) != nil
&& ((hold
= hold
->car
) != nil
))
/* Nexit ****************************************************************/
/* Just calls lispend with no message. */
/* Nsys *****************************************************************/
/* Just calls lispend with no message. */
register lispval arglist
, body
, name
, form
;
arglist
= body
->cdr
->car
;
if((TYPE(arglist
))!=DTPR
&& arglist
!= nil
)
error("Warning: defining function with nonlist of args",
return((lbot
->val
)->car
);
{ register lispval handy
, where
, value
;
register struct argent
*lbot
, *np
;
for(where
= lbot
->val
; where
!= nil
; where
= handy
->cdr
) {
error("odd number of args to setq",FALSE
);
if((lefttype
=TYPE(where
->car
))==ATOM
) {
error("Attempt to set nil",FALSE
);
where
->car
->clb
= value
= eval(handy
->car
);
}else if(lefttype
==VALUE
)
where
->car
->l
= value
= eval(handy
->car
);
else error("CAN ONLY SETQ ATOMS OR VALUES",FALSE
);
register lispval where
, last
;
if ((TYPE(where
->car
))!=DTPR
)
if ((last
=eval((where
->car
)->car
)) != nil
)
if ((TYPE(where
)) != DTPR
)
where
= (where
->car
)->cdr
;
while ((TYPE(where
))==DTPR
) {
register lispval current
, temp
;
if ( (temp
= current
->car
)!=nil
&& (temp
= eval(temp
))!=nil
)
register lispval current
, temp
;
if ( (temp
= eval(current
->car
)) == nil
)
int wflag
, childsi
, childso
, childnum
, child
;
register lispval current
, temp
;
if( (TYPE(current
))!=DTPR
)
if( (current
= current
->cdr
)!=nil
&& (TYPE((temp
= current
->car
)))==ATOM
) {
} else if (temp
!= nil
) {
temp
->clb
= (lispval
)bufs
[1];
childsi
= fileno(bufs
[0]);
if( (current
= current
->cdr
)!=nil
&& (TYPE((temp
= current
->car
)))==ATOM
) {
temp
->clb
= (lispval
)obufs
[0];
childso
= fileno(obufs
[1]);
if((child
= fork()) == 0 ) {
if(wflag
!=0 && handler
!=1)
execlp("csh", "csh", "-c",sharg
,0);
execlp("sh", "sh", "-c",sharg
,0);
exit(-1); /* if exec fails, signal problems*/
if(childsi
!= 0) fclose(bufs
[0]);
if(childso
!= 1) fclose(obufs
[1]);
if(wflag
&& child
!= -1) {