"$Header: fex2.c,v 1.3 83/09/07 17:55:38 sklower Exp $";
/* -[Mon Jan 31 21:54:52 1983 by layer]-
* (c) copyright 1982, Regents of the University of California
* Ndo maclisp do function.
register lispval current
, where
, handy
;
register struct nament
*mybnp
;
lispval body
, endtest
, endform
, varstuff
, renewals
[NDOVARS
] ;
struct argent
*getem
, *startnp
;
struct nament
*savedbnp
= bnp
;
int count
, repeatdo
, index
;
extern struct frame
*errp
;
varstuff
= current
->d
.car
;
switch( TYPE(varstuff
) ) {
case ATOM
: /* This is old style maclisp do;
atom is var, cadr(current) = init;
caddr(current) = repeat etc. */
if(varstuff
==nil
) goto newstyle
;
current
= current
->d
.cdr
; /* car(current) is now init */
PUSHDOWN(varstuff
,eval(current
->d
.car
));
*renewals
= (current
= current
->d
.cdr
)->d
.car
;
endtest
= (current
= current
->d
.cdr
)->d
.car
;
errp
= Pushframe(F_PROG
,nil
,nil
);
* returning from this prog, value to return
* going to a certain label, label to go to in
while ((TYPE(where
) == DTPR
)
& (where
->d
.car
!= lispretval
))
if (where
->d
.car
== lispretval
) {
/* label not found in this prog, must
Inonlocalgo(C_GO
,lispretval
,nil
);
case C_INITIAL
: break; /* fall through */
while (TYPE(where
) == DTPR
)
if((TYPE(temp
))!=ATOM
) eval(temp
);
varstuff
->a
.clb
= eval(*renewals
);
case DTPR
: /* New style maclisp do; atom is
list of things of the form
for(where
= varstuff
; where
!= nil
; where
= where
->d
.cdr
) {
/* do inits and count do vars. */
/* requires "simultaneous" eval
while (TYPE(where
->d
.car
) != DTPR
)
errorh1(Vermisc
,"do: variable forms must be lists ",
nil
,TRUE
,0,where
->d
.car
);
handy
= where
->d
.car
->d
.cdr
;
temp
= eval(handy
->d
.car
);
error("More than 15 do vars",FALSE
);
getem
= startnp
; /* base of stack of init forms */
for(index
= 0; index
< count
; index
++) {
/* get var name from group */
while((TYPE(atom
) != ATOM
) || (atom
== nil
))
atom
= errorh1(Vermisc
,"do variable must be a non nil symbol ",
PUSHDOWN(atom
,getem
->val
);
handy
= handy
->d
.cdr
->d
.cdr
;
handy
= CNIL
; /* be sure not to rebind later */
/* more loop "increments" */
np
= startnp
; /* pop off all init forms */
/* Examine End test and End form */
current
= current
->d
.cdr
;
* a do form with a test of nil just does the body once
if (handy
== nil
) repeatdo
= 1; /* just do it once */
else repeatdo
= -1; /* do it forever */
errp
= Pushframe(F_PROG
,nil
,nil
);
* returning from this prog, value to return
* going to a certain label, label to go to in
while ((TYPE(where
) == DTPR
)
& (where
->d
.car
!= lispretval
))
if (where
->d
.car
== lispretval
) {
/* label not found in this prog, must
Inonlocalgo(C_GO
,lispretval
,nil
);
case C_INITIAL
: break; /* fall through */
np
= startnp
; /* is bumped when doing repeat forms */
if((repeatdo
-- == 0) || (eval(endtest
) !=nil
)) {
for(handy
= nil
; endform
!=nil
; endform
= endform
->d
.cdr
)
handy
= eval(endform
->d
.car
);
while (TYPE(where
) == DTPR
)
if((TYPE(temp
))!=ATOM
) eval(temp
);
/* Simultaneously eval repeat forms */
for(index
= 0; index
< count
; index
++) {
if (temp
== nil
|| temp
== CNIL
)
/* now simult. rebind all the atoms */
for(index
= 0; index
< count
; index
++)
if( getem
->val
!= CNIL
) /* if this atom has a repeat */
mybnp
->atm
->a
.clb
= (getem
)->val
; /* rebind */
error("do: neither list nor atom follows do", FALSE
);
register lispval where
, handy
;
register struct nament
*namptr
;
register struct argent
*vars
;
struct nament
*oldbnp
= bnp
;
protect(eval(where
->d
.car
)); /* list of vars = lbot[1].val */
protect(eval((where
= where
->d
.cdr
)->d
.car
));
/* simultaneous eval of all
for(;handy
!=nil
; handy
= handy
->d
.cdr
) {
(np
++)->val
= (handy
->d
.car
);
/* Note, each element should not be reevaluated like it
/* Before: (np++)->val = eval(handy->d.car);*/
/*asm("# Here is where rebinding is done"); /* very cute */
for(handy
=lbot
[1].val
,vars
=lbot
+3; handy
!=nil
; handy
=handy
->d
.cdr
) {
namptr
->atm
= handy
->d
.car
;
++namptr
; /* protect against interrupts
while re-lambda binding */
namptr
[-1].atm
= handy
->d
.car
;
namptr
[-1].val
= handy
->d
.car
->a
.clb
;
handy
->d
.car
->a
.clb
= vars
++->val
;
handy
->d
.car
->a
.clb
= nil
;
for(where
= where
->d
.cdr
; where
!= nil
; where
= where
->d
.cdr
)
handy
= eval(where
->d
.car
);
register lispval result
, where
;
for(where
= lbot
->val
; where
!= nil
; where
= where
->d
.cdr
)
result
= eval(where
->d
.car
);
register lispval result
, where
;
result
= eval((where
= where
->d
.cdr
)->d
.car
);
for(where
= where
->d
.cdr
; where
!= nil
; where
= where
->d
.cdr
)
if ((tx
= TYPE(ptr
)) == typ
) return(tatom
);
if ((tx
== INT
) && (typ
== ATOM
)) return(tatom
);
* In the interpreter, function is the same as quote
if((lbot
->val
== nil
) || (lbot
->val
->d
.cdr
!= nil
))
return(lbot
->val
->d
.car
);