1module loops88;  % Rlisp88 looping forms other than the FOR statement.
2
3% Author: Anthony C. Hearn.
4
5% Redistribution and use in source and binary forms, with or without
6% modification, are permitted provided that the following conditions are met:
7%
8%    * Redistributions of source code must retain the relevant copyright
9%      notice, this list of conditions and the following disclaimer.
10%    * Redistributions in binary form must reproduce the above copyright
11%      notice, this list of conditions and the following disclaimer in the
12%      documentation and/or other materials provided with the distribution.
13%
14% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
15% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
16% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
17% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
18% CONTRIBUTORS
19% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25% POSSIBILITY OF SUCH DAMAGE.
26%
27
28
29fluid '(!*blockp loopdelimslist!*);
30
31global '(cursym!* repeatkeywords!* whilekeywords!*);
32
33
34% ***** REPEAT STATEMENT *****
35
36repeatkeywords!* := '(finally initially returns until with);
37
38symbolic procedure repeatstat88;
39  begin scalar body,!*blockp,x,y,z;
40      loopdelimslist!* := repeatkeywords!* . loopdelimslist!*;
41      flag(repeatkeywords!*,'delim);
42      body := erroreval '(xread t);
43      if not (cursym!* memq repeatkeywords!*) then symerr('repeat,t);
44  a:  x := cursym!*;
45      y := erroreval if x eq 'with then '(xread 'lambda)
46                      else '(xread t);
47      z := (x . y) . z;
48      if cursym!* memq repeatkeywords!* then go to a;
49      remflag(car loopdelimslist!*,'delim);
50      loopdelimslist!* := cdr loopdelimslist!*;
51      if loopdelimslist!* then flag(car loopdelimslist!*,'delim);
52      return 'repeat . body . reversip z
53   end;
54
55symbolic macro procedure repeat88 u;
56   begin scalar body,lab,xwith;
57        body := cadr u; u := cddr u;
58        xwith := atsoc('with,u);
59        return sublis(pair('(!$locals !$do !$rets !$inits !$fins !$bool
60                             !$label),
61                           list(if xwith then cdr xwith else nil,
62                                body,
63                                x!-car x!-cdr atsoc('returns,u),
64                                mkfn(x!-cdr atsoc('initially,u),'progn),
65                                mkfn(x!-cdr atsoc('finally,u),'progn),
66                                x!-car x!-cdr atsoc('until,u),
67                                gensym())),
68                      '(prog !$locals
69                             !$inits
70                        !$label !$do
71                             (cond (!$bool !$fins (return !$rets)))
72                             (go !$label)))
73   end;
74
75symbolic procedure remcomma!* u; if null u then nil else remcomma cdr u;
76
77symbolic procedure x!-car u; if atom u then u else car u;
78
79symbolic procedure x!-cdr u; if null u then nil else list cdr u;
80
81% flag('(repeat),'nochange);
82
83symbolic procedure formrepeat88(u,vars,mode);
84   begin scalar y,z;
85      for each x in cddr u do
86         if car x eq 'with
87           then <<y := remcomma cdr x;
88                  vars := nconc(for each j in y collect j . 'scalar,
89                                vars);
90                  z := (car x . y) . z>>
91%         else if car x eq 'until
92%          then z := (car x . formbool(cdr x,vars,mode)) . z
93          else z := (car x . formc(cdr x,vars,mode)) . z;
94      return 'repeat . formc(cadr u,vars,mode) . reversip z
95   end;
96
97
98% ***** WHILE STATEMENT *****
99
100whilekeywords!* := '(collect do finally initially returns with);
101
102symbolic procedure whilstat88;
103   begin scalar !*blockp,bool1,x,y,z;
104      loopdelimslist!* := whilekeywords!* . loopdelimslist!*;
105      flag(whilekeywords!*,'delim);
106      bool1 := erroreval '(xread t);
107      if not (cursym!* memq whilekeywords!*) then symerr('while,t);
108  a:  x := cursym!*;
109      y := erroreval if x eq 'with then '(xread 'lambda)
110                      else '(xread t);
111      z := (x . y) . z;
112      if cursym!* memq whilekeywords!* then go to a;
113      remflag(car loopdelimslist!*,'delim);
114      loopdelimslist!* := cdr loopdelimslist!*;
115      if loopdelimslist!* then flag(car loopdelimslist!*,'delim);
116      return 'while . bool1 . reversip z
117   end;
118
119symbolic macro procedure while88 u;
120   begin scalar body,bool,lab,rets,vars;
121      bool := cadr u; u := cddr u;
122      rets := x!-car x!-cdr atsoc('returns,u);
123      vars := x!-car x!-cdr atsoc('with,u);
124      if body := atsoc('collect,u)
125        then <<vars := gensym() . vars;
126               body := list('setq,
127                            car vars,
128                            list('cons,cdr body,car vars));
129               if rets then rederr "While loop value conflict";
130               rets := list('reversip,car vars)>>
131       else if body := atsoc('do,u) then body := cdr body
132       else rederr "Missing body in WHILE statement";
133      return sublis(pair('(!$locals !$do !$rets !$inits !$fins !$bool
134                           !$label),
135                         list(vars,
136                              body,
137                              rets,
138                              mkfn(x!-cdr atsoc('initially,u),'progn),
139                              mkfn(x!-cdr atsoc('finally,u),'progn),
140                              bool,
141                              gensym())),
142                    '(prog !$locals
143                           !$inits
144                      !$label
145                           (cond ((not !$bool) !$fins (return !$rets)))
146                           !$do
147                           (go !$label)))
148   end;
149
150% flag('(while),'nochange);
151
152symbolic procedure formwhile88(u,vars,mode);
153   begin scalar y,z;
154      for each x in cddr u do
155         if car x eq 'with
156           then <<y := remcomma cdr x;
157                  vars := nconc(for each j in y collect j . 'scalar,
158                                vars);
159                  z := (car x . y) . z>>
160          else z := (car x . formc(cdr x,vars,mode)) . z;
161      return 'while . formc(cadr u,vars,mode) . reversip z
162   end;
163
164endmodule;
165
166end;
167