module for88; % Definition of Rlisp88 FOR statement.
% Author: Anthony C. Hearn.
fluid '(!*fastfor binops!* loopdelimslist!*);
global '(forkeywords!*);
flag('(fastfor),'switch); % Since switch may not yet be defined.
Comment The FOR statement defined here has a very rich syntax with many
different options. The parsing and macro expansion are under the control
of keywords that are activated during parsing once FOR has been read.
The keywords are deactivated at the end of the FOR statement, enabling
them to be used as regular ID's in other parts of the program.
The next ID after FOR may define a different type of FOR loop. Such
different loops are indicated by the presence of the ID in the list
forloops!*;
deflist('((all forallstat)),'forloops!*);
Comment
Keywords are defined by their presence in the global list FORKEYWORDS!*.
For each keyword, a parsing construct is also defined under the
indicator FOR-KEYWORD.
The parsing phase of the analysis returns a form:
(FOR (<keyword> . <expression>) ... (<keyword> . <expression>));
forkeywords!* := '(collect count do each every finally in initially
join on product returns some step sum unless until
when with maximize minimize);
% Note: append used to be on the above list, but was removed since it
% couldn't be distinguished from the function "append".
remflag(forkeywords!*,'delim); % For bootstrapping purposes.
Comment some of the keywords denote actions (e.g., PRODUCT, SUM) with
which a binary function is associated. To associate such a function with
an action, one says;
forbinops!* := '((append append) (collect cons) (count plus2)
(join nconc) (maximize max2!*) (minimize min2!*)
(product times2) (sum plus2));
% NB: We need to reset FOR and LET delims if an error occurs. It's
% probably best to do this in the begin1 loop.
symbolic procedure forstat88;
begin scalar !*blockp,x;
if x := get(scan(),'forloops!*) then return lispapply(x,nil);
loopdelimslist!* := forkeywords!* . loopdelimslist!*;
flag(forkeywords!*,'delim);
return 'for . if cursym!* neq 'each
then progn(x := forfrag(), x . fortail())
else fortail()
end;
symbolic procedure forfrag;
begin scalar incr,var,x;
x := erroreval '(xread1 'for);
if not eqcar(x,'setq) or not idp(var := cadr x)
then symerr('for,t);
x := caddr x;
if cursym!* eq 'step
then <<incr := erroreval '(xread t);
if not(cursym!* eq 'until) then symerr('for,t)>>
else if cursym!* eq '!*colon!* then incr := 1
else symerr('for,t);
return list('incr,var,x,erroreval '(xread t),incr)
% if numberp incr and incr>0
% then incr := list('from,var,x,erroreval '(xread t),incr)
% else if eqcar(incr,'minus) and numberp cadr incr and cadr incr>0
% then incr := list('down,var,x,erroreval '(xread t),cadr incr)
% else rederr list("Increment",incr,"not supported");
% return incr
end;
symbolic procedure erroreval u;
begin scalar x;
x := errorset!*(u,t);
if errorp x then error1() else return car x
end;
symbolic procedure eachfrag;
begin scalar x,y;
if not idp(x := scan()) or not((y := scan()) memq '(in on))
then symerr("For each",t);
return list(y,x,erroreval '(xread t));
end;
symbolic procedure fortail;
begin scalar x,y,z,z1;
a: z1 := cursym!*;
if z1 eq 'each
then if not idp(x := scan())
or not((y := scan()) memq '(in on))
then symerr("FOR EACH",t)
else <<z := list(y,x,erroreval '(xread t)) . z;
go to a>>
else if z1 eq 'with
then z := (z1 . erroreval '(xread 'lambda)) . z
else if z1 eq '!*semicol!* then symerr("FOR EACH",t)
else z := (z1 . erroreval '(xread t)) . z;
if cursym!* memq forkeywords!* then go to a;
remflag(car loopdelimslist!*,'delim);
loopdelimslist!* := cdr loopdelimslist!*;
if loopdelimslist!* then flag(car loopdelimslist!*,'delim);
return reversip z
end;
symbolic procedure formfor88(u,vars,mode);
begin scalar x,y,z;
u := z := cdr u;
% First check for local vars.
a: if null z then go to b;
x := car z;
if car x memq '(down from incr in on)
then vars := (cadr x . 'scalar) . vars;
if null(car x eq 'with) then progn(z := cdr z,go to a);
x := remcomma cdr x;
a0: if x then progn(y := (car x . 'scalar) . y, x := cdr x, go to a0);
vars := nconc(reversip!* y,vars);
z := cdr z;
go to a;
% Now do actual analysis.
b: if null u then return 'for . reversip z;
x := car u;
if car x memq '(down from incr)
% We could optimize this by recognizing integers.
then z := (car x . cadr x . formclis(cddr x,vars,mode)) . z
else if car x eq 'with then z := (car x . remcomma cdr x) . z
else if car x memq '(in on)
then z := (car x . list(cadr x,formc(caddr x,vars,mode))) . z
else z := (car x . formc(cdr x,vars,mode)) . z;
u := cdr u;
go to b
end;
symbolic macro procedure for88 x;
begin scalar lvars,init,init2,final,body,!$cond,rets,cur,!$when,
!*maxminflag,next,!$label2,!$while,cx,iv,action,curvar,
valuevar,y;
x := cdr x;
action := caar x;
!$label2 := gensym();
loop:
if null x
then <<final := mkfn(final,'progn);
next := mkfn(next,'progn);
!$cond := mkfn(!$cond,'or);
cur := mkfn(cur,'progn);
body := mkfn(body,'progn);
if !$while
then !$while := forcond
sublis(pair('(!$while final rets),
list(mkfn(!$while,'or),
final,rets)),
'(!$while final
(return rets)));
if !$when
then body := forcond list(!$when,body);
if !*maxminflag then rets := list('null2zero,rets);
return forprog(lvars .
nconc(init,
nconc(init2,
sublis(pair('(final body !$cond rets cur next
!$label !$label2 !$while),
list(final,body,!$cond,rets,cur,next,
gensym(),!$label2,!$while)),
if final then
'(!$label
(cond (!$cond
(progn final (return rets))))
cur
!$while
body
!$label2
next
(go !$label))
else
'(!$label
(cond (!$cond (return rets)))
cur
!$while
body
!$label2
next
(go !$label))))))>>;
cx := car x;
if atom cx then rederr list(cx,"invalid in FOR form")
% WITH tacks its variables onto the !$LVARS list
else if car cx eq 'with
then lvars := append(lvars,cdr cx)
% INITIALLY takes its expressions and tacks them onto the list of
% INIT. This will later be built into a PROGN.
else if car cx eq 'initially
then init := aconc(init,cdr cx)
% FINALLY puts its expressions on the list of FINAL.
% This becomes a PROGN that is created just before the RETURN.
else if car cx eq 'finally
then final := aconc(final,cdr cx)
% ON
else if car cx eq 'on
then <<valuevar := cadr cx;
lvars := valuevar . lvars;
!$cond := list('null,valuevar) . !$cond;
init := list('setq,valuevar,caddr cx) . init;
if cdddr cx
then next := list('setq,valuevar,cadddr x) . next
else next := list('setq, valuevar,list('cdr,valuevar))
. next>>
% IN
else if car cx eq 'in
then <<valuevar := gensym();
iv := cadr cx;
lvars := valuevar . iv . lvars;
init := list('setq,valuevar,caddr cx) . init;
!$cond := list('null,valuevar) . !$cond;
cur := list('setq,iv,list('car,valuevar)) . cur;
if cdddr cx
then next := list('setq,valuevar,list cadddr cx) . next
else next := list('setq,valuevar,list('cdr,valuevar))
. next>>
% INCR
else if car cx eq 'incr
then begin scalar incr,incrvar;
valuevar := cadr cx;
cx := cddr cx;
lvars := valuevar . lvars;
init := list('setq,valuevar,car cx) . init;
incr := caddr cx;
if numberp incr then nil % Assume positive?
else if eqcar(incr,'minus) and numberp cadr incr
then incr := - cadr incr
else <<incrvar := gensym();
lvars := incrvar . lvars;
init := list('setq,incrvar,incr) . init;
incr := incrvar>>;
!$cond :=
(if incrvar
then list('cond,list(list('minusp,incr),
list('lessp,valuevar,cadr cx)),
list('t,list('greaterp,valuevar,
cadr cx)))
else if minusp incr
then if !*fastfor
then list('ilessp,valuevar,cadr cx)
else list('lessp,valuevar,cadr cx)
else if !*fastfor
then list('igreaterp,valuevar,cadr cx)
else list('greaterp,valuevar,cadr cx))
. !$cond;
next := list('setq,valuevar,
list(if incrvar or not !*fastfor
then 'plus2
else 'iplus2,
valuevar,incr)) . next
end
% SUM, PRODUCT etc.
else if car cx memq '(sum product append join count collect
maximize minimize)
then <<curvar := gensym();
lvars := curvar . lvars;
% Set up initial value for loop.
if car cx eq 'product
then init := aconc!*(init,list('setq,curvar,1))
else if car cx memq '(count sum)
then init := aconc!*(init,list('setq,curvar,0))
else if car cx memq '(maximize minimize)
then <<!*maxminflag := t;
%y := list(list('setq,curvar,cdr cx),
% list('go,!$label2));
if action eq 'in
then y :=
list('setq,iv,list('car,valuevar)); % . y;
if action memq '(in on)
then y :=
list('cond,list(list('null,valuevar),
'(return 0)))
. y;
nconc!*(init,y)>>;
if car cx eq 'collect
then rets := list('reversip,curvar)
else rets := curvar;
body := list('setq,curvar,
list(get(car cx,'bin),
if car cx memq '(append count join) then curvar
else cdr cx,
if car cx memq '(append join) then cdr cx
else if car cx eq 'count
then list('cond,list(cdr cx,1),'(t 0))
else curvar))
. body>>
% RETURNS
else if car cx eq 'returns then rets := cdr cx
% DO
else if car cx eq 'do then body := aconc(body,cdr cx)
% WHEN
else if car cx eq 'when
then if !$when
then symerr("Redundant WHEN or UNLESS in FOR statement",
nil)
else !$when := cdr cx
% UNLESS
else if car cx eq 'unless
then if !$when
then symerr("Redundant WHEN or UNLESS in FOR statement",
nil)
else !$when := list('not,cdr cx)
% WHILE
% else if car cx eq 'while
% then !$while := append(!$while,list list('not,cdr cx))
% UNTIL
else if car cx eq 'until
then !$while := append(!$while,list cdr cx)
% SOME
else if car cx eq 'some
then cur := append(cur,
list list('cond,list(cdr cx,list('return,t))))
% EVERY
else if car cx eq 'every
then <<if not rets then rets := t;
cur := append(cur,
list list('cond,list(list('null,cdr cx),
list('return,nil))))>>
else rederr list(car cx,"invalid in FOR form");
x := cdr x;
go to loop
end;
symbolic procedure forcond u;
list('cond,list(car u,if cddr u then 'progn . cdr u else cadr u));
symbolic procedure forprog u;
'prog . fornilchk u;
symbolic procedure fornilchk u;
if null u then nil
else if null car u then fornilchk cdr u
else car u . fornilchk cdr u;
symbolic procedure max2!*(u,v); if null v then u else max2(u,v);
symbolic procedure min2!*(u,v); if null v then u else min2(u,v);
symbolic procedure null2zero u; if null u then 0 else u;
symbolic procedure mkfn(x,fn);
if atom x then x else if length x>1 then fn . x else car x;
endmodule;
end;