1 (setq SCCS-primFp.l "@(#)primFp.l 1.3 05/30/83") 2 ; FP interpreter/compiler 3 ; Copyright (c) 1982 Scott B. Baden 4 ; Berkeley, California 5 6 (include specials.l) 7 (declare (special y_l z_l) 8 (localf ok_pair ok_eqpair rpair$ lpair$ trnspz allNulls 9 allLists emptyHeader treeInsWithLen)) 10 11 ; fp addition 12 13 (defun plus$fp (x) 14 (cond (DynTraceFlg (IncrTimes 'plus$fp))) 15 (cond ((ok_pair x 'numberp) (plus (car x) (cadr x))) 16 (t (bottom)))) 17 18 ; unit function 19 20 (defun (u-fnc plus$fp) nil 21 0) 22 23 ; fp subtraction 24 25 (defun sub$fp (x) 26 (cond (DynTraceFlg (IncrTimes 'sub$fp))) 27 (cond ((ok_pair x 'numberp) (diff (car x) (cadr x))) 28 (t (bottom)))) 29 30 31 ; unit function 32 33 (defun (u-fnc sub$fp) nil 34 0) 35 36 ; fp multiplication 37 38 (defun times$fp (x) 39 (cond (DynTraceFlg (IncrTimes 'times$fp))) 40 (cond ((ok_pair x 'numberp) (product (car x) (cadr x))) 41 (t (bottom)))) 42 43 ; unit function 44 45 (defun (u-fnc times$fp) nil 46 1) 47 48 49 ; fp division 50 51 (defun div$fp (x) 52 (cond (DynTraceFlg (IncrTimes 'div$fp))) 53 (cond ((ok_pair x 'numberp) 54 (cond ((not (zerop (cadr x))) 55 (quotient (car x) (cadr x))) 56 (t (bottom)))) 57 (t (bottom)))) 58 59 ; unit function 60 61 (defun (u-fnc div$fp) nil 62 1) 63 64 65 66 ; logical functions, and or xor not 67 68 (defun and$fp (x) 69 (cond (DynTraceFlg (IncrTimes 'and$fp))) 70 (cond ((ok_pair x 'boolp) 71 (cond 72 ((eq 'F (car x)) 'F) 73 (t (cadr x)))) 74 (t (bottom)))) 75 76 ; unit function 77 78 (defun (u-fnc and$fp) nil 79 'T) 80 81 82 (defun or$fp (x) 83 (cond (DynTraceFlg (IncrTimes 'or$fp))) 84 (cond ((ok_pair x 'boolp) 85 (cond 86 ((eq 'T (car x)) 'T) 87 (t (cadr x)))) 88 (t (bottom)))) 89 90 ; unit function 91 92 (defun (u-fnc or$fp) nil 93 'F) 94 95 96 (defun xor$fp (x) 97 (cond (DynTraceFlg (IncrTimes 'xor$fp))) 98 (cond ((ok_pair x 'boolp) 99 (let ((p (car x)) 100 (q (cadr x))) 101 (cond ((or (and (eq p 'T) (eq q 'T)) 102 (and (eq p 'F) (eq q 'F))) 103 'F) 104 (t 'T)))) 105 (t (bottom)))) 106 107 ; unit function 108 109 (defun (u-fnc xor$fp) nil 110 'F) 111 112 113 (defun not$fp (x) 114 (cond (DynTraceFlg (IncrTimes 'not$fp))) 115 (cond ((not (atom x)) (bottom)) 116 ((boolp x) (cond ((eq x 'T) 'F) (t 'T))) 117 (t (bottom)))) 118 119 120 ; relational operators, < <= = >= > ~= 121 122 (defun lt$fp (x) 123 (cond (DynTraceFlg (IncrTimes 'lt$fp))) 124 (cond ((ok_pair x 'numberp) 125 (cond ((lessp (car x) (cadr x)) 'T) 126 (t 'F))) 127 (t (bottom)))) 128 129 (defun le$fp (x) 130 (cond (DynTraceFlg (IncrTimes 'le$fp))) 131 (cond ((ok_pair x 'numberp) 132 (cond ((not (greaterp (car x) (cadr x))) 'T) 133 (t 'F))) 134 (t (bottom)))) 135 136 (defun eq$fp (x) 137 (cond (DynTraceFlg (IncrTimes 'eq$fp))) 138 (cond ((ok_eqpair x ) 139 (cond ((equal (car x) (cadr x)) 'T) 140 (t 'F))) 141 (t (bottom)))) 142 143 (defun ge$fp (x) 144 (cond (DynTraceFlg (IncrTimes 'ge$fp))) 145 (cond ((ok_pair x 'numberp) 146 (cond ((not (lessp (car x) (cadr x))) 'T) 147 (t 'F))) 148 (t (bottom)))) 149 150 (defun gt$fp (x) 151 (cond (DynTraceFlg (IncrTimes 'gt$fp))) 152 (cond ((ok_pair x 'numberp) 153 (cond ((greaterp (car x) (cadr x)) 'T) 154 (t 'F))) 155 (t (bottom)))) 156 157 (defun ne$fp (x) 158 (cond (DynTraceFlg (IncrTimes 'ne$fp))) 159 (cond ((ok_eqpair x) 160 (cond ((not (equal (car x) (cadr x))) 'T) 161 (t 'F))) 162 (t (bottom)))) 163 164 165 166 ; check arguments for eq and ne 167 168 (defun ok_eqpair (x) 169 (cond ((not (atom x)) 170 (cond ((eq (length x) 2) t))))) 171 172 ; check arguments for binary arithmetics/logicals 173 174 (defun ok_pair (x typ) 175 (cond ((not (atom x)) 176 (cond ((eq (length x) 2) 177 (cond 178 ((and (atom (car x)) (atom (cadr x))) 179 (cond ((and (funcall typ (car x)) 180 (funcall typ (cadr x))) t))))))))) 181 182 ; check if a variable is boolean, 'T' or 'F' 183 184 (defun boolp (x) 185 (memq x '(T F))) 186 187 188 (defun undefp (x) 189 (eq x '?)) 190 191 (defun tl$fp (x) 192 (cond (DynTraceFlg (IncrSize 'tl$fp (size x)) (IncrTimes 'tl$fp))) 193 (cond ((atom x) (bottom)) 194 (t (cdr x)))) 195 196 197 (defun tlr$fp (x) 198 (cond (DynTraceFlg (IncrSize 'tlr$fp (size x)) (IncrTimes 'tlr$fp))) 199 (cond ((listp x) (cond 200 ((onep (length x)) nil) 201 (t (reverse (cdr (reverse x)))))) 202 (t (bottom)))) 203 204 ; this function is just like id$fp execept it also prints its 205 ; argument on the stdout. It is meant to be used only for debuging. 206 207 (defun out$fp (x) 208 (fpPP x) 209 (terpri) 210 x) 211 212 (defun id$fp (x) 213 (cond (DynTraceFlg (IncrSize 'id$fp (size x)) (IncrTimes 'id$fp))) 214 x) 215 216 (defun atom$fp (x) 217 (cond (DynTraceFlg (IncrSize 'atom$fp (size x)) (IncrTimes 'atom$fp))) 218 (cond ((atom x) 'T) 219 (t 'F))) 220 221 (defun null$fp (x) 222 (cond (DynTraceFlg (IncrSize 'null$fp (size x)) (IncrTimes 'null$fp))) 223 (cond ((null x) 'T) 224 (t 'F))) 225 226 (defun reverse$fp (x) 227 (cond (DynTraceFlg (IncrSize 'reverse$fp (size x)) (IncrTimes 'reverse$fp))) 228 (cond ((null x) x) 229 ((listp x) (reverse x)) 230 (t (bottom)))) 231 232 (defun lpair$ (x) 233 (cond ((or (undefp x) (not (listp x))) nil) 234 (t 235 (setq y_l (car x)) 236 (setq z_l (cdr x)) 237 (cond ((null z_l) t) 238 (t (cond ((or (not (listp z_l)) (not (onep (length z_l)))) nil) 239 (t (listp (setq z_l (car z_l)))))))))) 240 241 (defun rpair$ (x) 242 (cond ((or (undefp x) (not (listp x))) nil) 243 (t 244 (setq y_l (car x)) 245 (setq z_l (cdr x)) 246 (cond ((null y_l) t) 247 (t (cond ((not (listp y_l)) nil) 248 (t (setq z_l (car z_l)) t))))))) 249 250 251 (defun distl$fp (x) 252 (let ((y_l nil) (z_l nil)) 253 (cond ((lpair$ x) 254 (cond (DynTraceFlg 255 (IncrSize 'distl$fp (size z_l)) (IncrTimes 'distl$fp))) 256 (mapcar '(lambda (u) (list y_l u)) z_l)) 257 (t (bottom))))) 258 259 (defun distr$fp (x) 260 (let ((y_l nil) (z_l nil)) 261 (cond ((rpair$ x) 262 (cond (DynTraceFlg 263 (IncrSize 'distr$fp (size y_l)) (IncrTimes 'distr$fp))) 264 (mapcar '(lambda (u) (list u z_l)) y_l)) 265 (t (bottom))))) 266 267 268 (defun length$fp (x) 269 (cond (DynTraceFlg (IncrSize 'length$fp (size x)) (IncrTimes 'length$fp))) 270 (cond ((listp x) (length x)) 271 (t (bottom)))) 272 273 (defun apndl$fp (x) 274 (cond ((and (dtpr x) (eq 2 (length x)) (listp (cadr x))) 275 (cond (DynTraceFlg 276 (IncrSize 'apndl$fp (size (cadr x))) (IncrTimes 'apndl$fp))) 277 (cons (car x) (cadr x))) 278 (t (bottom)))) 279 280 281 (defun apndr$fp (x) 282 (cond ((and (dtpr x) (eq 2 (length x)) (listp (car x))) 283 (cond (DynTraceFlg 284 (IncrSize 'apndr$fp (size (car x))) (IncrTimes 'apndr$fp))) 285 (append (car x) (cdr x))) 286 (t (bottom)))) 287 288 289 (defun rotl$fp (x) 290 (cond (DynTraceFlg (IncrSize 'rotl$fp (size x)) (IncrTimes 'rotl$fp))) 291 (cond ((null x) x) 292 ((listp x) (cond ((onep (length x)) x) 293 (t (append (cdr x) (list (car x)))))) 294 (t (bottom)))) 295 296 (defun rotr$fp (x) 297 (cond (DynTraceFlg (IncrSize 'rotr$fp (size x)) (IncrTimes 'rotr$fp))) 298 (cond ((null x) x) 299 ((listp x) (cond ((onep (length x)) x) 300 (t (reverse (rotl$fp (reverse x)))))) 301 (t (bottom)))) 302 303 304 (defun trans$fp (x) 305 (If (and (listp x) (allLists x)) 306 then (If (allNulls x) 307 then 308 (cond (DynTraceFlg 309 (IncrSize 'trans$fp (size x)) 310 (IncrTimes 'trans$fp))) 311 nil 312 313 else 314 (cond (DynTraceFlg 315 (IncrSize 'trans$fp 316 (+ (size (car x)) 317 (size (cadr x)))) (IncrTimes 'trans$fp))) 318 319 (do ((a x (cdr a)) 320 (f (length (car x)))) 321 ((null a) (trnspz x)) 322 (If (or (not (listp (car a))) (not (eq f (length (car a))))) 323 then (bottom)))) 324 else 325 326 (bottom))) 327 328 (defun allNulls (x) 329 (do ((a x (cdr a))) 330 ((null a) t) 331 (If (car a) then (return nil)))) 332 333 (defun allLists (x) 334 (do ((a x (cdr a))) 335 ((null a) t) 336 (If (not (dtpr (car a))) then (return nil)))) 337 338 339 (defun trnspz (l) 340 (do 341 ((h (emptyHeader (length (car l)))) 342 (v l (cdr v))) 343 ((null v) (mapcar 'car h)) 344 (mapcar #'(lambda (x y) (tconc x y)) h (car v)))) 345 346 347 (defun emptyHeader (n) 348 (do 349 ((r nil) 350 (c n (1- c))) 351 ((= c 0) r) 352 (setq r (cons (ncons nil) r)))) 353 354 355 (defun iota$fp (x) 356 (cond (DynTraceFlg (IncrTimes 'iota$fp))) 357 (cond ((undefp x) x) 358 ((listp x) (bottom)) 359 ((not (fixp x)) (bottom)) 360 ((lessp x 0) (bottom)) 361 ((zerop x) nil) 362 (t 363 (do ((z x (1- z)) 364 (rslt nil)) 365 ((zerop z) rslt) 366 (setq rslt (cons z rslt)))))) 367 368 ; this is the stuff that was added by dorab patel to make this have 369 ; the same functions as David Lahti's interpreter 370 371 372 ;; Modified by SBB to accept nil as a valid input 373 374 (defun last$fp (x) 375 (cond (DynTraceFlg (IncrSize 'last$fp (size x)) (IncrTimes 'last$fp))) 376 (cond ((null x) nil) 377 ((listp x) (car (last x))) 378 (t (bottom)))) 379 380 ;; Added by SBB 381 382 (defun first$fp (x) 383 (If DynTraceFlg then (IncrSize 'first$fp (size x)) (IncrTimes 'first$fp)) 384 (If (not (listp x)) then (bottom) 385 else (car x))) 386 387 (defun front$fp (x) 388 (cond (DynTraceFlg (IncrSize 'front$fp (size x)) (IncrTimes 'front$fp))) 389 (cond ((null x) (bottom)) 390 ((listp x) (reverse (cdr (reverse x)))) 391 (t (bottom)))) 392 393 (defun pick$fp (sAndX) 394 (let ((s (car sAndX)) 395 (x (cadr sAndX))) 396 (If (or (not (fixp s)) (zerop s) (cddr sAndX)) then (bottom) 397 else 398 399 (progn 400 (cond (DynTraceFlg 401 (IncrTimes 'select$fp) 402 (IncrSize 'select$fp (size x)))) 403 404 (cond ((not (listp x)) (bottom)) 405 ((plusp s) 406 (If (greaterp s (length x)) then (bottom) 407 else (nthelem s x))) 408 ((minusp s) 409 (let ((len (length x))) 410 (If (greaterp (absval s) len) then (bottom) 411 else (nthelem (plus len 1 s) x))))))))) 412 413 414 (defun concat$fp (x) 415 (cond (DynTraceFlg (IncrSize 'concat$fp (size x)) (IncrTimes 'concat$fp))) 416 417 (If (listp x) 418 then 419 (do ((a x (cdr a)) 420 (y (copy x) (cdr y)) 421 (rslt (ncons nil))) 422 ((null a) (car rslt)) 423 (If (not (listp (car a))) then (bottom)) 424 425 (lconc rslt (car y))) 426 427 else (bottom))) 428 429 430 (defun pair$fp (x) 431 (cond (DynTraceFlg (IncrSize 'pair$fp (size x)) (IncrTimes 'pair$fp))) 432 (cond ((not (listp x)) (bottom)) 433 ((null x) (bottom)) 434 (t (do ((count 0 (add count 2)) ; set local vars 435 (max (length x)) 436 (ret (ncons nil))) 437 ((not (lessp count max)) (car ret)) ; return car of tconc struc 438 (cond ((equal (diff max count) 1) ; if only one element left 439 (tconc ret (list (car x)))) 440 (t (tconc ret (list (car x) (cadr x))) 441 (setq x (cddr x)))))))) 442 443 444 (defun split$fp (x) 445 (cond (DynTraceFlg (IncrSize 'split$fp (size x)) (IncrTimes 'split$fp))) 446 (cond ((not (listp x)) (bottom)) 447 ((null x) (bottom)) 448 ((eq (length x) 1) (list x nil)) 449 (t 450 (do ((count 1 (add1 count)) 451 (mid (fix (plus 0.5 (quotient (length x) 2.0)))) 452 (ret nil)) 453 ((greaterp count mid) (cons (nreverse ret) (list x))) 454 (setq ret (cons (car x) ret)) 455 (setq x (cdr x)))))) 456 457 458 ; Library functions: sin, asin, cos, acos, log, exp, mod 459 460 (defun sin$fp (x) 461 (cond (DynTraceFlg (IncrTimes 'sin$fp))) 462 (cond ((numberp x) (sin x)) 463 (t (bottom)))) 464 465 (defun asin$fp (x) 466 (cond (DynTraceFlg (IncrTimes 'asin$fp))) 467 (cond ((and (numberp x) (not (greaterp (abs x) 1.0))) (asin x)) 468 (t (bottom)))) 469 470 (defun cos$fp (x) 471 (cond (DynTraceFlg (IncrTimes 'cos$fp))) 472 (cond ((numberp x) (cos x)) 473 (t (bottom)))) 474 475 (defun acos$fp (x) 476 (cond (DynTraceFlg (IncrTimes 'acos$fp))) 477 (cond ((and (numberp x) (not (greaterp (abs x) 1.0))) (acos x)) 478 (t (bottom)))) 479 480 (defun log$fp (x) 481 (cond (DynTraceFlg (IncrTimes 'log$fp))) 482 (cond ((and (numberp x) (not (minusp x))) (log x)) 483 (t (bottom)))) 484 485 (defun exp$fp (x) 486 (cond (DynTraceFlg (IncrTimes 'exp$fp))) 487 (cond ((numberp x) (exp x)) 488 (t (bottom)))) 489 490 (defun mod$fp (x) 491 (cond (DynTraceFlg (IncrTimes 'mod$fp))) 492 (cond ((ok_pair x 'numberp) (mod (car x) (cadr x))) 493 (t (bottom)))) 494 495 496 ;; Tree insert function 497 498 499 (defun treeIns$fp (fn x) 500 (If (not (listp x)) then (bottom) 501 else 502 (If (null x) then (unitTreeInsert fn) 503 else 504 (let ((len (length x))) 505 (If (onep len) then (car x) 506 else 507 (If (twop len) then (funcall fn x ) 508 else (treeInsWithLen fn x len))))))) 509 510 511 (defun treeInsWithLen (fn x len) 512 (let* ((r1 (copy x)) 513 (nLen (fix (plus 0.5 (quotient len 2.0)))) 514 (p (Cnth r1 nLen)) 515 (r2 (cdr p))) 516 (rplacd p nil) 517 (let ((saveLevel level)) 518 (setq level (1+ level)) 519 (let ((R1 (treeIns fn r1 nLen))) 520 (setq level (1+ saveLevel)) 521 (let ((R2 (treeIns fn r2 (diff len nLen)))) 522 (setq level saveLevel) 523 (funcall fn `(,R1 ,R2))))))) 524