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