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