; FP interpreter/compiler
; Copyright (c) 1982 Scott B. Baden
; Copyright (c) 1982 Regents of the University of California.
; All rights reserved. The Berkeley software License Agreement
; specifies the terms and conditions for redistribution.
(setq SCCS-primFp.l "@(#)primFp.l 5.1 (Berkeley) %G%")
; FP interpreter/compiler
(declare (special y_l z_l)
(localf ok_pair ok_eqpair rpair$ lpair$ trnspz allNulls
allLists emptyHeader treeInsWithLen))
(cond (DynTraceFlg (IncrTimes 'plus$fp)))
(cond ((ok_pair x 'numberp) (plus (car x) (cadr x)))
(defun (u-fnc plus$fp) nil
(cond (DynTraceFlg (IncrTimes 'sub$fp)))
(cond ((ok_pair x 'numberp) (diff (car x) (cadr x)))
(defun (u-fnc sub$fp) nil
(cond (DynTraceFlg (IncrTimes 'times$fp)))
(cond ((ok_pair x 'numberp) (product (car x) (cadr x)))
(defun (u-fnc times$fp) nil
(cond (DynTraceFlg (IncrTimes 'div$fp)))
(cond ((ok_pair x 'numberp)
(cond ((not (zerop (cadr x)))
(quotient (car x) (cadr x)))
(defun (u-fnc div$fp) nil
; logical functions, and or xor not
(cond (DynTraceFlg (IncrTimes 'and$fp)))
(cond ((ok_pair x 'boolp)
(defun (u-fnc and$fp) nil
(cond (DynTraceFlg (IncrTimes 'or$fp)))
(cond ((ok_pair x 'boolp)
(cond (DynTraceFlg (IncrTimes 'xor$fp)))
(cond ((ok_pair x 'boolp)
(cond ((or (and (eq p 'T) (eq q 'T))
(and (eq p 'F) (eq q 'F)))
(defun (u-fnc xor$fp) nil
(cond (DynTraceFlg (IncrTimes 'not$fp)))
(cond ((not (atom x)) (bottom))
((boolp x) (cond ((eq x 'T) 'F) (t 'T)))
; relational operators, < <= = >= > ~=
(cond (DynTraceFlg (IncrTimes 'lt$fp)))
(cond ((ok_pair x 'numberp)
(cond ((lessp (car x) (cadr x)) 'T)
(cond (DynTraceFlg (IncrTimes 'le$fp)))
(cond ((ok_pair x 'numberp)
(cond ((not (greaterp (car x) (cadr x))) 'T)
(cond (DynTraceFlg (IncrTimes 'eq$fp)))
(cond ((equal (car x) (cadr x)) 'T)
(cond (DynTraceFlg (IncrTimes 'ge$fp)))
(cond ((ok_pair x 'numberp)
(cond ((not (lessp (car x) (cadr x))) 'T)
(cond (DynTraceFlg (IncrTimes 'gt$fp)))
(cond ((ok_pair x 'numberp)
(cond ((greaterp (car x) (cadr x)) 'T)
(cond (DynTraceFlg (IncrTimes 'ne$fp)))
(cond ((not (equal (car x) (cadr x))) 'T)
; check arguments for eq and ne
(cond ((eq (length x) 2) t)))))
; check arguments for binary arithmetics/logicals
((and (atom (car x)) (atom (cadr x)))
(cond ((and (funcall typ (car x))
(funcall typ (cadr x))) t)))))))))
; check if a variable is boolean, 'T' or 'F'
(cond (DynTraceFlg (IncrSize 'tl$fp (size x)) (IncrTimes 'tl$fp)))
(cond ((atom x) (bottom))
(cond (DynTraceFlg (IncrSize 'tlr$fp (size x)) (IncrTimes 'tlr$fp)))
(t (reverse (cdr (reverse x))))))
; this function is just like id$fp execept it also prints its
; argument on the stdout. It is meant to be used only for debuging.
(cond (DynTraceFlg (IncrSize 'id$fp (size x)) (IncrTimes 'id$fp)))
(cond (DynTraceFlg (IncrSize 'atom$fp (size x)) (IncrTimes 'atom$fp)))
(cond (DynTraceFlg (IncrSize 'null$fp (size x)) (IncrTimes 'null$fp)))
(cond (DynTraceFlg (IncrSize 'reverse$fp (size x)) (IncrTimes 'reverse$fp)))
(cond ((or (undefp x) (not (listp x))) nil)
(t (cond ((or (not (listp z_l)) (not (onep (length z_l)))) nil)
(t (listp (setq z_l (car z_l))))))))))
(cond ((or (undefp x) (not (listp x))) nil)
(t (cond ((not (listp y_l)) nil)
(t (setq z_l (car z_l)) t)))))))
(let ((y_l nil) (z_l nil))
(IncrSize 'distl$fp (size z_l)) (IncrTimes 'distl$fp)))
(mapcar '(lambda (u) (list y_l u)) z_l))
(let ((y_l nil) (z_l nil))
(IncrSize 'distr$fp (size y_l)) (IncrTimes 'distr$fp)))
(mapcar '(lambda (u) (list u z_l)) y_l))
(cond (DynTraceFlg (IncrSize 'length$fp (size x)) (IncrTimes 'length$fp)))
(cond ((listp x) (length x))
(cond ((and (dtpr x) (eq 2 (length x)) (listp (cadr x)))
(IncrSize 'apndl$fp (size (cadr x))) (IncrTimes 'apndl$fp)))
(cond ((and (dtpr x) (eq 2 (length x)) (listp (car x)))
(IncrSize 'apndr$fp (size (car x))) (IncrTimes 'apndr$fp)))
(append (car x) (cdr x)))
(cond (DynTraceFlg (IncrSize 'rotl$fp (size x)) (IncrTimes 'rotl$fp)))
((listp x) (cond ((onep (length x)) x)
(t (append (cdr x) (list (car x))))))
(cond (DynTraceFlg (IncrSize 'rotr$fp (size x)) (IncrTimes 'rotr$fp)))
((listp x) (cond ((onep (length x)) x)
(t (reverse (rotl$fp (reverse x))))))
(If (and (listp x) (allLists x))
(IncrSize 'trans$fp (size x))
(size (cadr x)))) (IncrTimes 'trans$fp)))
(If (or (not (listp (car a))) (not (eq f (length (car a)))))
(If (car a) then (return nil))))
(If (not (dtpr (car a))) then (return nil))))
((h (emptyHeader (length (car l))))
((null v) (mapcar 'car h))
(mapcar #'(lambda (x y) (tconc x y)) h (car v))))
(setq r (cons (ncons nil) r))))
(cond (DynTraceFlg (IncrTimes 'iota$fp)))
((not (fixp x)) (bottom))
(setq rslt (cons z rslt))))))
; this is the stuff that was added by dorab patel to make this have
; the same functions as David Lahti's interpreter
;; Modified by SBB to accept nil as a valid input
(cond (DynTraceFlg (IncrSize 'last$fp (size x)) (IncrTimes 'last$fp)))
((listp x) (car (last x)))
(If DynTraceFlg then (IncrSize 'first$fp (size x)) (IncrTimes 'first$fp))
(If (not (listp x)) then (bottom)
(cond (DynTraceFlg (IncrSize 'front$fp (size x)) (IncrTimes 'front$fp)))
(cond ((null x) (bottom))
((listp x) (reverse (cdr (reverse x))))
(If (or (not (fixp s)) (zerop s) (cddr sAndX)) then (bottom)
(IncrSize 'select$fp (size x))))
(cond ((not (listp x)) (bottom))
(If (greaterp s (length x)) then (bottom)
(If (greaterp (absval s) len) then (bottom)
else (nthelem (plus len 1 s) x)))))))))
(cond (DynTraceFlg (IncrSize 'concat$fp (size x)) (IncrTimes 'concat$fp)))
(If (not (listp (car a))) then (bottom))
(cond (DynTraceFlg (IncrSize 'pair$fp (size x)) (IncrTimes 'pair$fp)))
(cond ((not (listp x)) (bottom))
(t (do ((count 0 (add count 2)) ; set local vars
((not (lessp count max)) (car ret)) ; return car of tconc struc
(cond ((equal (diff max count) 1) ; if only one element left
(tconc ret (list (car x))))
(t (tconc ret (list (car x) (cadr x)))
(cond (DynTraceFlg (IncrSize 'split$fp (size x)) (IncrTimes 'split$fp)))
(cond ((not (listp x)) (bottom))
((eq (length x) 1) (list x nil))
(do ((count 1 (add1 count))
(mid (fix (plus 0.5 (quotient (length x) 2.0))))
((greaterp count mid) (cons (nreverse ret) (list x)))
(setq ret (cons (car x) ret))
; Library functions: sin, asin, cos, acos, log, exp, mod
(cond (DynTraceFlg (IncrTimes 'sin$fp)))
(cond ((numberp x) (sin x))
(cond (DynTraceFlg (IncrTimes 'asin$fp)))
(cond ((and (numberp x) (not (greaterp (abs x) 1.0))) (asin x))
(cond (DynTraceFlg (IncrTimes 'cos$fp)))
(cond ((numberp x) (cos x))
(cond (DynTraceFlg (IncrTimes 'acos$fp)))
(cond ((and (numberp x) (not (greaterp (abs x) 1.0))) (acos x))
(cond (DynTraceFlg (IncrTimes 'log$fp)))
(cond ((and (numberp x) (not (minusp x))) (log x))
(cond (DynTraceFlg (IncrTimes 'exp$fp)))
(cond ((numberp x) (exp x))
(cond (DynTraceFlg (IncrTimes 'mod$fp)))
(cond ((ok_pair x 'numberp) (mod (car x) (cadr x)))
(If (not (listp x)) then (bottom)
(If (null x) then (unitTreeInsert fn)
(If (onep len) then (car x)
(If (twop len) then (funcall fn x )
else (treeInsWithLen fn x len)))))))
(defun treeInsWithLen (fn x len)
(nLen (fix (plus 0.5 (quotient len 2.0))))
(let ((R1 (treeIns fn r1 nLen)))
(setq level (1+ saveLevel))
(let ((R2 (treeIns fn r2 (diff len nLen))))
(funcall fn `(,R1 ,R2)))))))