![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to complrc.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 3BSD / cmd / liszt|
Return to complrc.l CVS log | Up to [CSRG BSD Unix] / 3BSD / cmd / liszt |
1.1 root 1: ;--- file : complrc.l
2: (include "compmacs.l")
3:
4: (declare (special w-vars w-labs w-ret w-name w-bv w-atmt cm-alv v-cnt))
5: (def $pr$ (macro (x) `(patom ,(cadr x) compout)))
6:
7: (def put
8: (macro (x)
9: ((lambda (atm prp arg)
10: `(progn (putprop ,atm ,arg ,prp) ,atm))
11: (cadr x) (caddr x) (cadddr x))))
12:
13: (def f-if
14: (lambda (v-l v-r v-j v-t)
15: (cond ((eq (caar v-l) 't)
16: (cond ((null (cdar v-l)) (f-exp t v-r v-t))
17: (t (f-seq (cdar v-l) v-r v-t))))
18: (t (prog (v-tr v-i v-dv)
19: (setq v-tr (f-reg nil))
20: (setq v-dv 'amb)
21: (cond ((null (cdr v-l))
22: (setq v-tr v-r)
23: (cond ((null (cdar v-l)) (go loop2)))
24: (setq v-dv nil)
25: (setq v-i (cadr v-j)))
26: ((null (cdar v-l))
27: (setq v-tr v-r)
28: (setq v-t (f-if (cdr v-l) v-r v-j v-t))
29: (setq v-t (f-addi (list 'true (cadr v-j) t)
30: v-t))
31: (go loop1))
32: (t (setq v-t (f-leap (f-if (cdr v-l)
33: v-r
34: v-j
35: v-t)))
36: (setq v-t (f-addi v-j v-t))
37: (setq v-i (cadr s-inst))))
38: (setq v-t (f-seq (cdar v-l) v-r v-t))
39: (setq v-t (f-addi (list 'false v-i v-dv) v-t))
40: loop1
41: (setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t))
42: loop2
43: (return (f-exp (caar v-l) v-tr v-t)))))))
44: ;--- f-seqp - v-l : sequence of s-expressions and labels to evaluate
45: ; - v-r : psreg in which to store the final result
46: ; - v-t : tail.
47: ; This will do the top level of prog bodies
48: ;
49: (def f-seqp
50: (lambda (v-l v-r v-t)
51: (do ((l (reverse v-l) (cdr l))
52: (newreg v-r)
53: (reg v-r newreg))
54: ((null l) v-t)
55: (cond ((symbolp (car l))
56: (setq v-t (f-labl v-t (car l))))
57: (t (setq v-t (f-exp (car l) reg v-t))
58: (setq newreg (Gensym nil)))))))
59:
60: ;--- f-seq - v-l : sequence of s-expressions to evaluate
61: ; - v-r : psreg in which to store the final result
62: ; - v-t : tail
63: ;
64: ; This generates intermediate codes to calculate the s-expressions
65: ; in v-l. This does not look for labels.
66: ;
67: (def f-seq
68: (lambda (v-l v-r v-t)
69: (do ((l (reverse v-l) (cdr l))
70: (reg v-r (Gensym nil)))
71: ((null l) v-t)
72: (setq v-t (f-exp (car l) reg v-t)))))
73:
74: ;--- f-pusha - v-l : list of forms to evaluate and push on stack
75: ; - v-r : register to place result of last expr in
76: ; - v-t : tail
77: ; emits code to to evaluate and push forms on the stack.
78: (def f-pusha
79: (lambda (v-l v-r v-t)
80: (cond ((null v-l) v-t)
81: (t (do ((ll (reverse v-l) (cdr ll))
82: (reg v-r (Gensym nil))
83: (res v-t
84: (f-exp (car ll)
85: reg
86: (f-addi `(push ,(f-use reg)) res))))
87: ((null ll) res))))))
88:
89: ;--- f-iter - v-e : list of expression to evaluate
90: ; - v-v : list of variables those expressions will be bound to
91: ; This checks of the given expressions can be bound to the given
92: ; variables with no conflicts. This is determining if tail
93: ; merging is possible were we replace recursion by iteration.
94: ;
95: (def f-iter
96: (lambda (v-e v-v)
97: (prog (v-y w-vars)
98:
99: loop
100: (cond ((null v-e) (return t))
101: ((null v-v) (go bad))
102: ((ifflag (setq v-y (car v-v)) x-spec) (go bad))
103: ((equal (car v-e) v-y) (go usable))
104: (t (go check)))
105: next
106: (setq w-vars (cons v-y w-vars))
107: usable
108: (setq v-e (cdr v-e))
109: (setq v-v (cdr v-v))
110: (go loop)
111: check
112: (cond ((f-nice (car v-e)) (go next)))
113: bad
114: (return nil))))
115:
116: (def f-nice
117: (lambda (v-e)
118: (cond ((atom v-e) (not (member v-e w-vars)))
119: ((atom (car v-e))
120: (cond ((eq (car v-e) 'quote) t)
121: ((ifflag (car v-e) x-dont) nil)
122: (t (f-all v-e 'f-nice))))
123: (t (f-all v-e 'f-nice)))))
124:
125: ;--- f-all - v-l : list
126: ; - v-f : function
127: ; mapc function v-f over v-l as long as the result is non nil
128: ;
129: (def f-all
130: (lambda (v-l v-f)
131: (cond ((null v-l) t)
132: ((funcall v-f (car v-l)) (f-all (cdr v-l) v-f))
133: (t nil))))
134:
135: (def f-make
136: (lambda (v-r v-v)
137: (put v-r x-reg v-v)))
138:
139: ;--- f-leap - v-t : tail
140: ; We generate and place in global variable s-inst an itermediate
141: ; instructin which will jump to the current top location in v-t.
142: ; If there is not a label on top of v-t, one is added.
143: ;
144: (def f-leap
145: (lambda (v-t)
146: (cond ((not (setq s-inst (get (caar v-t) x-leap)))
147: (setq v-t (f-labl v-t nil))
148: (setq s-inst 'go)))
149: (setq s-inst (list s-inst (cadar v-t)))
150: v-t))
151:
152: ;--- f-labl - v-t : tail
153: ; - v-l : real label or nil
154: ; We insure that there is a label on top of v-t. If not we
155: ; create one. If we are given a label, we associate it with
156: ; a created label.
157: ; Labels in v-t are all gensymed and the association is all
158: ; on the property list of the value of w-labs.
159: ; Errors: duplicate labels
160: ;
161: (def f-labl
162: (lambda (v-t v-l)
163: (prog (v-i)
164: (cond ((eq (caar v-t) 'label)
165: (cond (v-l (cond ((setq v-i (get w-labs v-l)))
166: (t (put w-labs v-l (cadar v-t))
167: (return v-t))))
168: (t (return v-t))))
169:
170: ((null v-l) (setq v-i (Gensym nil)))
171: ((setq v-i (get w-labs v-l)))
172: (t (put w-labs v-l (setq v-i (Gensym nil)))))
173: (return (f-addi (list 'label v-i) v-t)))))
174:
175: (def f-test
176: (lambda (v-t)
177: (and (eq (caar v-t) 'minus)
178: (null (caddar v-t)))))
179:
180: (def f-vble
181: (lambda (v-v v-r)
182: (f-use v-r)
183: (cond ((not (symbolp v-v)) v-v)
184: ((null v-v) nil)
185: ((f-con v-v) v-v)
186: ((ifflag v-v x-spec) v-v)
187: ((member v-v w-vars) v-v)
188: (t (setq k-free (cons v-v k-free))
189: (flag v-v x-spec)))))
190:
191: (def f-addi
192: (lambda (v-i v-t)
193: (prog (v-o)
194: (cond ((not (setq v-o (get (car v-i) x-opt))) (go normal))
195: ((setq v-o (funcall v-o v-i v-t)) (return v-o)))
196: normal
197: (return (cons v-i v-t)))))
198:
199: (def f-reg
200: (lambda (v-f)
201: (cond ((numberp v-f) (put (Gensym nil) x-reg v-f))
202: (v-f (flag (Gensym nil) v-f))
203: (t (Gensym nil)))))
204:
205: (def f-con
206: (lambda (v-v)
207: (cond ((ifflag v-v x-spec) nil)
208: (t (ifflag v-v x-con)))))
209:
210: (def f-one
211: (lambda (v-e)
212: (or (atom v-e)
213: (eq (car v-e) 'quote))))
214:
215: (def f-swap
216: (lambda (v-t)
217: (cond ((eq (caar v-t) 'get) (f-swap (cdr v-t)))
218: (t (rplaca (car v-t)
219: (cond ((eq (caar v-t) 'true) 'false)
220: (t 'true)))))
221: v-t))
222:
223: (def f-xval
224: (lambda (v-t v-r)
225: (cond ((or (eq (caar v-t) 'get)
226: (eq (caddar v-t) 'amb)) v-t)
227: (t (f-addi (list 'get (f-use v-r) (caddar v-t)) v-t)))))
228:
229: ;--- f-use - v-r : psreg whose value is being used
230: ; we keep track of the number of times the value of a register is
231: ; used, the count is kept under the indicator x-count in the
232: ; psreg's property list. the count starts at nil, goes to `used'
233: ; and then to `force'. Once the count goes to `force' all gets
234: ; must be done. when the count is used get should look to see
235: ; if the following intermediate code instruction is the one
236: ; using the register and in that case it can merge with that
237: ; instruction
238: ;
239: (def f-use
240: (lambda (v-r)
241: ((lambda (curv)
242: (cond (curv (cond ((not (eq curv 'force))
243: (putprop v-r 'force 'x-count))))
244: (t (putprop v-r 'used 'x-count)))
245: v-r)
246: (get v-r 'x-count))))
247:
248:
249: (def f-chop
250: (lambda (v-t)
251: (cond ((or (eq (caar v-t) 'label)
252: (eq (caar v-t) 'end)) v-t)
253: (t (f-chop (cdr v-t))))))
254:
255: (def f-tfo
256: (lambda (v-i v-t)
257: (cond ((not (f-like v-t '(go label))) nil)
258: ((not (equal (cadr v-i) (cadadr v-t))) nil)
259: (t (rplaca (cdr v-i) (cadar v-t))
260: (f-swap (rplaca v-t v-i))))))
261:
262: (def f-like
263: (lambda (v-t v-p)
264: (cond ((null v-p) t)
265: ((null v-t) nil)
266: ((equal (caar v-t) (car v-p)) (f-like (cdr v-t) (cdr v-p)))
267: (t nil))))
268:
269: (def f-aor
270: (lambda (v-l v-e v-r v-t)
271: (cond ((null v-l)
272: (f-addi (list 'get (f-use v-r) (eq v-e 'and)) v-t))
273: (t (prog (v-j v-dv v-tr v-tr2)
274: (setq v-dv (eq v-e 'or))
275: (setq v-tr v-r)
276: (setq v-tr2 v-r)
277: (setq v-e
278: (cond ((eq v-e 'and) 'false)
279: (t 'true)))
280: (setq v-l (reverse v-l))
281: (cond ((null (cdr v-l)) (go loop))
282: ((and (f-test v-t)
283: (not (eq (caadr v-t) 'get)))
284: (cond ((eq (caddadr v-t) 'amb)
285: (setq v-dv 'amb)
286: (setq v-tr2 (f-reg nil)))
287: ((not (equal (caddadr v-t) v-dv))
288: (setq v-dv 'amb)))
289: (cond ((equal (caadr v-t) v-e)
290: (setq v-j (cadadr v-t))
291: (go loop)))
292: (rplacd (cdr v-t) (f-leap (cddr v-t))))
293: (t (setq v-t (f-leap v-t))))
294: (setq v-j (cadr s-inst))
295: loop
296: (setq v-t (f-exp (car v-l) v-tr v-t))
297: (setq v-tr v-tr2)
298: (cond ((null (setq v-l (cdr v-l))) (return v-t)))
299: (setq v-t (f-addi (list v-e v-j v-dv) v-t))
300: (setq v-t (f-addi (list 'minus (f-use v-tr) nil) v-t))
301: (go loop))))))
302:
303: (def f-repl
304: (lambda (v-e)
305: (cons (ucar (car v-e)) (cdr v-e))))
306:
307: ;this seems out of date, must change to mapconvert
308: (def f-domap
309: (lambda (v-e)
310: (prog (v-x)
311: (cond ((setq v-x (f-chkf (cadr v-e) 4))
312: (return (list (car v-e)
313: (list 'quote v-x)
314: (caddr v-e))))
315: (t (return v-e))))))
316:
317:
318: ;--- mapconvert - access : function to access parts of lists
319: ; - join : function to join results
320: ; - resu : function to apply to result
321: ; - form : mapping form
322: ; This function converts maps to an equivalent do form.
323: ;
324: (def mapconvert
325: (lambda (access join resu form )
326: (prog (vrbls finvar acc accform compform tmp)
327:
328: (setq finvar (Gensym 'X) ; holds result
329:
330: vrbls (maplist '(lambda (arg)
331: ((lambda (temp)
332: (cond ((or resu (cdr arg))
333: `(,temp ,(car arg)
334: (cdr ,temp)))
335: (t `(,temp
336: (setq ,finvar ,(car arg))
337: (cdr ,temp)))))
338: (Gensym 'X)))
339: (cdr form))
340:
341:
342: acc (mapcar '(lambda (tem)
343: (cond (access `(,access ,(car tem)))
344: (t (car tem))))
345: vrbls)
346:
347: accform (cond ((or (atom (setq tmp (car form)))
348: (null (setq tmp (cmacroexpand tmp)))
349: (not (member (car tmp) '(quote function))))
350: `(funcall ,tmp ,@acc))
351: (t `(,(cadr tmp) ,@acc))))
352: (return
353: `((lambda (,finvar)
354: (do ( ,@vrbls)
355: ((null ,(caar vrbls)))
356: ,(cond (join `(setq ,finvar (,join ,accform ,finvar)))
357: (t accform)))
358: ,(cond (resu `(,resu ,finvar))
359: (t finvar)))
360: nil )))))
361: (putprop 'mapc 'f-mapc 'x-spfm)
362: (def f-mapc
363: (lambda (v-e)
364: (mapconvert 'car nil nil (cdr v-e))))
365:
366: (putprop 'mapcar 'f-mapcar 'x-spfm)
367: (def f-mapcar
368: (lambda (v-e)
369: (mapconvert 'car 'cons 'reverse (cdr v-e))))
370:
371: (putprop 'map 'f-map 'x-spfm)
372: (def f-map
373: (lambda (v-e)
374: (mapconvert nil nil nil (cdr v-e))))
375:
376:
377: (putprop 'maplist 'f-maplist 'x-spfm)
378: (def f-maplist
379: (lambda (v-e)
380: (mapconvert nil 'cons 'reverse (cdr v-e))))
381:
382:
383:
384:
385: (def f-initv
386: (lambda (v-l)
387: (mapcar 'car (car v-l))))
388:
389: (def f-inits
390: (lambda (v-l)
391: (mapcar 'cadr (car v-l))))
392:
393: (def f-repv
394: (lambda (v-l)
395: (prog (v-x)
396: (setq v-l (car v-l))
397: lp
398: (cond ((null v-l) (return (reverse v-x))))
399: (cond ((cddar v-l) (setq v-x (cons (caar v-l) v-x))))
400: (setq v-l (cdr v-l))
401: (go lp))))
402:
403: (def f-reps
404: (lambda (v-l)
405: (prog (v-x v-y)
406: (setq v-l (car v-l))
407: lp
408: (cond ((null v-l) (return (reverse v-x))))
409: (cond ((cddar v-l)
410: (setq v-y (caddar v-l)) (setq v-x (cons v-y v-x))))
411: (setq v-l (cdr v-l))
412: (go lp))))
413:
414: (def f-endtest
415: (lambda (v-l)
416: (caadr v-l)))
417:
418: (def f-endbody
419: (lambda (v-l)
420: (cdadr v-l)))
421:
422: (def f-dobody
423: (lambda (v-l)
424: (cddr v-l)))
425:
426:
427: (putprop 'do 'f-do 'x-spf)
428:
429: (def f-do
430: (lambda (v-l v-r v-t)
431: (prog (v-init v-initv v-rep v-repv v-loop v-outl v-retl)
432: (cond ((and (car v-l) (atom (car v-l))) ; look for old do
433: (setq v-l (olddo-to-newdo v-l))))
434: (setq v-initv (f-initv v-l)
435: v-init (f-inits v-l)
436: v-repv (f-repv v-l)
437: v-rep (f-reps v-l)
438: v-retl (Gensym nil)
439: v-loop (Gensym nil)
440: v-outl (Gensym nil))
441: (w-save)
442: (return
443: (f-pusha v-init v-r
444: (prog (w-ret w-labs tmp)
445: (setq w-ret `(,v-r . (go ,v-retl)))
446: (setq w-labs (Gensym nil))
447: (setq tmp
448: `((begin ,(length v-initv))
449: ,@(mapcar '(lambda (arg) (setq w-locs
450: (cons arg w-locs))
451: `(bind ,arg))
452: v-initv)
453: (label ,v-loop)
454: ,@(f-exp (f-endtest v-l) v-r
455: `((minus ,v-r nil)
456: (true ,v-outl nil)
457: ,@(f-seqp (f-dobody v-l) v-r
458: (f-pusha v-rep v-r
459: `((dopop ,v-repv)
460: (go ,v-loop)
461: (label ,v-outl)
462: ,@(f-seq (f-endbody v-l) v-r
463: `((end ,v-retl)
464: ,@v-t)))))))))
465: (w-unsave)
466: (return tmp)))))))
467:
468: (def olddo-to-newdo
469: (lambda (v-l)
470: `(((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
471: (,(cadddr v-l) nil)
472: ,@(cddddr v-l))))
473:
474: (putprop 'cond 'f-cond 'x-spf)
475:
476: (def f-cond
477: (lambda (v-l v-r v-t)
478: (setq v-t (f-leap v-t))
479: (f-if v-l v-r s-inst v-t)))
480:
481: (putprop 'quote 'f-quote 'x-spf)
482:
483: (def f-quote
484: (lambda (v-l v-r v-t)
485: (f-addi (list 'get v-r (cons 'quote v-l)) v-t)))
486:
487: (putprop 'prog 'f-prog 'x-spf)
488:
489:
490:
491:
492: (putprop 'setq 'f-setq 'x-spf)
493:
494: (def f-setq
495: (lambda (v-l v-r v-t)
496: (cond ((null (car v-l)) v-t))
497: (do ((ll (reverse v-l) (cddr ll))
498: (reg v-r (Gensym nil)))
499: ((null ll) v-t)
500: (setq v-t (f-exp (car ll)
501: reg
502: `((set ,(f-use reg) ,(g-specialchk (cadr ll)))
503: ,@v-t))))))
504:
505:
506: (putprop 'rplaca 'f-rplaca 'x-spf)
507:
508:
509: (def f-rplaca
510: (lambda (v-l v-r v-t)
511: (cond ((f-one (cadr v-l))
512: (f-exp (car v-l)
513: v-r
514: (f-exp (cadr v-l)
515: (setq v-l (Gensym nil))
516: (f-addi (list 'seta (f-use v-r) (f-use v-l))
517: v-t))))
518: (t (f-pusha v-l
519: (Gensym nil)
520: (f-addi (list 'setas v-r) v-t))))))
521:
522: (putprop 'rplacd 'f-rplacd 'x-spf)
523:
524:
525: (def f-rplacd
526: (lambda (v-l v-r v-t)
527: (cond ((f-one (cadr v-l))
528: (f-exp (car v-l)
529: v-r
530: (f-exp (cadr v-l)
531: (setq v-l (Gensym nil))
532: (f-addi (list 'setd (f-use v-r) (f-use v-l)) v-t))))
533: (t (f-pusha v-l
534: (Gensym nil)
535: (f-addi (list 'setds (f-use v-r)) v-t))))))
536:
537: (putprop 'go 'f-go 'x-spf)
538:
539: ;--- f-go - v-l : label to go to
540: ; - v-r : not used
541: ; - v-t : tail
542: ; We allow non local go to's, however the goto must go no further than the
543: ; first inclosing prog.
544: ; f-go works by finding the w-labs associated with the first enclosing prog,
545: ; and keeping track of the number of binding levels which must be traversed
546: ; to get to that prog.o
547: ; when it finds the correct w-labs, it checks if this label has been seen yet,
548: ; if not iit assigns it a gensymed symbol.
549: ; if a binding level must be traversed, we eimit
550: ; (unbind n) n is number of binding levels to traverse,
551: ; 0 means current level only.
552: ; (go gensymedlabl)
553: ;
554: ; if this is a local goto only the (go gensymedlabl) will be emitted.
555: ;
556: (def f-go
557: (lambda (v-l v-r v-t)
558: (prog (use-labs levels)
559: (setq v-l (car v-l))
560: (setq use-labs
561: (cond (w-ret w-labs)
562: (t (do ((ll w-save (cdr ll))
563: (count 0 (add1 count)))
564: ((null ll)
565: (comp-err " go not within prog"))
566: (cond ((caar ll)
567: (setq levels count)
568: (comp-warn " non-local go used")
569: (return (cadar ll))))))))
570:
571: (cond ((not (setq v-r (get use-labs v-l)))
572: (put use-labs v-l (setq v-r (Gensym nil)))))
573: (setq v-t (f-addi (list 'go v-r) v-t))
574: (cond (levels (setq v-t (f-addi `(unbind ,levels) v-t))))
575: (return v-t))))
576:
577: (putprop 'lambda 'f-lambda 'x-spf)
578:
579: ;--- f-lambda - ?? how is this routine called, certainly this isnt the
580: ; same as ((lambda (n) form) arg)
581: ;
582:
583: (putprop 'and 'f-and 'x-spf)
584:
585: (def f-and
586: (lambda (v-l v-r v-t)
587: (f-aor v-l 'and v-r v-t)))
588:
589: (putprop 'or 'f-or 'x-spf)
590:
591: (def f-or
592: (lambda (v-l v-r v-t)
593: (f-aor v-l 'or v-r v-t)))
594:
595:
596:
597: (putprop 'prog2 'prog2toprog 'x-spfm)
598:
599:
600: ;--- prog2toprog - v-e : prog2 expression
601: ; we convert this (prog2 a b c d e f) to
602: ; (progn a ((lambda (newsim) c d e f newsim) b))
603: ; simple enough.
604: ;
605: (def prog2toprog
606: (lambda (v-e)
607: ((lambda (newsim)
608: `(progn ,(cadr v-e)
609: ((lambda (,newsim)
610: ,@(cdddr v-e)
611: ,newsim)
612: ,(caddr v-e))))
613: (Gensym nil))))
614:
615:
616: (putprop 'progn 'f-seq 'x-spf)
617:
618: (putprop 'return 'f-return 'x-spfn)
619:
620: ;--- f-return - v-l : arg to return, may be nil meaning return nil
621: ; - v-r : psreg in which to store result
622: ; - v-t : tail
623: ; this handles the return statement. While returns should
624: ; occur in progs, this allows for a return inside a context
625: ; which is inside a prog (or do). If this is a simple return
626: ; from prog or do, we have:
627: ; ... code to place to be returned val in v-r
628: ; (go retlb) jump to label at end of prog body
629: ; but before special unbinding
630: ; for non local cases we have
631: ; ... code to place value to be returned into v-r
632: ; (unwind levels) where is levels is the number of enclosing
633: ; contexts (which begin with a (begin xx)) to return
634: ; from.
635: ; (go retlb) then go to the return spot.
636: ;
637: (def f-return
638: (lambda (v-l v-r v-t)
639: (prog (use-ret levels)
640: (setq use-ret
641: (cond (w-ret)
642: (t (do ((ll w-save (cdr ll))
643: (count 0 (add1 count)))
644: ((null ll)
645: (comp-err " return not within a prog"))
646: (cond ((caar ll)
647: (setq levels count)
648: (comp-warn " non local return used")
649: (return (caar ll))))))))
650:
651: (setq v-t (f-addi (cdr use-ret) v-t))
652: (cond (levels (setq v-t (f-addi `(unbind ,levels) v-t))))
653: (return (f-exp (and v-l (car v-l)) (f-use (car use-ret)) v-t)))))
654:
655: (putprop 'null 'f-null 'x-spfn)
656:
657: (def f-null
658: (lambda (v-l v-r v-t)
659: (cond ((f-test v-t)
660: (rplaca (cdar (rplacd v-t (f-xval (f-swap (cdr v-t)) v-r)))
661: (f-use (setq v-r (Gensym nil))))
662: (f-exp (car v-l) v-r v-t)))))
663:
664: (putprop 'not 'f-null 'x-spfn)
665:
666:
667: (def f-type
668: (lambda (v-l v-r v-t v-bits)
669: (cond ((f-test v-t)
670: (setq v-t (f-xval (cdr v-t) v-r))
671: (f-exp (car v-l)
672: (setq v-r (Gensym nil))
673: (f-addi (list 'getype (f-use v-r) v-bits) v-t))))))
674:
675: (putprop 'atom 'f-atom 'x-spfn)
676:
677: (def f-atom
678: (lambda (v-l v-r v-t)
679: (f-type v-l v-r v-t '(0 1 2 4 5 6 7 9 10))))
680:
681: (putprop 'numberp 'f-numberp 'x-spfn)
682:
683: (def f-numberp
684: (lambda (v-l v-r v-t)
685: (f-type v-l v-r v-t '(2 4 9))))
686:
687: (putprop 'symbolp 'f-symbolp 'x-spfn)
688:
689: (def f-symbolp
690: (lambda (v-l v-r v-t)
691: (f-type v-l v-r v-t 1)))
692:
693: (putprop 'dtpr 'f-dtpr 'x-spfn)
694:
695: (def f-dtpr
696: (lambda (v-l v-r v-t)
697: (f-type v-l v-r v-t 3)))
698:
699: (putprop 'bcdp 'f-bcdp 'x-spfn)
700:
701: (def f-bcdp
702: (lambda (v-l v-r v-t)
703: (f-type v-l v-r v-t 5)))
704:
705: (putprop 'stringp 'f-stringp 'x-spfn)
706:
707: (def f-stringp
708: (lambda (v-l v-r v-t)
709: (f-type v-l v-r v-t 0)))
710:
711: (putprop 'type 'f-ty 'x-spfn)
712:
713: (def f-ty
714: (lambda (v-l v-r v-t)
715: (f-exp (car v-l)
716: (setq v-r (Gensym nil))
717: (f-addi (list 'getype (f-use v-r) 'name) v-t))))
718:
719: (putprop 'eq 'f-eq 'x-spfn)
720:
721: (def f-eq
722: (lambda (v-l v-r v-t)
723: (prog (v-r1)
724: (cond ((f-test v-t)
725: (setq v-t (f-xval (cdr v-t) v-r))
726: (cond ((and (f-one (car v-l)) (f-one (cadr v-l)))
727: (return (f-addi (list 'eqv (car v-l) (cadr v-l))
728: v-t))))
729: (return (f-pusha v-l
730: (Gensym nil)
731: (f-addi '(eqs) v-t))))))))
732:
733: (putprop 'cons 'f-repl 'x-spfh)
734:
735: '(putprop 'map 'f-domap 'x-spfh)
736:
737: '(putprop 'mapc 'f-domap 'x-spfh)
738:
739: '(putprop 'mapcar 'f-domap 'x-spfh)
740:
741: '(putprop 'maplist 'f-domap 'x-spfh)
742:
743: (putprop 'zerop 'f-zerop 'x-spfm)
744:
745: (def f-zerop
746: (lambda (v-e)
747: (list 'equal 0 (cadr v-e))))
748:
749: (putprop 'plist 'f-plist 'x-spfm)
750:
751: (def f-plist
752: (lambda (v-e)
753: (list 'car (cadr v-e))))
754:
755: (putprop 'go 'f-xgo 'x-opt)
756:
757: (def f-xgo
758: (lambda (v-i v-t)
759: (setq v-t (f-chop v-t))
760: (cond ((equal (cadr v-i) (cadar v-t)) v-t)
761: (t (cons v-i v-t)))))
762:
763: (putprop 'return 'f-xreturn 'x-opt)
764:
765: (def f-xreturn
766: (lambda (v-i v-t)
767: (cons v-i (f-chop v-t))))
768:
769: (putprop 'repeat 'f-xreturn 'x-opt)
770:
771: (putprop 'false 'f-tfo 'x-opt)
772:
773: (putprop 'true 'f-tfo 'x-opt)
774:
775:
776: (putprop '*catch 'f-*catch 'x-spf)
777:
778:
779: ;--- f-*catch - v-l : list of (tag exp) , tag is evaled, exp is to be run
780: ; - v-r : result register
781: ; - v-t : tail
782: ; This compiles a catch by emiting these intermediate codes:
783: ; ..calculate tag..
784: ; (catchent <gensym> <tag> nil)
785: ; .. code to eval (car v-l) ..
786: ; (catchexit)
787: ; (label <gensym>)
788: ;
789: ; The catchent sets up a catch frame on the c-runtime stack.
790: ; The (car v-l) is evaluated and the result placed in r0 (it must
791: ; be since that is where the value would be thrown). If no throw
792: ; is done, it enters the catchexit which pops our catchframe off
793: ; the stack. If a throw is done it ends up at the label <gensym>
794: ; with the catch frame already popped off.
795: ;
796: (def f-*catch
797: (lambda (v-l v-r v-t)
798: (prog (v-loop v-tag x y z v-nr)
799: (setq v-tag (car v-l))
800: ; we check to make sure we can force v-r to be r0, else
801: ; we must give up.
802: (cond ((and (get v-r 'x-reg)
803: (not (equal (get v-r 'x-reg) 0)))
804: (err '"Can't compile catch correctly"))
805: (t (f-make v-r 0)))
806:
807: (return
808: (f-exp v-tag
809: (setq v-nr (Gensym nil))
810: (f-addi `(catchent ,(setq v-loop (Gensym nil))
811: ,(f-use v-nr)
812: nil)
813: (f-exp (cadr v-l) (f-use v-r)
814: (f-addi `(catchexit)
815: (f-addi `(label ,v-loop) v-t)))))))))
816:
817: (putprop 'errset 'f-errset 'x-spf)
818: ;--- f-errset - v-l : list of (errset form [flag])
819: ; - v-r : place to put result.
820: ; - v-t : tail
821: ;
822: ; This sets up an errset frame. It is different than a catch in
823: ; that the tag is always (ER%all) and the result returned upon
824: ; a regular exit is listified.
825: ; again, we must insure that v-r can be forced to be r0 since
826: ; an err or error will place the result there.
827: ;
828: (def f-errset
829: (lambda (v-l v-r v-t)
830: (prog (v-loop v-tag v-flag v-nr)
831: (cond ((and (get v-r 'x-reg) (not (equal (get v-r 'x-reg) 0)))
832: (err '"Can't compile errset correctly"))
833: (t (f-make v-r 0)))
834:
835: ; flag tells if error message will be reported, t if so.
836: ; t is the default
837: (cond ((cdr v-l) (setq v-flag (cadr v-l)))
838: (t (setq v-flag t)))
839:
840: (return
841: (f-exp v-flag
842: (setq v-nr (Gensym nil))
843: (f-addi `(catchent ,(setq v-loop (Gensym nil))
844: '(ER%all)
845: ,(f-use v-nr))
846: (f-exp (car v-l)
847: v-r
848: `((catchexit)
849: (push ,v-r)
850: (call ,v-r _Lncons 1)
851: (label ,v-loop)
852: ,@v-t))))))))
853:
854:
855:
856:
857: (putprop '*throw 'f-*throw 'x-spf)
858:
859: ;--- f-*throw - v-l : list of (tag exp)
860: ; - v-r : loc to eval exp to
861: ; - v-t : tail
862: ;
863: (def f-*throw
864: (lambda (v-l v-r v-t)
865: (let ((v-nr (Gensym nil)))
866: (f-exp (car v-l)
867: v-nr
868: (f-exp (cadr v-l) v-r
869: (f-addi `(*throw ,(f-use v-r) ,(f-use v-nr)) v-t))))))
870:
871:
872: (putprop 'arg 'f-arg 'x-spf)
873:
874: ;--- f-arg - v-l : list of arg to evaluate
875: ; - v-r : place to store value
876: ; - v-t : tail
877: (def f-arg
878: (lambda (v-l v-r v-t)
879: (f-exp (car v-l) v-r
880: (f-addi `(arg ,(f-use v-r))
881: v-t))))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.