1 (setq SCCS-primFp.l "@(#)primFp.l 1.2 04/29/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 (cond (DynTraceFlg (IncrSize 'pick$fp (size x)) (IncrTimes 'pick$fp))) 397 398 (If (or (not (fixp s)) (zerop s)) then (bottom) 399 else 400 401 (progn 402 (cond (DynTraceFlg 403 (IncrTimes 'select$fp) 404 (IncrSize 'select$fp (size x)))) 405 406 (cond ((not (listp x)) (bottom)) 407 ((plusp s) 408 (If (greaterp s (length x)) then (bottom) 409 else (nthelem s x))) 410 ((minusp s) 411 (let ((len (length x))) 412 (If (greaterp (absval s) len) then (bottom) 413 else (nthelem (plus len 1 s) x))))))))) 414 415 416 417 (defun concat$fp (x) 418 (cond (DynTraceFlg (IncrSize 'concat$fp (size x)) (IncrTimes 'concat$fp))) 419 420 (If (listp x) 421 then 422 (do ((a x (cdr a)) 423 (y (copy x) (cdr y)) 424 (rslt (ncons nil))) 425 ((null a) (car rslt)) 426 (If (not (listp (car a))) then (bottom)) 427 428 (lconc rslt (car y))) 429 430 else (bottom))) 431 432 433 (defun pair$fp (x) 434 (cond (DynTraceFlg (IncrSize 'pair$fp (size x)) (IncrTimes 'pair$fp))) 435 (cond ((not (listp x)) (bottom)) 436 ((null x) (bottom)) 437 (t (do ((count 0 (add count 2)) ; set local vars 438 (max (length x)) 439 (ret (ncons nil))) 440 ((not (lessp count max)) (car ret)) ; return car of tconc struc 441 (cond ((equal (diff max count) 1) ; if only one element left 442 (tconc ret (list (car x)))) 443 (t (tconc ret (list (car x) (cadr x))) 444 (setq x (cddr x)))))))) 445 446 447 (defun split$fp (x) 448 (cond (DynTraceFlg (IncrSize 'split$fp (size x)) (IncrTimes 'split$fp))) 449 (cond ((not (listp x)) (bottom)) 450 ((null x) (bottom)) 451 ((eq (length x) 1) (list x nil)) 452 (t 453 (do ((count 1 (add1 count)) 454 (mid (fix (plus 0.5 (quotient (length x) 2.0)))) 455 (ret nil)) 456 ((greaterp count mid) (cons (nreverse ret) (list x))) 457 (setq ret (cons (car x) ret)) 458 (setq x (cdr x)))))) 459 460 461 ; Library functions: sin, asin, cos, acos, log, exp, mod 462 463 (defun sin$fp (x) 464 (cond (DynTraceFlg (IncrTimes 'sin$fp))) 465 (cond ((numberp x) (sin x)) 466 (t (bottom)))) 467 468 (defun asin$fp (x) 469 (cond (DynTraceFlg (IncrTimes 'asin$fp))) 470 (cond ((and (numberp x) (not (greaterp (abs x) 1.0))) (asin x)) 471 (t (bottom)))) 472 473 (defun cos$fp (x) 474 (cond (DynTraceFlg (IncrTimes 'cos$fp))) 475 (cond ((numberp x) (cos x)) 476 (t (bottom)))) 477 478 (defun acos$fp (x) 479 (cond (DynTraceFlg (IncrTimes 'acos$fp))) 480 (cond ((and (numberp x) (not (greaterp (abs x) 1.0))) (acos x)) 481 (t (bottom)))) 482 483 (defun log$fp (x) 484 (cond (DynTraceFlg (IncrTimes 'log$fp))) 485 (cond ((and (numberp x) (not (minusp x))) (log x)) 486 (t (bottom)))) 487 488 (defun exp$fp (x) 489 (cond (DynTraceFlg (IncrTimes 'exp$fp))) 490 (cond ((numberp x) (exp x)) 491 (t (bottom)))) 492 493 (defun mod$fp (x) 494 (cond (DynTraceFlg (IncrTimes 'mod$fp))) 495 (cond ((ok_pair x 'numberp) (mod (car x) (cadr x))) 496 (t (bottom)))) 497 498 499 ;; Tree insert function 500 501 502 (defun treeIns$fp (fn x) 503 (If (not (listp x)) then (bottom) 504 else 505 (If (null x) then (unitTreeInsert fn) 506 else 507 (let ((len (length x))) 508 (If (onep len) then (car x) 509 else 510 (If (twop len) then (funcall fn x ) 511 else (treeInsWithLen fn x len))))))) 512 513 514 (defun treeInsWithLen (fn x len) 515 (let* ((r1 (copy x)) 516 (nLen (fix (plus 0.5 (quotient len 2.0)))) 517 (p (Cnth r1 nLen)) 518 (r2 (cdr p))) 519 (rplacd p nil) 520 (let ((saveLevel level)) 521 (setq level (1+ level)) 522 (let ((R1 (treeIns fn r1 nLen))) 523 (setq level (1+ saveLevel)) 524 (let ((R2 (treeIns fn r2 (diff len nLen)))) 525 (setq level saveLevel) 526 (funcall fn `(,R1 ,R2))))))) 527