1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
2%
3% File:           PU:INUM.SL
4% Description:    Interpreter entries for open-compiled integer arithmetic
5% Author:         Eric Benson
6% Created:        18 March 1982
7% Modified:       12-Sep-84 09:26:56 (Brian Beach)
8% Mode:           Lisp
9% Package:        Utilities
10% Status:         Open Source: BSD License
11% Compiletime:    PL:RLISP.B
12%
13% (c) Copyright 1983, Hewlett-Packard Company, see the file
14%            HP_disclaimer at the root of the PSL file tree
15%
16% (c) Copyright 1982, University of Utah
17%
18% Redistribution and use in source and binary forms, with or without
19% modification, are permitted provided that the following conditions are met:
20%
21%    * Redistributions of source code must retain the relevant copyright
22%      notice, this list of conditions and the following disclaimer.
23%    * Redistributions in binary form must reproduce the above copyright
24%      notice, this list of conditions and the following disclaimer in the
25%      documentation and/or other materials provided with the distribution.
26%
27% THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
28% AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
29% THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
30% PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNERS OR
31% CONTRIBUTORS
32% BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
33% CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
34% SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
35% INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
36% CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
37% ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
38% POSSIBILITY OF SUCH DAMAGE.
39%
40%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
41%
42% Revisions:
43%
44% 25-Aug-1988 (Anthony C. Hearn)
45%  Parseifor commented out in this module, since it doesn't belong here.
46% 05-Jun-86 (H.Melenk ZIB Berlin)
47%  modified IFOR to handle more than one clause in body
48% 23-Aug-84 07:52:22 (Brian Beach)
49%  Added definition for IFOR.  Used to just change to a WFOR.
50% 06-Dec-83 16:17:09 (Brian Beach)
51%   Changed mksysfor to (cons 'wfor ...)
52% 05-Dec-83 17:39:55 (Nancy Kendzierski)
53%   Added contents of .BUILD file.
54% 02-Dec-83 18:07:14 (Nancy Kendzierski)
55%   Translated from Rlisp to Lisp.
56%
57%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
58
59(off r2i)
60
61(compiletime
62 (progn
63
64  (ds inumtwoarg (iname)
65    (de iname (arg1 arg2)
66      (let (result)
67      (if (and (intp arg1) (intp arg2)
68             (intp (setq result (iname arg1 arg2))))
69        result
70        (inum2error arg1 arg2 'iname)))))
71
72  (ds inumtwoargbool (iname)
73    (de iname (arg1 arg2)
74      (if (and (intp arg1) (intp arg2))
75      (iname arg1 arg2)
76      (inum2error arg1 arg2 'iname))))
77
78  (ds inumonearg (iname)
79    (de iname (arg)
80      (let (result)
81      (if (and (intp arg) (intp (setq result (iname arg))))
82        result
83        (inum1error arg 'iname)))))
84
85  (ds inumoneargbool (iname)
86    (de iname (arg)
87      (if (intp arg)
88      (iname arg)
89      (inum1error arg 'iname))))
90  ))
91
92(de inum2error (arg1 arg2 name)
93  (continuableerror 99 "Inum out of range" (list name arg1 arg2)))
94
95(de inum1error (arg name)
96  (continuableerror 99 "Inum out of range" (list name arg)))
97
98(inumtwoarg iplus2)
99
100(inumtwoarg idifference)
101
102(inumtwoarg itimes2)
103
104(inumtwoarg iquotient)
105
106(inumtwoarg iremainder)
107
108(inumtwoargbool ilessp)
109
110(inumtwoargbool igreaterp)
111
112(inumtwoargbool ileq)
113
114(inumtwoargbool igeq)
115
116(inumtwoarg ilor)
117
118(inumtwoarg iland)
119
120(inumtwoarg ilxor)
121
122(inumtwoarg ilsh)
123
124(inumonearg iadd1)
125
126(inumonearg isub1)
127
128(inumonearg iminus)
129
130(inumoneargbool izerop)
131
132(inumoneargbool ionep)
133
134(inumoneargbool iminusp)
135
136(on r2i)
137
138(dm ifor (u)
139  % U is of the form: (IFOR (FROM var start end step) (DO body))
140
141  (let ((step (nth (second u) 5)))
142    (if (fixp step)
143      (constant-increment-ifor u)
144      (variable-increment-ifor u)
145      )))
146
147(de variable-increment-ifor (u)
148  (let* ((var       (second (second u)))
149       (start     (third  (second u)))
150       (finish    (fourth (second u)))
151       (step      (nth    (second u) 5))
152       (action    (first (third u)))
153       (body      (cons 'progn (cdr (third u))))
154       (result    (list (list 'setq var start)))
155       (x         (list 'IDIFFERENCE finish var))
156       (label1    (gensym))
157       (label2    (gensym)))
158    (unless (onep step)
159      (setf x (list 'ITIMES2 step x))
160      )
161    (unless (eq action 'DO)
162      (stderror "Only do expected in SysLisp FOR")
163      )
164    `(PROG (,var)
165       (SETQ ,var ,start)
166       ,label1
167       (COND ((ILESSP ,x 0) (GO ,label2)))
168       ,body
169       (SETQ ,var (IPLUS2 ,var ,step))
170       (GO ,label1)
171       ,label2
172       )))
173
174(de constant-increment-ifor (u)
175  (let* ((var       (second (second u)))
176       (start     (third  (second u)))
177       (finish    (fourth (second u)))
178       (step      (nth    (second u) 5))
179       (action    (first (third u)))
180       (body      (cons 'progn (cdr (third u))))
181       (result    (list (list 'setq var start)))
182       (comparison(if (minusp step) 'ILESSP 'IGREATERP))
183       (label1    (gensym)))
184    (unless (eq action 'DO)
185      (stderror "Only do expected in SysLisp FOR")
186      )
187    `(PROG (,var)
188       (SETQ ,var ,start)
189       ,label1
190       (COND ((,comparison ,var ,finish) (RETURN 0)))
191       ,body
192       (SETQ ,var (IPLUS2 ,var ,step))
193       (GO ,label1)
194       )))
195
196
197(commentoutcode
198
199(compiletime (load rlisp))
200
201(unless (funboundp 'begin1)
202  (definerop 'ifor nil parseifor)
203  (de parseifor (x)
204    (prog (init stp untl action actexpr)
205          (if (eq (setq op (scan)) 'setq)
206            (setq init (parse0 6 t))
207            (parerr "FOR missing loop VAR assignment" t))
208          (cond ((eq op '!*colon!*) (setq stp 1) (setq op 'until))
209                ((eq op 'step) (setq stp (parse0 6 t)))
210                (t (parerr "FOR missing : or STEP clause" t)))
211          (if (eq op 'until)
212            (setq untl (parse0 6 t))
213            (parerr "FOR missing UNTIL clause" t))
214          (setq action op)
215          (if (memq action '(do sum product))
216            (setq actexpr (parse0 6 t))
217            (parerr "FOR missing action keyword" t))
218          (return (list 'ifor (list 'from x init untl stp)
219                        (list action actexpr)))))
220  nil)
221
222)
223
224