![[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] / 42BSD / ucb / fp|
Return to primFp.l CVS log | Up to [CSRG BSD Unix] / 42BSD / ucb / fp |
1.1 root 1: (setq SCCS-primFp.l "@(#)primFp.l 1.3 5/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)))))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.