![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cadr.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 41BSD / cmd / liszt|
Return to cadr.l CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / liszt |
1.1 root 1:
2:
3: ; l i s z t v 4
4:
5:
6:
7:
8: ; Copyright (c) 1980 , The Regents of the University of California.
9: ; All rights reserved.
10: ; author: j. foderaro
11:
12: ; Section EXPR -- general expression compiler
13:
14: (include "caspecs.l")
15:
16: (eval-when (compile eval)
17: (cond ((not (getd 'If))
18: (fasl 'camacs))))
19:
20: (setq sectioncadrid "@(#)cadr.l 5.4 10/22/80") ; id for SCCS
21:
22: ;--- d-exp :: compile a lisp expression = d-exp =
23: ; v-form : a lisp expression to compile
24: ; returns an IADR which tells where the value was located.
25: ;
26: (defun d-exp (v-form)
27: (prog (first resloc tmp ftyp)
28:
29: begin
30: (If (atom v-form)
31: then (setq tmp (d-loc v-form)) ;locate vrble
32: (If (null g-loc)
33: then (If g-cc then (d-tst tmp))
34: else (d-move tmp g-loc))
35: (d-handlecc)
36: (return tmp)
37:
38: elseif (atom (setq first (car v-form)))
39: then (If (and fl-xref (not (get first g-refseen)))
40: then (Push g-reflst first)
41: (putprop first t g-refseen))
42: (setq ftyp (d-functyp first))
43: (If (eq 'macro ftyp)
44: then (setq v-form (apply first v-form))
45: (go begin)
46: elseif (setq tmp (get first 'fl-exprcc))
47: then (return (funcall tmp))
48: elseif (setq tmp (get first 'fl-exprm))
49: then (setq v-form (funcall tmp))
50: (go begin)
51: elseif (setq tmp (get first 'fl-expr))
52: then (funcall tmp)
53: elseif (setq tmp (or (and (eq 'car first)
54: '( a ))
55: (and (eq 'cdr first)
56: '( d ))
57: (d-cxxr first)))
58: then (return (cc-cxxr (cadr v-form) tmp))
59: elseif (eq 'nlambda ftyp)
60: then (d-callbig first `(',(cdr v-form)))
61: elseif (or (eq 'lambda ftyp) (eq 'lexpr ftyp))
62: then (setq tmp (length v-form))
63:
64: (d-callbig first (cdr v-form)))
65: elseif (eq 'lambda (car first))
66: then (c-lambexp)
67:
68: elseif (or (eq 'quote (car first)) (eq 'function (car first)))
69: then (comp-warn "bizzare function name " (or first))
70: (setq v-form (cons (cadr first) (cdr v-form)))
71: (go begin)
72:
73: else (comp-err "bad expression" (or v-form)))
74:
75: (If (null g-loc)
76: then (If g-cc then (d-tst 'reg))
77: elseif (eq g-loc 'reg)
78: then (If g-cc then (d-tst 'reg))
79: else (d-move 'reg g-loc))
80: (If g-cc then (d-handlecc))))
81:
82: ;--- d-functyp :: return the type of function
83: ; - name : function name
84: ;
85: (defun d-functyp (name)
86: (let (ftyp )
87: (If (atom name) then
88: (If (setq ftyp (getd name))
89: then (If (bcdp ftyp)
90: then (getdisc ftyp)
91: elseif (dtpr ftyp)
92: then (car ftyp))
93: elseif (get name g-functype) thenret
94: else 'lambda)))) ; default is lambda
95:
96:
97: ;--- d-exps :: compile a list of expressions
98: ; - exps : list of expressions
99: ; the last expression is evaluated according to g-loc and g-cc, the others
100: ; are evaluated with g-loc and g-cc nil.
101: ;
102: (defun d-exps (exps)
103: (d-exp (do ((ll exps (cdr ll))
104: (g-loc nil)
105: (g-cc nil)
106: (g-ret nil))
107: ((null (cdr ll)) (car ll))
108: (d-exp (car ll)))))
109:
110:
111: ;--- d-pushargs :: compile and push a list of expressions
112: ; - exps : list of expressions
113: ; compiles and stacks a list of expressions
114: ;
115: (defun d-pushargs (args)
116: (If args then (do ((ll args (cdr ll))
117: (g-loc 'stack)
118: (g-cc nil)
119: (g-ret nil))
120: ((null ll))
121: (d-exp (car ll))
122: (Push g-locs nil)
123: (incr g-loccnt))))
124:
125: ;--- d-cxxr :: split apart a cxxr function name
126: ; - name : a possible cxxr function name
127: ; returns the a's and d's between c and r in reverse order, or else
128: ; returns nil if this is not a cxxr name
129: ;
130: (defun d-cxxr (name)
131: (let ((expl (explodec name)))
132: (If (eq 'c (car expl)) ; must begin with c
133: then (do ((ll (cdr expl) (cdr ll))
134: (tmp)
135: (res))
136: (nil)
137: (setq tmp (car ll))
138: (If (null (cdr ll))
139: then (If (eq 'r tmp) ; must end in r
140: then (return res)
141: else (return nil))
142: elseif (or (eq 'a tmp) ; and contain only a's and d's
143: (eq 'd tmp))
144: then (setq res (cons tmp res))
145: else (return nil))))))
146:
147: ;--- d-call :: call another function
148: ; - name : name of funtion to call
149: ; - nargs : number of args stacked (including the function name)
150: ;
151: (defun d-call (name nargs)
152: (prog (tmp)
153: (forcecomment `(calling ,name))
154: (If (null (setq tmp (cdr (assoc nargs
155: '( (1 . (* -8 #.bind-reg))
156: (2 . (* -12 #.bind-reg))
157: (3 . (* -16 #.bind-reg))
158: (4 . (* -20 #.bind-reg))
159: (5 . (* -24 #.bind-reg)))))))
160: then ; lbot will not be set up automatically
161: (e-write3 'movab ; must set up lbot
162: `(,(* -4 nargs) #.Np-reg)
163: '#.Lbot-reg)
164: (setq tmp '(* -28 #.bind-reg)))
165: (e-write2 'jsb tmp)))
166:
167: ;--- d-callbig :: call a local or global function
168: ;
169: ;
170: (defun d-callbig (name args)
171: (let ((tmp (get name g-localf))
172: c)
173: (forcecomment `(calling ,name))
174: (If (d-dotailrecursion name args) thenret
175: elseif tmp then ;-- local function call
176: (d-pushargs args)
177: (e-write2 'jsb (car tmp))
178: (setq g-locs (nthcdr (setq c (length args)) g-locs))
179: (setq g-loccnt (- g-loccnt c))
180: else (If fl-tran ;-- transfer table linkage
181: then (d-pushargs args)
182: (setq c (length args))
183: (d-calltran name c)
184: else ;--- standard function call
185: (d-pushargs `(',name ,@args))
186: (d-call name (setq c (1+ (length args)))))
187: (setq g-locs (nthcdr c g-locs))
188: (setq g-loccnt (- g-loccnt c)))
189: (d-clearreg)))
190:
191:
192: ;--- d-calltran :: call a function through the transfer table = d-calltran =
193: ; name - name of function to call
194: ; c - number of arguments to the function
195: ;
196: (defun d-calltran (name c)
197: (e-write3 'movab `(,(* -4 c) #.Np-reg) '#.Lbot-reg)
198: (e-write3 'calls '$0 (concat "*trantb+" (d-tranloc name)))
199: (e-write3 'movl '#.Lbot-reg '#.Np-reg))
200:
201: ;--- d-tranloc :: locate a function in the transfer table = d-tranloc =
202: ;
203: ; return the offset we should use for this function call
204: ;
205: (defun d-tranloc (fname)
206: (cond ((get fname g-tranloc))
207: (t (Push g-tran fname)
208: (let ((newval (* 8 g-trancnt)))
209: (putprop fname newval g-tranloc)
210: (incr g-trancnt)
211: newval))))
212:
213: ;--- d-dotailrecursion :: do tail recursion if possible
214: ; name - function name we are to call
215: ; args - arguments to give to function
216: ;
217: ; return t iff we were able to do tail recursion
218: ; We can do tail recursion if:
219: ; g-ret is set indicating that the result of this call will be returned
220: ; as the value of the function we are compiling
221: ; the function we are calling, name, is the same as the function we are
222: ; compiling, g-fname
223: ; there are no variables shallow bound, since we would have to unbind
224: ; them, which may cause problems in the function.
225: ;
226: (defun d-dotailrecursion (name args)
227: (If (and g-ret
228: (eq name g-fname)
229: (do ((loccnt 0)
230: (ll g-locs (cdr ll)))
231: ((null ll) (return t))
232: (If (dtpr (car ll))
233: then (If (or (eq 'catcherrset (caar ll))
234: (greaterp (cdar ll) 0))
235: then (return nil))
236: else (incr loccnt))))
237: then
238: ; evalate the arguments and pop them back to the location of
239: ; the original args.
240: (makecomment '(tail merging))
241: (comp-note "Tail merging being done: " v-form)
242: (let ((g-locs g-locs)
243: (g-loccnt g-loccnt))
244: (d-pushargs args)) ; push then forget about
245: (let (base-reg nargs)
246: (If (eq g-ftype 'lexpr)
247: then ; the beginning of the local variables
248: ;has been stacked
249: (e-write3 'addl2 '$4 'sp) ; pop off arg count
250: (e-write4 'addl3 '$4 "(sp)" Lbot-reg)
251: (setq base-reg Lbot-reg) ; will push from bot
252: else (setq base-reg oLbot-reg)) ; will push from olbot
253: (setq nargs (length args))
254: (do ((i nargs (1- i))
255: (top (* nargs -4) (+ top 4))
256: (bot 0 (+ bot 4)))
257: ((zerop i))
258: (e-write3 'movl `(,top ,Np-reg) `(,bot ,base-reg)))
259: (e-write3 'movab `(,(* 4 nargs) ,base-reg) Np-reg)
260: (e-goto g-topsym))
261: t)) ; return t to indicate that tailrecursion was successful
262:
263:
264:
265:
266: ; Section xxx -- specific function compilers
267: ;
268:
269: ;--- cc-and :: compile an and expression
270: ; We evaluate forms from left to right as long as they evaluate to
271: ; a non nil value. We only have to worry about storing the value of
272: ; the last expression in g-loc.
273: ;
274: (defun cc-and nil
275: (let ((finlab (d-genlab))
276: (finlab2)
277: (exps (If (cdr v-form) thenret else '(t)))) ; (and) ==> t
278: (If (null (cdr g-cc))
279: then (d-exp (do ((g-cc (cons nil finlab))
280: (g-loc)
281: (g-ret)
282: (ll exps (cdr ll)))
283: ((null (cdr ll)) (car ll))
284: (d-exp (car ll))))
285: (If g-loc then (setq finlab2 (d-genlab))
286: (e-goto finlab2)
287: (e-label finlab)
288: (d-move 'Nil g-loc)
289: (e-label finlab2)
290: else (e-label finlab))
291: else ;--- cdr g-cc is non nil, thus there is
292: ; a quick escape possible if one of the
293: ; expressions evals to nil
294:
295: (If (null g-loc) then (setq finlab (cdr g-cc)))
296: (d-exp (do ((g-cc (cons nil finlab))
297: (g-loc)
298: (g-ret)
299: (ll exps (cdr ll)))
300: ((null (cdr ll)) (car ll))
301: (d-exp (car ll))))
302: ; if g-loc is non nil, then we have evaled the and
303: ; expression to yield nil, which we must store in
304: ; g-loc and then jump to where the cdr of g-cc takes us
305: (If g-loc then (setq finlab2 (d-genlab))
306: (e-goto finlab2)
307: (e-label finlab)
308: (d-move 'Nil g-loc)
309: (e-goto (cdr g-cc))
310: (e-label finlab2))))
311: (d-clearreg)) ; we cannot predict the state of the registers
312:
313:
314:
315:
316: ;--- cc-arg :: get the nth arg from the current lexpr = cc-arg =
317: ;
318: ; the syntax for Franz lisp is (arg i)
319: ; for interlisp the syntax is (arg x i) where x is not evaluated and is
320: ; the name of the variable bound to the number of args. We can only handle
321: ; the case of x being the variable for the current lexpr we are compiling
322: ;
323: (defun cc-arg nil
324: (let ((nillab (d-genlab)) (finlab (d-genlab)))
325: (If (not (eq 'lexpr g-ftype))
326: then (comp-err " arg only allowed in lexprs"))
327: (If (and (eq (length (cdr v-form)) 2) fl-inter)
328: then (If (not (eq (car g-args) (cadr v-form)))
329: then (comp-err " arg expression is for non local lexpr "
330: v-form)
331: else (setq v-form (cdr v-form))))
332: (If (or g-loc g-cc)
333: then (let ((g-loc 'reg)
334: (g-cc (cons nil nillab))
335: (g-ret))
336: (d-exp `(cdr ,(cadr v-form)))) ; calc the numeric arg
337: (If g-loc then (d-move '"*-4(fp)[r0]" g-loc)
338: else (e-tst '"*-4(fp)[r0]"))
339: (d-handlecc)
340: (e-goto finlab)
341: (e-label nillab)
342: ; here we are doing (arg nil) which returns the number of args
343: ; which is always true if anyone is testing
344: (If g-loc then (d-move '"-8(fp)" g-loc)
345: (d-handlecc)
346: elseif (car g-cc) then (e-goto (car g-cc))) ;always true
347: (e-label finlab))))
348:
349:
350: ;--- cc-atom :: test for atomness = cc-atom =
351: ;
352: (defun cc-atom nil
353: (d-typecmplx (cadr v-form)
354: '#.(concat '$ (plus 1_0 1_1 1_2 1_4 1_5 1_6 1_7 1_9 1_10))))
355:
356:
357: ;--- cc-bcdp :: check for bcdpness = cc-bcdp =
358: ;
359: (defun cc-bcdp nil
360: (d-typesimp (cadr v-form) '$5))
361:
362:
363: ;--- cc-bigp :: check for bignumness = cc-bigp =
364: ;
365: (defun cc-bigp nil
366: (d-typesimp (cadr v-form) '$9))
367:
368: ;--- c-*catch :: compile a *catch expression = c-*catch =
369: ;
370: ; the form of *catch is (*catch 'tag 'val)
371: ; we evaluate 'tag and set up a catch frame, and then eval 'val
372: ;
373: (defun c-*catch nil
374: (let ((g-loc 'reg)
375: (g-cc nil)
376: (g-ret nil)
377: (finlab (d-genlab)))
378: (d-exp (cadr v-form)) ; calculate tag into r0
379: (d-catcherrset finlab 'reg 'T (caddr v-form))
380: (e-label finlab)))
381:
382:
383:
384: ;--- d-catcherrset :: common code to catch and errset
385: ;
386: (defun d-catcherrset (finlab tagloc flagloc expr)
387: (e-write2 'pushab finlab)
388: (e-write2 'pushr '$0x2540) ; save registers
389: (e-write2 'jsb '_svkludg) ; save rest of state
390: (e-write2 'pushl Bnp-val)
391: (e-write2 'pushl (e-cvt tagloc)) ; push tag
392: (e-write2 'pushl (e-cvt flagloc)) ; non-nil flag
393: (e-write2 'pushl '_errp) ; old error pointer
394: (e-write3 'movl 'sp '_errp) ; set up new error pointer
395: (Push g-locs '(catcherrset . 0))
396: (d-exp expr) ; now do the expression
397: (unpush g-locs)
398: (e-write3 'movl '"(sp)" '_errp) ; unlink this error frame
399: (e-write3 'addl2 '$80 'sp)
400: (d-clearreg)) ; cant predict contents after retune
401:
402:
403: ;--- c-cond :: compile a "cond" expression = c-cond =
404: ;
405: ; not that this version of cond is a 'c' rather than a 'cc' .
406: ; this was done to make coding this routine easier and because
407: ; it is believed that it wont harm things much if at all
408: ;
409: (defun c-cond nil
410: (makecomment '(beginning cond))
411: (do ((clau (cdr v-form) (cdr clau))
412: (finlab (d-genlab))
413: (nxtlab)
414: (save-reguse)
415: (seent))
416: ((or (null clau) seent)
417: ; end of cond
418: ; if haven't seen a t must store a nil in r0
419: (If (null seent) then (d-move 'Nil 'reg))
420: (e-label finlab))
421:
422: ; case 1 - expr
423: (If (atom (car clau))
424: then (comp-err "bad cond clause " (car clau))
425: ; case 2 - (expr)
426: elseif (null (cdar clau))
427: then (let ((g-loc (If (or g-cc g-loc) then 'reg))
428: (g-cc (cons finlab nil))
429: (g-ret))
430: (d-exp (caar clau)))
431: ; case 3 - (t expr1 expr2 ...)
432: elseif (or (eq t (caar clau))
433: (equal ''t (caar clau)))
434: then (let ((g-loc (If (or g-cc g-loc) then 'reg))
435: g-cc)
436: (d-exps (cdar clau)))
437: (setq seent t)
438: ; case 4 - (expr1 expr2 ...)
439: else (let ((g-loc nil)
440: (g-cc (cons nil (setq nxtlab (d-genlab))))
441: (g-ret nil))
442: (d-exp (caar clau)))
443: (setq save-reguse (copy g-reguse))
444: (let ((g-loc (If (or g-cc g-loc) then 'reg))
445: g-cc)
446: (d-exps (cdar clau)))
447: (If (or (cdr clau) (null seent)) then (e-goto finlab))
448: (e-label nxtlab)
449: (setq g-reguse save-reguse)))
450:
451: (d-clearreg))
452:
453:
454:
455: ;--- c-cons :: do a cons instruction quickly = c-cons =
456: ;
457: (defun c-cons nil
458: (d-pushargs (cdr v-form)) ; there better be 2 args
459: (e-write2 'jsb '_qcons)
460: (setq g-locs (cddr g-locs))
461: (setq g-loccnt (- g-loccnt 2))
462: (d-clearreg))
463:
464:
465: ;--- c-cxr :: compile a cxr instruction = c-cxr =
466: ;
467: ; this code would also be useful for accessing any vector of lispvals.
468: ;
469: (defun c-cxr nil
470: (prog (arg1 arg2 arg1loc arg2loc)
471: (setq arg1loc (d-simple (setq arg1 (list 'cdr (cadr v-form))))
472: arg2loc (d-simple (setq arg2 (caddr v-form))))
473:
474: (If (not (and (dtpr arg1loc) (eq 'immed (car arg1loc))))
475: then
476: (If arg2loc
477: then (If (null arg1loc)
478: then (let ((g-loc 'r1)
479: (g-cc))
480: (d-exp arg1))
481: else (d-move arg1loc 'r1))
482: (d-move arg2loc 'r0)
483: else (d-pushargs (ncons arg1))
484: (let ((g-loc 'r0)
485: (g-cc))
486: (d-exp arg2))
487: (d-move 'unstack 'r1)
488: (decr g-loccnt)
489: (Pop g-locs))
490: (d-inreg 'r1 nil) ; register clobbered
491: (If g-loc then (e-move `(0 r0 r1) (e-cvt g-loc))
492: (d-handlecc)
493: elseif g-cc then (e-tst `(0 r0 r1))
494: (d-handlecc))
495: else (let ((g-loc 'r0)
496: (g-cc))
497: (d-exp arg2))
498: (setq arg1loc (list (* 4 (cadr arg1loc)) 'r0))
499: (If g-loc then (e-move arg1loc (e-cvt g-loc))
500: (d-handlecc)
501: elseif g-cc then (e-tst arg1loc)
502: (d-handlecc)))))
503:
504:
505: ;--- cc-cxxr :: compile a "c*r" instr where * = c-cxxr =
506: ; is any sequence of a's and d's
507: ; - arg : argument of the cxxr function
508: ; - pat : a list of a's and d's in the reverse order of that
509: ; which appeared between the c and r
510: ;
511: (defun cc-cxxr (arg pat)
512: (prog (resloc loc qloc sofar togo keeptrack)
513: ; check for the special case of nil, since car's and cdr's
514: ; are nil anyway
515: (If (null arg) then (If g-loc then (d-move 'Nil g-loc)
516: (d-handlecc)
517: elseif (cdr g-cc) then (e-goto (cdr g-cc)))
518: (return))
519:
520: (If (and (symbolp arg) (setq qloc (d-bestreg arg pat)))
521: then (setq resloc (car qloc)
522: loc resloc
523: sofar (cadr qloc)
524: togo (caddr qloc))
525: else (setq resloc (If (d-simple arg) thenret
526: else (let ((g-loc 'reg)
527: (g-cc nil)
528: (g-ret nil))
529: (d-exp arg))
530: 'r0))
531: (setq sofar nil
532: togo pat))
533:
534: (If (and arg (symbolp arg)) then (setq keeptrack t))
535:
536: ; if resloc is a global variable, we must move it into a register
537: ; right away to be able to do car's and cdr's
538: (If (and (dtpr resloc) (or (eq (car resloc) 'bind)
539: (eq (car resloc) 'vstack)))
540: then (d-move resloc 'reg)
541: (setq resloc 'r0))
542:
543: ; now do car's and cdr's . Values are placed in r0. We stop when
544: ; we can get the result in one machine instruction. At that point
545: ; we see whether we want the value or just want to set the cc's.
546: ; If the intermediate value is in a register,
547: ; we can do : car cdr cddr cdar
548: ; If the intermediate value is on the local vrbl stack or lbind
549: ; we can do : cdr
550: (do ((curp togo newp)
551: (newp))
552: ((null curp) (If g-loc then (d-movespec loc g-loc)
553: elseif g-cc then (e-tst loc))
554: (d-handlecc))
555: (If (symbolp resloc)
556: then (If (eq 'd (car curp))
557: then (If (or (null (cdr curp))
558: (eq 'a (cadr curp)))
559: then (setq newp (cdr curp) ; cdr
560: loc `(0 ,resloc)
561: sofar (append sofar (list 'd)))
562: else (setq newp (cddr curp) ; cddr
563: loc `(* 0 ,resloc)
564: sofar (append sofar (list 'd 'd))))
565: else (If (or (null (cdr curp))
566: (eq 'a (cadr curp)))
567: then (setq newp (cdr curp) ; car
568: loc `(4 ,resloc)
569: sofar (append sofar (list 'a)))
570: else (setq newp (cddr curp) ; cdar
571: loc `(* 4 ,resloc)
572: sofar (append sofar (list 'a 'd)))))
573: elseif (and (eq 'd (car curp))
574: (not (eq '* (car (setq loc (e-cvt resloc))))))
575: then (setq newp (cdr curp) ; (cdr <local>)
576: loc (cons '* loc)
577: sofar (append sofar (list 'd)))
578: else (setq loc (e-cvt resloc)
579: newp curp))
580: (If newp ; if this is not the last move
581: then (setq resloc (d-allocreg (If keeptrack then nil else 'r0)))
582: (d-movespec loc resloc)
583: (If keeptrack then (d-inreg resloc (cons arg sofar)))))))
584:
585: ;--- c-declare :: handle the "declare" form
586: ; if a declare is seen inside a function definition, we just
587: ; ignore it. We probably should see what it is declareing, as it
588: ; might be declaring a special.
589: ;
590: (defun c-declare nil)
591:
592: ;--- c-do :: compile a "do" expression = c-do =
593: ;
594: ; a do has this form:
595: ; (do vrbls tst . body)
596: ; we note the special case of tst being nil, in which case the loop
597: ; is evaluated only once, and thus acts like a let with labels allowed.
598: ; The do statement is a cross between a prog and a lambda. It is like
599: ; a prog in that labels are allowed. It is like a lambda in that
600: ; we stack the values of all init forms then bind to the variables, just
601: ; like a lambda expression (that is the initial values of even specials
602: ; are stored on the stack, and then copied into the value cell of the
603: ; atom during the binding phase. From then on the stack location is
604: ; not used).
605: ;
606: (defun c-do nil
607: (prog (b-vrbls b-tst b-body chklab bodylab x-repeat x-vrbs x-fst
608: g-loc g-cc oldreguse)
609: (forcecomment '(beginning do))
610: (setq g-loc 'reg chklab (d-genlab) bodylab (d-genlab))
611:
612: (If (and (cadr v-form) (atom (cadr v-form)))
613: then (setq v-form (d-olddo-to-newdo (cdr v-form))))
614:
615: (Push g-locs (cons 'do 0 )) ; begin our frame
616:
617: (setq b-vrbls (cadr v-form)
618: b-tst (caddr v-form)
619: b-body (cdddr v-form))
620:
621: ; push value of init forms on stack
622: (d-pushargs (mapcar '(lambda (x)
623: (If (atom x) then nil ; no init form => nil
624: else (cadr x)))
625: b-vrbls))
626:
627: ; now bind to the variables in the vrbls form
628: (d-bindlamb (mapcar '(lambda (x)
629: (If (atom x) then x
630: else (car x)))
631: b-vrbls))
632:
633: ; search through body for all labels and assign them gensymed labels
634: (Push g-labs (cons (d-genlab)
635: (do ((ll b-body (cdr ll))
636: (res))
637: ((null ll) res)
638: (If (and (car ll) (symbolp (car ll)))
639: then (Push res (cons (car ll) (d-genlab)))))))
640:
641: ; if the test is non nil, we do the test
642: ; another strange thing, a test form of (pred) will not return
643: ; the value of pred if it is not nil! it will return nil (in this
644: ; way, it is not like a cond clause)
645: (d-clearreg)
646: (If b-tst then (e-label chklab)
647: (let ((g-cc (cons nil bodylab)) g-loc g-ret)
648: (d-exp (car b-tst))) ; eval test
649: ; if false, do body
650: (If (cdr b-tst)
651: then (setq oldreguse (copy g-reguse))
652: (d-exps (cdr b-tst))
653: (setq g-reguse oldreguse)
654: else (d-move 'Nil 'reg))
655: (e-goto (caar g-labs)) ; leave do
656: (e-label bodylab)) ; begin body
657:
658: ; process body
659: (do ((ll b-body (cdr ll))
660: (g-cc) (g-loc)(g-ret))
661: ((null ll))
662: (If (or (null (car ll)) (not (symbolp (car ll))))
663: then (d-exp (car ll))
664: else (e-label (cdr (assoc (car ll) (cdar g-labs))))
665: (d-clearreg)))
666:
667: (If b-tst then ; determine all repeat forms which must be
668: ; evaluated, and all the variables affected.
669: ; store the results in x-repeat and x-vrbs
670: ; if there is just one repeat form, we calculate
671: ; its value directly into where it is stored,
672: ; if there is more than one, we stack them
673: ; and then store them back at once.
674: (do ((ll b-vrbls (cdr ll)))
675: ((null ll))
676: (If (and (dtpr (car ll)) (cddar ll))
677: then (Push x-repeat (caddar ll))
678: (Push x-vrbs (caar ll))))
679: (If x-vrbs
680: then (If (null (cdr x-vrbs)) ; if just one repeat..
681: then (let ((g-loc (d-locv (car x-vrbs)))
682: (g-cc nil))
683: (d-exp (car x-repeat)))
684: else (setq x-fst (car x-repeat))
685: (d-pushargs (nreverse (cdr x-repeat)))
686: (let ((g-loc (d-locv (car x-vrbs)))
687: (g-cc)
688: (g-ret))
689: (d-exp x-fst))
690: (do ((ll (cdr x-vrbs) (cdr ll)))
691: ((null ll))
692: (d-move 'unstack (d-locv (car ll)))
693: (setq g-locs (cdr g-locs))
694: (decr g-loccnt))))
695: (e-goto chklab))
696:
697: (e-label (caar g-labs)) ; end of do label
698: (d-clearreg)
699: (d-unbind)
700: (setq g-labs (cdr g-labs))))
701:
702:
703: ;--- d-olddo-to-newdo :: map old do to new do
704: ;
705: ; form of old do is (do var tst . body)
706: ; where var is a symbol, not nil
707: ;
708: (defun d-olddo-to-newdo (v-l)
709: `(do ((,(car v-l) ,(cadr v-l) ,(caddr v-l)))
710: (,(cadddr v-l))
711: ,@(cddddr v-l)))
712:
713:
714:
715: ;--- cc-dtpr :: check for dtprness = cc-dtpr =
716: ;
717: (defun cc-dtpr nil
718: (d-typesimp (cadr v-form) '$3))
719:
720:
721: ;--- cc-eq :: compile an "eq" expression = cc-eq =
722: ;
723: (defun cc-eq nil
724: (let ((arg1 (cadr v-form))
725: (arg2 (caddr v-form))
726: arg1loc
727: arg2loc)
728: (If (setq arg2loc (d-simple arg2))
729: then (If (setq arg1loc (d-simple arg1))
730: then ; eq <simple> <simple>
731: (d-cmp arg1loc arg2loc)
732: else ; eq <nonsimple> <simple>
733: (let ((g-loc 'reg) ; put <nonsimple> in r0
734: g-cc
735: g-ret)
736: (d-exp arg1))
737: (d-cmp 'reg arg2loc))
738: else ; since second is nonsimple, must stack first
739: ; arg out of harms way
740: (let ((g-loc 'stack)
741: g-cc
742: g-ret)
743: (d-exp arg1)
744: (Push g-locs nil)
745: (incr g-loccnt)
746: (setq g-loc 'reg) ; second arg to r0
747: (d-exp arg2))
748: (d-cmp 'unstack 'reg)
749: (setq g-locs (cdr g-locs))
750: (decr g-loccnt)))
751:
752: (d-invert))
753:
754: (defun cc-equal nil
755: (let ((lab1 (d-genlab))
756: (lab11 (d-genlab))
757: lab2)
758: (d-pushargs (cdr v-form))
759: (e-write3 'cmpl "-8(r6)" "-4(r6)")
760: (e-gotonil lab1)
761: (d-calltran 'equal '2) ; not eq, try equal.
762: (d-clearreg)
763: (e-write2 'tstl 'r0)
764: (e-gotot lab11)
765: (If g-loc then (d-move 'Nil g-loc))
766: (If (cdr g-cc) then (e-goto (cdr g-cc))
767: else (e-goto (setq lab2 (d-genlab))))
768: (e-writel lab1)
769: (e-dropnp 2)
770: (e-writel lab11)
771: (If g-loc then (d-move 'T g-loc))
772: (If (car g-cc) then (e-goto (car g-cc)))
773: (If lab2 then (e-writel lab2))
774: (setq g-locs (cddr g-locs))
775: (setq g-loccnt (- g-loccnt 2))))
776:
777:
778:
779:
780: ;--- c-errset :: compile an errset expression = c-errset =
781: ;
782: ; the errset has this form: (errset 'value ['tag])
783: ; where tag defaults to t.
784: ;
785: (defun c-errset nil
786: (let ((g-loc 'reg)
787: (g-cc nil)
788: (g-ret nil)
789: (finlab (d-genlab)))
790: (d-exp (If (cddr v-form) then (caddr v-form) else t))
791: (d-catcherrset finlab (d-loclit '(ER%all) nil) 'reg (cadr v-form))
792: (d-move 'reg 'stack)
793: (d-calltran 'ncons 1)
794: (e-label finlab)
795: (d-clearreg)))
796:
797:
798: ;--- cc-fixp :: check for a fixnum or bignum = cc-fixp =
799: ;
800: (defun cc-fixp nil
801: (d-typecmplx (cadr v-form)
802: '#.(concat '$ (plus 1_2 1_9))))
803:
804:
805: ;--- cc-floatp :: check for a flonum = cc-floatp =
806: ;
807: (defun cc-floatp nil
808: (d-typesimp (cadr v-form) '$4))
809:
810:
811: ;--- c-get :: do a get from the prop list
812: ;
813: (defun c-get nil
814: (If (not (eq 2 (length (cdr v-form))))
815: then (comp-err "Wrong number of args to get " v-form))
816: (d-pushargs (cdr v-form)) ; there better be 2 args
817: (e-write2 'jsb '_qget)
818: (d-clearreg)
819: (setq g-locs (cddr g-locs))
820: (setq g-loccnt (- g-loccnt 2)))
821:
822: ;--- c-go :: compile a "go" expression = c-go =
823: ;
824: ; we only compile the (go symbol)type expression, we do not
825: ; allow symbol to be anything by a non null symbol.
826: ;
827: (defun c-go nil
828: ; find number of frames we have to go down to get to the label
829: (do ((labs g-labs (cdr labs))
830: (locs g-locs)
831: (locals 0)
832: (specials 0)
833: (catcherrset 0)
834: (label))
835: ((null labs) (comp-err "go label not found for expression: " (or v-form)))
836: ; if there are any enclosing *catches or errsets, they will be
837: ; first in g-locs
838: (do nil
839: ((not (and (dtpr (car locs)) (eq (caar locs) 'catcherrset))))
840: (incr catcherrset)
841: (unpush locs))
842:
843: (If (car labs)
844: then (If (setq label (do ((lbs (cdar labs) (cdr lbs)))
845: ((null lbs))
846: (If (eq (caar lbs) (cadr v-form))
847: then (return (cdar lbs)))))
848: then (If (not (eq labs g-labs))
849: then (comp-warn "non local go used : " (or v-form)))
850: (If (greaterp catcherrset 0)
851: then (comp-warn "Go through a catch or errset " v-form)
852: (do ((i 0 (1+ i)))
853: ((equal catcherrset i))
854: (e-write3 'movl "(sp)" '_errp)
855: (e-write3 'addl2 '$80 'sp)))
856: (e-pop locals)
857: (If (greaterp specials 0)
858: then (e-unshallowbind specials))
859: (e-goto label)
860: (return)))
861: ; tally all locals and specials used in this frame
862: (do ()
863: ((dtpr (car locs)) (setq specials (+ specials (cdar locs))
864: locs (cdr locs)))
865: (setq locs (cdr locs))
866: (incr locals))))
867:
868:
869: ;--- cc-ingnore :: just ignore this code
870: ;
871: (defun cc-ignore nil
872: nil)
873:
874: ;--- c-lambexp :: compile a lambda expression = c-lambexp =
875: ;
876: (defun c-lambexp nil
877: (let ((g-loc (If (or g-loc g-cc) then 'reg))
878: (g-cc nil))
879: (Push g-locs (cons 'lambda 0)) ; add null lambda header
880: (d-pushargs (cdr v-form)) ; then push vals
881: (d-lambbody (car v-form))
882: (d-clearreg)))
883:
884: ;--- d-lambbody :: do a lambda body
885: ; - body : body of lambda expression, eg (lambda () dld)
886: ;
887: (defun d-lambbody (body)
888: (d-bindlamb (cadr body)) ; bind locals
889: (setq g-labs (cons nil g-labs)) ; no labels allowed
890: (d-clearreg)
891: (d-exp (do ((ll (cddr body) (cdr ll))
892: (g-loc)
893: (g-cc)
894: (g-ret))
895: ((null (cdr ll)) (car ll))
896: (d-exp (car ll))))
897:
898: (setq g-labs (cdr g-labs))
899: (d-unbind)) ; unbind this frame
900:
901:
902: ;--- d-bindlamb :: bind variables in lambda list
903: ; - vrbs : list of lambda variables, may include nil meaning ignore
904: ;
905: (defun d-bindlamb (vrbs)
906: (let ((res (d-bindlrec (reverse vrbs) g-locs 0 g-loccnt)))
907: (If res then (e-setupbind)
908: (mapc '(lambda (vrb) (e-shallowbind (car vrb) (cdr vrb)))
909: res)
910: (e-unsetupbind))))
911:
912: ;--- d-bindlrec :: recusive routine to bind lambda variables
913: ; - vrb : list of variables yet to bind
914: ; - locs : current location in g-loc
915: ; - specs : number of specials seen so far
916: ; - lev : how far up from the bottom of stack we are.
917: ; returns: list of elements, one for each special, of this form:
918: ; (<specialvrbname> stack <n>)
919: ; where specialvrbname is the name of the special variable, and n is
920: ; the distance from the top of the stack where its initial value is
921: ; located
922: ; also: puts the names of the local variables in the g-locs list, as well
923: ; as placing the number of special variables in the lambda header.
924: ;
925: (defun d-bindlrec (vrb locs specs lev)
926: (If vrb
927: then (let ((spcflg (d-specialp (car vrb)))
928: retv)
929: (If spcflg then (setq specs (1+ specs)))
930:
931: (If (cdr vrb) ; if more vrbls to go ...
932: then (setq retv (d-bindlrec (cdr vrb)
933: (cdr locs)
934: specs
935: (1- lev)))
936: else (rplacd (cadr locs) specs)) ; else fix up lambda hdr
937:
938: (If (not spcflg) then (rplaca locs (car vrb))
939: else (Push retv `(,(car vrb) stack ,lev)))
940:
941: retv)))
942: ;--- c-list :: compile a list expression = c-list =
943: ;
944: ; this is compiled as a bunch of conses with a nil pushed on the
945: ; top for good measure
946: ;
947: (defun c-list nil
948: (prog (nargs)
949: (setq nargs (length (cdr v-form)))
950: (makecomment '(list expression))
951: (If (zerop nargs) then (d-move 'Nil 'reg) ; (list) ==> nil
952: (return))
953: (d-pushargs (cdr v-form))
954: (e-write2 'clrl '(+ #.Np-reg)) ; stack one nil
955:
956: ; now do the consing
957: (do ((i (max 1 nargs) (1- i)))
958: ((zerop i))
959: (e-write2 'jsb '_qcons)
960: (d-clearreg)
961: (If (> i 1) then (d-move 'reg 'stack)))
962:
963: (setq g-locs (nthcdr nargs g-locs)
964: g-loccnt (- g-loccnt nargs))))
965:
966:
967:
968: ;--- d-mapconvert - access : function to access parts of lists
969: ; - join : function to join results
970: ; - resu : function to apply to result
971: ; - form : mapping form
972: ; This function converts maps to an equivalent do form.
973: ;
974: (defun d-mapconvert (access join resu form )
975: (prog (vrbls finvar acc accform compform tmp)
976:
977: (setq finvar (gensym 'X) ; holds result
978:
979: vrbls (reverse
980: (maplist '(lambda (arg)
981: ((lambda (temp)
982: (cond ((or resu (cdr arg))
983: `(,temp ,(car arg)
984: (cdr ,temp)))
985: (t `(,temp
986: (setq ,finvar ,(car arg))
987: (cdr ,temp)))))
988: (gensym 'X)))
989: (reverse (cdr form))))
990:
991: acc (mapcar '(lambda (tem)
992: (cond (access `(,access ,(car tem)))
993: (t (car tem))))
994: vrbls)
995:
996: accform (cond ((or (atom (setq tmp (car form)))
997: (null (setq tmp (d-macroexpand tmp)))
998: (not (member (car tmp) '(quote function))))
999: `(funcall ,tmp ,@acc))
1000: (t `(,(cadr tmp) ,@acc))))
1001: (return
1002: `((lambda (,finvar)
1003: (do ( ,@vrbls)
1004: ((null ,(caar vrbls)))
1005: ,(cond ((eq join 'nconc)
1006: `(setq ,finvar (nconc ,finvar ,accform)))
1007: (join `(setq ,finvar (,join ,accform ,finvar)))
1008: (t accform)))
1009: ,(cond ((eq resu 'identity) finvar)
1010: (resu `(,resu ,finvar))
1011: (t finvar)))
1012: nil ))))
1013: ; apply to successive elements, return second arg
1014: (defun cm-mapc nil
1015: (d-mapconvert 'car nil nil (cdr v-form)))
1016:
1017: ; apply to successive elements, return list of results
1018: (defun cm-mapcar nil
1019: (d-mapconvert 'car 'cons 'nreverse (cdr v-form)))
1020:
1021: ; apply to successive elements, returned nconc of results
1022: (defun cm-mapcan nil
1023: (d-mapconvert 'car 'nconc 'identity (cdr v-form)))
1024:
1025:
1026: ; apply to successive sublists, return second arg
1027: (defun cm-map nil
1028: (d-mapconvert nil nil nil (cdr v-form)))
1029:
1030:
1031: ; apply to successive sublists, return list of results
1032: (defun cm-maplist nil
1033: (d-mapconvert nil 'cons 'reverse (cdr v-form)))
1034:
1035: ; apply to successive sublists, return nconc of results
1036: (defun cm-mapcon nil
1037: (d-mapconvert nil 'nconc 'identity (cdr v-form)))
1038:
1039:
1040: ;--- cc-memq :: compile a memq expression = cc-memq =
1041: ;
1042: (defun cc-memq nil
1043: (let ((loc1 (d-simple (cadr v-form)))
1044: (loc2 (d-simple (caddr v-form)))
1045: looploc finlab)
1046: (If loc2 then (d-clearreg 'r1)
1047: (If loc1 then (d-move loc1 'r1)
1048: else (let ((g-loc 'r1)
1049: g-cc
1050: g-ret)
1051: (d-exp (cadr v-form))))
1052: (d-move loc2 'reg)
1053: else (let ((g-loc 'stack)
1054: g-cc
1055: g-ret)
1056: (d-exp (cadr v-form)))
1057: (Push g-locs nil)
1058: (incr g-loccnt)
1059: (let ((g-loc 'reg)
1060: g-cc
1061: g-ret)
1062: (d-exp (caddr v-form)))
1063: (d-move 'unstack 'r1)
1064: (d-clearreg 'r1)
1065: (unpush g-locs)
1066: (decr g-loccnt))
1067: ; now set up the jump addresses
1068: (If (null g-loc)
1069: then (setq loc1 (If (car g-cc) thenret
1070: else (d-genlab))
1071: loc2 (If (cdr g-cc) thenret
1072: else (d-genlab)))
1073: else (setq loc1 (d-genlab)
1074: loc2 (d-genlab)))
1075:
1076: (setq looploc (d-genlab))
1077:
1078: (e-write2 'tstl 'r0)
1079: (e-write2 'jeql loc2)
1080: (e-label looploc)
1081: (e-write3 'cmpl 'r1 "4(r0)")
1082: (e-write2 'jeql loc1)
1083: (e-write3 'movl "(r0)" 'r0)
1084: (e-write2 'jneq looploc)
1085: (If g-loc then (e-label loc2) ; nil result
1086: (d-move 'reg g-loc)
1087: (If (cdr g-cc) then (e-goto (cdr g-cc))
1088: else (e-goto (setq finlab (d-genlab))))
1089: else (If (cdr g-cc) then (e-goto (cdr g-cc))
1090: else (e-label loc2)))
1091: (If g-loc then (e-label loc1) ; non nil result
1092: (d-move 'reg g-loc)
1093: (If (car g-cc) then (e-goto (car g-cc)))
1094: else (If (null (car g-cc)) then (e-label loc1)))
1095: (If finlab then (e-label finlab))))
1096:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.