![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to cddr.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 cddr.l CVS log | Up to [CSRG BSD Unix] / 41BSD / cmd / liszt |
1.1 root 1: (include "caspecs.l")
2: (eval-when (compile)
3: (fasl 'camacs))
4:
5: (setq sectioncddrid "@(#)cddr.l 5.4 11/11/80") ; id for SCCS
6:
7: ; cc-not :: compile a "not" or "null" expression = cc-not =
8: ;
9: (defun cc-not nil
10: (makecomment '(beginning not))
11: (If (null g-loc)
12: then (let ((g-cc (cons (cdr g-cc) (car g-cc)))
13: (g-ret nil))
14: (d-exp (cadr v-form)))
15: else (let ((finlab (d-genlab))
16: (finlab2 (d-genlab))
17: (g-ret nil))
18: ; eval arg and jump to finlab if nil
19: (let ((g-cc (cons finlab nil))
20: g-loc)
21: (d-exp (cadr v-form)))
22: ; didn't jump, answer must be t
23: (d-move 'T g-loc)
24: (If (car g-cc) then (e-goto (car g-cc))
25: else (e-goto finlab2))
26: (e-label finlab)
27: ; answer is nil
28: (d-move 'Nil g-loc)
29: (If (cdr g-cc) then (e-goto (cdr g-cc)))
30: (e-label finlab2))))
31:
32:
33: ;--- cc-numberp :: check for numberness = cc-numberp =
34: ;
35: (defun cc-numberp nil
36: (d-typecmplx (cadr v-form)
37: '#.(concat '$ (plus 1_2 1_4 1_9))))
38:
39:
40: ;--- cc-or :: compile an "or" expression = cc-or =
41: ;
42: (defun cc-or nil
43: (let ((finlab (d-genlab))
44: (finlab2)
45: (exps (If (cdr v-form) thenret else '(nil)))) ; (or) => nil
46: (If (null (car g-cc))
47: then (d-exp (do ((g-cc (cons finlab nil))
48: (g-loc (If g-loc then 'reg))
49: (g-ret nil)
50: (ll exps (cdr ll)))
51: ((null (cdr ll)) (car ll))
52: (d-exp (car ll))))
53: (If g-loc then (setq finlab2 (d-genlab))
54: (e-goto finlab2)
55: (e-label finlab)
56: (d-move 'reg g-loc)
57: (e-label finlab2)
58: else (e-label finlab))
59: else (If (null g-loc) then (setq finlab (car g-cc)))
60: (d-exp (do ((g-cc (cons finlab nil))
61: (g-loc (If g-loc then 'reg))
62: (g-ret nil)
63: (ll exps (cdr ll)))
64: ((null (cdr ll)) (car ll))
65: (d-exp (car ll))))
66: (If g-loc then (setq finlab2 (d-genlab))
67: (e-goto finlab2)
68: (e-label finlab)
69: (d-move 'reg g-loc)
70: (e-goto (car g-cc)) ; result is t
71: (e-label finlab2)))
72: (d-clearreg))) ; we are not sure of the state due to possible branches.
73:
74:
75: ;--- c-prog :: compile a "prog" expression = c-prog =
76: ;
77: ; for interlisp compatibility, we allow the formal variable list to
78: ; contain objects of this form (vrbl init) which gives the initial value
79: ; for that variable (instead of nil)
80: ;
81: (defun c-prog nil
82: (let (g-loc g-cc seeninit initf ((spcs locs initsv . initsn)
83: (d-classify (cadr v-form)))
84: (p-rettrue g-ret) (g-ret nil))
85:
86: (e-pushnil (length locs)) ; locals initially nil
87: (d-bindprg spcs locs) ; bind locs and specs
88:
89: (cond (initsv (d-pushargs initsv)
90: (mapc '(lambda (x)
91: (d-move 'unstack (d-loc x))
92: (decr g-loccnt)
93: (unpush g-locs))
94: (nreverse initsn))))
95:
96: ; determine all possible labels
97: (do ((ll (cddr v-form) (cdr ll))
98: (labs nil))
99: ((null ll) (setq g-labs `((,(d-genlab) ,@labs)
100: ,@g-labs)))
101: (If (and (car ll) (symbolp (car ll)))
102: then (If (assq (car ll) labs)
103: then (comp-err "label is mulitiply defined " (car ll))
104: else (setq labs (cons (cons (car ll) (d-genlab))
105: labs)))))
106:
107: ; compile each form which is not a label
108: (d-clearreg) ; unknown state after binding
109: (do ((ll (cddr v-form) (cdr ll)))
110: ((null ll))
111: (If (or (null (car ll)) (not (symbolp (car ll))))
112: then (d-exp (car ll))
113: else (e-label (cdr (assq (car ll) (cdar g-labs))))
114: (d-clearreg)))) ; dont know state after label
115:
116: ; result is nil if fall out and care about value
117: (If (or g-cc g-loc) then (d-move 'Nil 'reg))
118:
119: (e-label (caar g-labs)) ; return to label
120: (setq g-labs (cdr g-labs))
121: (d-unbind)) ; unbind our frame
122:
123:
124: ;--- d-bindprg :: do binding for a prog expression
125: ; - spcs : list of special variables
126: ; - locs : list of local variables
127: ; - specinit : init values for specs (or nil if all are nil)
128: ;
129: (defun d-bindprg (spcs locs)
130:
131:
132: ; place the local vrbls and prog frame entry on the stack
133: (setq g-loccnt (+ g-loccnt (length locs))
134: g-locs (nconc locs `((prog . ,(length spcs)) ,@g-locs)))
135:
136: ; now bind the specials, if any, to nil
137: (If spcs then (e-setupbind)
138: (mapc '(lambda (vrb)
139: (e-shallowbind vrb 'Nil))
140: spcs)
141: (e-unsetupbind)))
142:
143: ;--- d-unbind :: remove one frame from g-locs
144: ;
145: (defun d-unbind nil
146: (do ((count 0 (1+ count)))
147: ((dtpr (car g-locs))
148: (If (not (zerop (cdar g-locs)))
149: then (e-unshallowbind (cdar g-locs)))
150: (cond ((not (zerop count))
151: (e-dropnp count)
152:
153: (setq g-loccnt (- g-loccnt count))))
154: (setq g-locs (cdr g-locs)))
155: (setq g-locs (cdr g-locs))))
156:
157:
158: ;--- d-classify :: seperate variable list into special and non-special
159: ; - lst : list of variables
160: ; returns ( xxx yyy zzz . aaa)
161: ; where xxx is the list of special variables and
162: ; yyy is the list of local variables
163: ; zzz are the non nil initial values for prog variables
164: ; aaa are the names corresponding to the values in zzz
165: ;
166: (defun d-classify (lst)
167: (do ((ll lst (cdr ll))
168: (locs) (spcs) (init) (initsv) (initsn)
169: (name))
170: ((null ll) (cons spcs (cons locs (cons initsv initsn))))
171: (If (atom (car ll)) then (setq name (car ll))
172: else (setq name (caar ll))
173: (Push initsn name)
174: (Push initsv (cadar ll)))
175: (If (d-specialp name)
176: then (Push spcs name)
177: else (Push locs name))))
178:
179: ; cm-progn :: compile a "progn" expression = cm-progn =
180: ;
181: (defun cm-progn nil
182: `((lambda nil ,@(cdr v-form))))
183:
184:
185: ; cm-prog1 :: compile a "prog1" expression = cm-prog1 =
186: ;
187: (defun cm-prog1 nil
188: (let ((gl (d-genlab)))
189: `((lambda (,gl)
190: ,@(cddr v-form)
191: ,gl)
192: ,(cadr v-form))))
193:
194:
195: ; cm-prog2 :: compile a "prog2" expression = cm-prog2 =
196: ;
197: (defun cm-prog2 nil
198: (let ((gl (d-genlab)))
199: `((lambda (,gl) ,(cadr v-form)
200: (setq ,gl ,(caddr v-form))
201: ,@(cdddr v-form)
202: ,gl)
203: nil)))
204:
205:
206: ;--- cc-quote : compile a "quote" expression = cc-quote =
207: ;
208: ; if we are just looking to set the ; cc, we just make sure
209: ; we set the cc depending on whether the expression quoted is
210: ; nil or not.
211: (defun cc-quote nil
212: (let ((arg (cadr v-form))
213: argloc)
214:
215: (If (null g-loc)
216: then (If (and (null arg) (cdr g-cc)
217: then (e-goto (cdr g-cc))
218: elseif (and arg (car g-cc))
219: then (e-goto (car g-cc)))
220: elseif (null g-cc)
221: then (comp-warn "losing the value of this expression " (or v-form)))
222: else (d-move (d-loclit arg nil) g-loc)
223: (d-handlecc))))
224:
225:
226: ;--- d-loc :: return the location of the variable or value in IADR form
227: ; - form : form whose value we are to locate
228: ;
229: ; if we are given a xxx as form, we check yyy;
230: ; xxx yyy
231: ; -------- ---------
232: ; nil Nil is always returned
233: ; symbol return the location of the symbols value, first looking
234: ; in the registers, then on the stack, then the bind list.
235: ; If g-ingorereg is t then we don't check the registers.
236: ; We would want to do this if we were interested in storing
237: ; something in the symbol's value location.
238: ; number always return the location of the number on the bind
239: ; list (as a (lbind n))
240: ; other always return the location of the other on the bind
241: ; list (as a (lbind n))
242: ;
243: (defun d-loc (form)
244: (If (null form) then 'Nil
245: elseif (numberp form) then
246: (If (and (fixp form) (greaterp form -1025) (lessp form 1024))
247: then `(fixnum ,form) ; small fixnum
248: else (d-loclit form nil))
249: elseif (symbolp form)
250: then (If (and (null g-ignorereg) (car (d-bestreg form nil))) thenret
251: else (If (d-specialp form) then (d-loclit form t)
252: else
253: (do ((ll g-locs (cdr ll)) ; check stack
254: (n g-loccnt))
255: ((null ll)
256: (comp-warn (or form) " declared special by compiler")
257: (d-makespec form)
258: (d-loclit form t))
259: (If (atom (car ll))
260: then (If (eq form (car ll))
261: then (return `(stack ,n))
262: else (setq n (1- n)))))))
263: else (d-loclit form nil)))
264:
265:
266: ;--- d-loclit :: locate or add litteral to bind list
267: ; - form : form to check for and add if not present
268: ; - flag : if t then if we are given a symbol, return the location of
269: ; its value, else return the location of the symbol itself
270: ;
271: ; scheme: we share the locations of atom (symbols,numbers,string) but always
272: ; create a fresh copy of anything else.
273: (defun d-loclit (form flag)
274: (prog (loc onplist symboltype)
275: (If (null form)
276: then (return 'Nil)
277: elseif (symbolp form)
278: then (setq symboltype t)
279: (cond ((setq loc (get form g-bindloc))
280: (setq onplist t)))
281: elseif (atom form)
282: then (do ((ll g-lits (cdr ll)) ; search for atom on list
283: (n g-litcnt (1- n)))
284: ((null ll))
285: (If (eq form (car ll))
286: then (setq loc n) ; found it
287: (return)))) ; leave do
288: (If (null loc)
289: then (Push g-lits form)
290: (setq g-litcnt (1+ g-litcnt)
291: loc g-litcnt)
292: (cond ((and symboltype (null onplist))
293: (putprop form loc g-bindloc))))
294:
295: (return (If (and flag symboltype) then `(bind ,loc)
296: else `(lbind ,loc)))))
297:
298:
299:
300: ;--- d-locv :: find the location of a value cell, and dont return a register
301: ;
302: (defun d-locv (sm)
303: (let ((g-ignorereg t))
304: (d-loc sm)))
305:
306:
307: ;--- c-setarg :: set a lexpr's arg = cc-setarg =
308: ; form is (setarg index value)
309: ;
310: (defun c-setarg nil
311: (If (not (eq 'lexpr g-ftype))
312: then (comp-err "setarg only allowed in lexprs"))
313: (If (and fl-inter (eq (length (cdr v-form)) 3)) ; interlisp setarg
314: then (If (not (eq (cadr v-form) (car g-args)))
315: then (comp-err "setarg: can only compile local setargs " v-form)
316: else (setq v-form (cdr v-form))))
317: (d-pushargs (list (cadr v-form))) ; stack index
318: (let ((g-loc 'reg)
319: (g-cc nil)
320: (g-ret nil))
321: (d-exp (caddr v-form)))
322: (d-clearreg 'r1) ; indicate we are clobbering r1
323: (e-write3 'movl `(* -4 #.Np-reg) 'r1) ; actual number to r1
324: (e-write3 'movl 'r0 "*-4(fp)[r1]") ; store value in
325: (e-pop 1)
326: (unpush g-locs)
327: (decr g-loccnt))
328:
329: ;--- cc-stringp :: check for string ness = cc-stringp =
330: ;
331: (defun cc-stringp nil
332: (d-typesimp (cadr v-form) '$0))
333:
334:
335: ;--- cc-symbolp :: check for symbolness = cc-symbolp =
336: ;
337: (defun cc-symbolp nil
338: (d-typesimp (cadr v-form) '$1))
339:
340:
341:
342: ;--- c-return :: compile a "return" statement = c-return =
343: ;
344: (defun c-return nil
345: ; value is always put in r0
346: (let ((g-loc 'reg)
347: g-cc
348: g-ret)
349: (d-exp (cadr v-form)))
350:
351: ; if we are doing a non local return, compute number of specials to unbind
352: ; and locals to pop
353: (If (car g-labs) then (e-goto (caar g-labs))
354: else (do ((loccnt 0)
355: (speccnt 0)
356: (ll g-labs (cdr ll))
357: (locs g-locs))
358: ((null ll) (comp-err "return used not within a prog or do"))
359: (If (car ll) then (comp-warn " non local return used ")
360: ; unbind down to but not including
361: ; this frame.
362: (If (greaterp loccnt 0)
363: then (e-pop loccnt))
364: (If (greaterp speccnt 0)
365: then (e-unshallowbind speccnt))
366: (e-goto (caar ll))
367: (return)
368: else ; determine number of locals and special on
369: ; stack for this frame, add to running
370: ; totals
371: (do ()
372: ((dtpr (car locs))
373: (setq speccnt (+ speccnt (cdar locs))
374: locs (cdr locs)))
375: (incr loccnt)
376: (setq locs (cdr locs)))))))
377:
378:
379: ; c-rplaca :: compile a "rplaca" expression = c-rplaca =
380: ;
381: (defun c-rplaca nil
382: (let ((ssimp (d-simple (caddr v-form)))
383: (g-ret nil))
384: (let ((g-loc (If ssimp then 'reg else 'stack))
385: (g-cc nil))
386: (d-exp (cadr v-form)))
387: (If (null ssimp) then (Push g-locs nil)
388: (incr g-loccnt)
389: (let ((g-loc 'r1)
390: (g-cc nil))
391: (d-exp (caddr v-form)))
392: (d-move 'unstack 'reg)
393: (unpush g-locs)
394: (decr g-loccnt)
395: (e-move 'r1 '(4 r0))
396: else (e-move (e-cvt ssimp) '(4 r0)))
397: (d-clearreg))) ; cant tell what we are clobbering
398:
399:
400: ; c-rplacd :: compile a "rplacd" expression = c-rplacd =
401: ;
402: (defun c-rplacd nil
403: (let ((ssimp (d-simple (caddr v-form)))
404: (g-ret nil))
405: (let ((g-loc (If ssimp then 'reg else 'stack))
406: (g-cc nil))
407: (d-exp (cadr v-form)))
408: (If (null ssimp) then (Push g-locs nil)
409: (incr g-loccnt)
410: (let ((g-loc 'r1)
411: (g-cc nil))
412: (d-exp (caddr v-form)))
413: (d-move 'unstack 'reg)
414: (unpush g-locs)
415: (decr g-loccnt)
416: (e-move 'r1 '(0 r0))
417: else (e-move (e-cvt ssimp) '(0 r0)))
418: (d-clearreg)))
419:
420: ; c-set :: compile a "set" expression = c-set =
421:
422:
423: ;--- cc-setq :: compile a "setq" expression = c-setq =
424: ;
425: (defun cc-setq nil
426: (let (tmp)
427: (If (oddp (length (cdr v-form)))
428: then (comp-err "wrong number of args to setq "
429: (or v-form))
430: elseif (cdddr v-form) ; if multiple setq's
431: then (do ((ll (cdr v-form) (cddr ll))
432: (g-loc)
433: (g-cc nil))
434: ((null (cddr ll)) (setq tmp ll))
435: (setq g-loc (d-locv (car ll)))
436: (d-exp (cadr ll))
437: (d-clearuse (car ll)))
438: else (setq tmp (cdr v-form)))
439:
440: ; do final setq
441: (let ((g-loc (d-locv (car tmp)))
442: (g-cc (If g-loc then nil else g-cc))
443: (g-ret nil))
444: (d-exp (cadr tmp))
445: (d-clearuse (car tmp)))
446: (If g-loc then (d-move (d-locv (car tmp)) g-loc)
447: (If g-cc then (d-handlecc)))))
448:
449:
450:
451: ; cc-typep :: compile a "typep" expression = cc-typep =
452: ;
453: ; this returns the type of the expression, it is always non nil
454: ;
455: (defun cc-typep nil
456: (let ((argloc (d-simple (cadr v-form)))
457: (g-ret))
458: (If (null argloc) then (let ((g-loc 'reg) g-cc)
459: (d-exp (cadr v-form)))
460: (setq argloc 'reg))
461: (If g-loc then (e-write4 'ashl '$-9 (e-cvt argloc) 'r0)
462: (e-write3 'cvtbl "_typetable+1[r0]" 'r0)
463: (e-write3 'movl "_tynames+4[r0]" 'r0)
464: (e-write3 'movl "(r0)" (e-cvt g-loc)))
465: (If (car g-cc) then (e-goto (car g-cc)))))
466:
467:
468:
469: ; cm-symeval :: compile a symeval expression.
470: ; the symbol cell in franz lisp is just the cdr.
471: ;
472: (defun cm-symeval nil
473: `(cdr ,(cadr v-form)))
474:
475:
476: ; c-*throw :: compile a "*throw" expression =c-*throw =
477: ;
478: ; the form of *throw is (*throw 'tag 'val) .
479: ; we calculate and stack the value of tag, then calculate val
480: ; we call Idothrow to do the actual work, and only return if the
481: ; throw failed.
482: ;
483: (defun c-*throw nil
484: (let ((arg2loc (d-simple (caddr v-form)))
485: g-cc
486: g-ret
487: arg1loc)
488: (If arg2loc then (If (setq arg1loc (d-simple (cadr v-form)))
489: then (e-write2 'pushl (e-cvt arg2loc))
490: (e-write2 'pushl (e-cvt arg1loc))
491: else (let ((g-loc 'reg))
492: (d-exp (cadr v-form)) ; calc tag
493: (e-write2 'pushl (e-cvt arg2loc))
494: (e-write2 'pushl (e-cvt 'reg))))
495: else (let ((g-loc 'stack))
496: (d-exp (cadr v-form)) ; calc tag to stack
497: (Push g-locs nil)
498: (incr g-loccnt)
499: (setq g-loc 'reg)
500: (d-exp (caddr v-form)) ; calc value into r0
501: (e-write2 'pushl (e-cvt 'reg))
502: (e-write2 'pushl (e-cvt 'unstack))
503: (unpush g-locs)
504: (decr g-loccnt)))
505: (e-write3 'calls '$0 '_Idothrow)
506: (e-write2 'clrl '"-(sp)") ; non contuable error
507: (e-write2 'pushab '__erthrow) ; string to print
508: (e-write3 'calls '$2 '_error)))
509:
510:
511:
512: ;--- cm-zerop :: convert zerop to a quick test = cm-zerop =
513: ; zerop is only allowed on fixnum and flonum arguments. In both cases,
514: ; if the value of the first 32 bits is zero, then we have a zero.
515: ; thus we can define it as a macro:
516: (defun cm-zerop nil
517: (cond ((atom (cadr v-form))
518: `(and (null (cdr ,(cadr v-form))) (not (bigp ,(cadr v-form)))))
519: (t (let ((gnsy (gensym)))
520: `((lambda (,gnsy)
521: (and (null (cdr ,gnsy))
522: (not (bigp ,gnsy))))
523: ,(cadr v-form))))))
524:
525:
526:
527: ;------- FIXNUM arithmetic section ---------
528: ; beware all ye who read this section
529: ;
530:
531:
532:
533: (declare (localf d-upordown d-fixop))
534:
535: ;--- c-1+ :: fixnum add1 function
536: ;
537: (defun c-1+ nil
538: (d-upordown 'addl3))
539:
540: ;--- c-1- :: fixnum sub1 function
541: ;
542: (defun c-1- nil
543: (d-upordown 'subl3))
544:
545: (defun d-upordown (opcode)
546: (let ((arg (cadr v-form))
547: argloc)
548: (If (setq argloc (d-simple `(cdr ,arg)))
549: then (e-write4 opcode '$1 (e-cvt argloc) 'r5)
550: else (let ((g-loc 'reg)
551: g-ret
552: g-cc)
553: (d-exp arg))
554: (e-write4 opcode '$1 "(r0)" 'r5))
555: (e-write2 "jsb" "_qnewint")
556: (d-clearreg)))
557:
558:
559: ;--- c-+ :: fixnum add = c-+ =
560: ;
561: (defun c-+ nil
562: (d-fixop 'addl3 'plus))
563:
564: (defun c-- nil
565: (d-fixop 'subl3 'difference))
566:
567: (defun c-* nil
568: (d-fixop 'mull3 'times))
569:
570: (defun c-/ nil
571: (d-fixop 'divl3 'quotient))
572:
573: (defun c-\\ nil
574: (d-fixop 'ediv 'remainder))
575:
576: (defun d-fixop (opcode lispopcode)
577: (prog (op1 op2 rop1 rop2 simpleop1)
578: (If (not (eq 3 (length v-form))) ; only handle two ops for now
579: then (d-callbig lispopcode (cdr v-form))
580: else (setq op1 (cadr v-form)
581: op2 (caddr v-form))
582: (If (fixp op1)
583: then (setq rop1 (concat '$ op1) ; simple int
584: simpleop1 t)
585: else (If (setq rop1 (d-simple `(cdr ,op1)))
586: then (setq rop1 (e-cvt rop1))
587: else (let ((g-loc 'reg) g-cc g-ret)
588: (d-exp op1))
589: (setq rop1 '|(r0)|)))
590: (If (fixp op2)
591: then (setq rop2 (concat '$ op2))
592: else (If (setq rop2 (d-simple `(cdr ,op2)))
593: then (setq rop2 (e-cvt rop2))
594: else (e-write3 'movl rop1 "-(sp)")
595: (setq rop1 "(sp)+")
596: (let ((g-loc 'reg)
597: g-cc g-ret)
598: (d-exp op2))
599: (setq rop2 '|(r0)|)))
600: (If (eq opcode 'ediv)
601: then (If (not simpleop1) then (e-write3 'movl rop1 'r2) ; need quad
602: (e-write4 'ashq '$-32 'r1 'r1)
603: (setq rop1 'r1)) ; word div.
604: (e-write5 'ediv rop2 rop1 'r0 'r5)
605: else (e-write4 opcode rop2 rop1 'r5))
606:
607: (e-write2 'jsb "_qnewint")
608: (d-clearreg))))
609:
610:
611:
612:
613: ;---- d routines (general ones, others are near function using them)
614:
615:
616:
617: ;--- d-cmp :: compare two IADR values
618: ;
619: (defun d-cmp (arg1 arg2)
620: (e-write3 'cmpl (e-cvt arg1) (e-cvt arg2)))
621:
622:
623: ;--- d-handlecc :: handle g-cc
624: ; at this point the Z condition code has been set up and if g-cc is
625: ; non nil, we must jump on condition to the label given in g-cc
626: ;
627: (defun d-handlecc nil
628: (If (car g-cc) then (e-gotot (car g-cc))
629: elseif (cdr g-cc) then (e-gotonil (cdr g-cc))))
630:
631:
632: ;--- d-invert :: handle inverted condition codes
633: ; this routine is called if a result has just be computed which alters
634: ; the condition codes such that Z=1 if the result is t, and Z=0 if the
635: ; result is nil (this is the reverse of the usual sense). The purpose
636: ; of this routine is to handle g-cc and g-loc. That is if g-loc is
637: ; specified, we must convert the value of the Z bit of the condition
638: ; code to t or nil and store that in g-loc. After handling g-loc we
639: ; must handle g-cc, that is if the part of g-cc is non nil which matches
640: ; the inverse of the current condition code, we must jump to that.
641: ;
642: (defun d-invert nil
643: (If (null g-loc)
644: then (If (car g-cc) then (e-gotonil (car g-cc))
645: elseif (cdr g-cc) then (e-gotot (cdr g-cc)))
646: else (let ((lab1 (d-genlab))
647: (lab2 (If (cdr g-cc) thenret else (d-genlab))))
648: (e-gotonil lab1)
649: ; Z=1, but remember that this implies nil due to inversion
650: (d-move 'Nil g-loc)
651: (e-goto lab2)
652: (e-label lab1)
653: ; Z=0, which means t
654: (d-move 'T g-loc)
655: (If (car g-cc) then (e-goto (car g-cc)))
656: (If (null (cdr g-cc)) then (e-label lab2)))))
657:
658:
659: ;--- d-noninvert :: handle g-cc and g-loc assuming cc non inverted
660: ;
661: ; like d-invert except Z=0 implies nil, and Z=1 implies t
662: ;
663: (defun d-noninvert nil
664: (If (null g-loc)
665: then (If (car g-cc) then (e-gotot (car g-cc))
666: elseif (cdr g-cc) then (e-gotonil (cdr g-cc)))
667: else (let ((lab1 (d-genlab))
668: (lab2 (If (cdr g-cc) thenret else (d-genlab))))
669: (e-gotot lab1)
670: ; Z=0, this implies nil
671: (d-move 'Nil g-loc)
672: (e-goto lab2)
673: (e-label lab1)
674: ; Z=1, which means t
675: (d-move 'T g-loc)
676: (If (car g-cc) then (e-goto (car g-cc)))
677: (If (null (cdr g-cc)) then (e-label lab2)))))
678:
679: ;--- d-macroexpand :: macro expand a form as much as possible
680: ;
681: (defun d-macroexpand (form)
682: (prog nil
683: loop
684: (If (and (dtpr form)
685: (symbolp (car form))
686: (eq 'macro (d-functyp (car form))))
687: then (setq form (apply (car form) form))
688: (go loop))
689: (return form)))
690:
691: ;--- d-makespec :: declare a variable to be special
692: ;
693: (defun d-makespec (vrb)
694: (putprop vrb t g-spec))
695:
696:
697: ;--- d-move :: emit instructions to move value from one place to another
698: ;
699: (defun d-move (from to)
700: (makecomment `(from ,(e-uncvt from) to ,(e-uncvt to)))
701: (cond ((eq 'Nil from) (e-write2 'clrl (e-cvt to)))
702: (t (e-write3 'movl (e-cvt from) (e-cvt to)))))
703:
704:
705: ;--- d-simple :: see of arg can be addresses in one instruction
706: ; we define simple and really simple as follows
707: ; <rsimple> ::= number
708: ; quoted anything
709: ; local symbol
710: ; t
711: ; nil
712: ; <simple> ::= <rsimple>
713: ; (cdr <rsimple>)
714: ; global symbol
715: ;
716: (defun d-simple (arg)
717: (let (tmp)
718: (If (d-rsimple arg) thenret
719: elseif (symbolp arg) then (d-loc arg)
720: elseif (and (memq (car arg) '(cdr car cddr cdar))
721: (setq tmp (d-rsimple (cadr arg))))
722: then (If (eq 'Nil tmp) then tmp
723: elseif (atom tmp)
724: then (If (eq 'car (car arg)) then `(racc 4 ,tmp)
725: elseif (eq 'cdr (car arg)) then `(racc 0 ,tmp)
726: elseif (eq 'cddr (car arg)) then `(racc * 0 ,tmp)
727: elseif (eq 'cdar (car arg)) then `(racc * 4 ,tmp))
728: elseif (not (eq 'cdr (car arg))) then nil
729: elseif (eq 'lbind (car tmp)) then `(bind ,(cadr tmp))
730: elseif (eq 'stack (car tmp)) then `(vstack ,(cadr tmp))
731: elseif (eq 'fixnum (car tmp)) then `(immed ,(cadr tmp))
732: elseif (atom (car tmp)) then `(0 ,(cadr tmp))
733: else (comp-err "bad arg to d-simple: " (or arg))))))
734:
735: (defun d-rsimple (arg)
736: (If (atom arg) then
737: (If (null arg) then 'Nil
738: elseif (eq t arg) then 'T
739: elseif (or (numberp arg)
740: (memq arg g-locs))
741: then (d-loc arg)
742: else (car (d-bestreg arg nil)))
743: elseif (eq 'quote (car arg)) then (d-loclit (cadr arg) nil)))
744:
745: ;--- d-movespec :: move from loc to loc where the first addr given is
746: ; an EIADR
747: ; - from : EIADR
748: ; - to : IADR
749: ;
750: (defun d-movespec (from to)
751: (makecomment `(fromspec ,from to ,(e-uncvt to)))
752: (e-write3 'movl from (e-cvt to)))
753:
754:
755: ;--- d-specialp :: check if a variable is special
756: ; a varible is special if it has been declared as such, or if
757: ; the variable special is t
758: (defun d-specialp (vrb)
759: (or special (get vrb g-spec)))
760:
761:
762: ;--- d-tst :: test the given value (set the cc)
763: ;
764: (defun d-tst (arg)
765: (e-write2 'tstl (e-cvt arg)))
766:
767: ;--- d-typesimp :: determine the type of the argument
768: ;
769: (defun d-typesimp (arg val)
770: (let ((argloc (d-simple arg)))
771: (If (null argloc) then (let ((g-loc 'reg)
772: g-cc g-ret)
773: (d-exp arg))
774: (setq argloc 'reg))
775: (e-write4 'ashl '$-9 (e-cvt argloc) 'r0)
776: (e-write3 'cmpb '"_typetable+1[r0]" val)
777: (d-invert)))
778:
779: ;--- d-typecmplx :: determine if arg has one of many types
780: ; - arg : lcode argument to be evaluated and checked
781: ; - vals : fixnum with a bit in position n if we are to check type n
782: ;
783: (defun d-typecmplx (arg vals)
784: (let ((argloc (d-simple arg))
785: (reg))
786: (If (null argloc) then (let ((g-loc 'reg)
787: g-cc g-ret)
788: (d-exp arg))
789: (setq argloc 'reg))
790: (setq reg 'r0)
791: (e-write4 'ashl '$-9 (e-cvt argloc) reg)
792: (e-write3 'cvtbl (concat "_typetable+1[" reg "]") reg)
793: (e-write4 'ashl reg '$1 reg)
794: (e-write3 'bitw vals reg)
795: (d-noninvert)))
796:
797:
798: ;---- register handling routines.
799:
800: ;--- d-allocreg :: allocate a register
801: ; name - the name of the register to allocate or nil if we should
802: ; allocate the least recently used.
803: ;
804: (defun d-allocreg (name)
805: (If name
806: then (let ((av (assoc name g-reguse)))
807: (If av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
808: name)
809: else ; find smallest used count
810: (do ((small (car g-reguse))
811: (smc (cadar g-reguse))
812: (lis (cdr g-reguse) (cdr lis)))
813: ((null lis)
814: (rplaca (cdr small) (1+ smc))
815: (car small))
816: (If (< (cadar lis) smc)
817: then (setq small (car lis)
818: smc (cadr small))))))
819:
820:
821: ;--- d-bestreg :: determine the register which is closest to what we have
822: ; name - name of variable whose subcontents we want
823: ; pat - list of d's and a's which tell which part we want
824: ;
825: (defun d-bestreg (name pat)
826: (do ((ll g-reguse (cdr ll))
827: (val)
828: (best)
829: (tmp)
830: (bestv -1))
831: ((null ll) (If best then (rplaca (cdr best) (1+ (cadr best)))
832: (list (car best)
833: (If (> bestv 0)
834: then (rplacd (nthcdr (1- bestv)
835: (setq tmp
836: (copy pat)))
837: nil)
838: tmp
839: else nil)
840: (nthcdr bestv pat))))
841: (If (and (setq val (cddar ll))
842: (eq name (car val)))
843: then (If (> (setq tmp (d-matchcnt pat (cdr val)))
844: bestv)
845: then (setq bestv tmp
846: best (car ll))))))
847:
848: ;--- d-matchcnt :: determine how many parts of a pattern match
849: ; want - pattern we want to achieve
850: ; have - pattern whose value exists in a register
851: ;
852: ; we return a count of the number of parts of the pattern match.
853: ; If this pattern will be any help at all, we return a value from
854: ; 0 to the length of the pattern.
855: ; If this pattern will not work at all, we return a number smaller
856: ; than -1.
857: ; For `have' to be useful for `want', `have' must be a substring of
858: ; `want'. If it is a substring, we return the length of `have'.
859: ;
860: (defun d-matchcnt (want have)
861: (let ((length 0))
862: (If (do ((hh have (cdr hh))
863: (ww want (cdr ww)))
864: ((null hh) t)
865: (If (or (null ww) (not (eq (car ww) (car hh))))
866: then (return nil)
867: else (incr length)))
868: then length
869: else -2)))
870:
871:
872:
873: ;--- d-clearreg :: clear all values in registers or just one
874: ; if no args are given, clear all registers.
875: ; if an arg is given, clear that register
876: ;
877: (defun d-clearreg n
878: (cond ((zerop n)
879: (mapc '(lambda (x) (rplaca (cdr x) 0)
880: (rplacd (cdr x) nil))
881: g-reguse))
882: (t (let ((av (assoc (arg 1) g-reguse)))
883: (If av then (rplaca (cdr av) 0)
884: (rplacd (cdr av) nil))))))
885:
886:
887: ;--- d-clearuse :: clear all register which reference a given variable
888: ;
889: (defun d-clearuse (varib)
890: (mapc '(lambda (x)
891: (If (eq (caddr x) varib) then (rplacd (cdr x) nil)))
892: g-reguse))
893:
894:
895: ;--- d-inreg :: declare that a value is in a register
896: ; name - register name
897: ; value - value in a register
898: ;
899: (defun d-inreg (name value)
900: (let ((av (assoc name g-reguse)))
901: (If av then (rplacd (cdr av) value))
902: name))
903:
904:
905: ;---- e routines
906:
907:
908:
909: (defun e-cvt (arg)
910: (If (eq 'reg arg) then 'r0
911: elseif (eq 'Nil arg) then '$0
912: elseif (eq 'T arg) then (If g-trueloc thenret
913: else (setq g-trueloc (e-cvt (d-loclit t nil))))
914: elseif (eq 'stack arg) then '(+ #.Np-reg)
915: elseif (eq 'unstack arg) then '(- #.Np-reg)
916: elseif (atom arg) then arg
917: elseif (dtpr arg) then (If (eq 'stack (car arg))
918: then `(,(* 4 (1- (cadr arg))) #.oLbot-reg)
919: elseif (eq 'vstack (car arg))
920: then `(* ,(* 4 (1- (cadr arg))) #.oLbot-reg)
921: elseif (eq 'bind (car arg))
922: then `(* ,(* 4 (1- (cadr arg))) #.bind-reg)
923: elseif (eq 'lbind (car arg))
924: then `( ,(* 4 (1- (cadr arg))) #.bind-reg)
925: elseif (eq 'fixnum (car arg))
926: then `(\# ,(cadr arg))
927: elseif (eq 'immed (car arg))
928: then `($ ,(cadr arg))
929: elseif (eq 'racc (car arg))
930: then (cdr arg)
931: else (comp-err " bad arg to e-cvt : "
932: (or arg)))
933: else (comp-warn "bad arg to e-cvt : " (or arg))))
934:
935:
936: ;--- e-uncvt :: inverse of e-cvt, used for making comments pretty
937: ;
938: (defun e-uncvt (arg)
939: (If (atom arg) then (If (eq 'Nil arg) then nil
940: else arg)
941: elseif (eq 'stack (car arg))
942: then (do ((i g-loccnt)
943: (ll g-locs))
944: ((and (equal i (cadr arg)) (atom (car ll))) (car ll))
945: (If (atom (car ll)) then (setq ll (cdr ll)
946: i (1- i))
947: else (setq ll (cdr ll))))
948: elseif (or (eq 'bind (car arg)) (eq 'lbind (car arg)))
949: then (do ((i g-litcnt (1- i))
950: (ll g-lits (cdr ll)))
951: ((equal i (cadr arg)) (cond ((eq 'lbind (car arg))
952: (list 'quote (car ll)))
953: (t (car ll)))))
954: else arg))
955:
956: ;--- e-cvtas :: convert an EIADR to vax unix assembler fmt and print it
957: ; - form : an EIADR form
958: ;
959: (defun e-cvtas (form)
960: (If (atom form)
961: then (sfilewrite form)
962: else (If (eq '* (car form)) then (If (eq '\# (cadr form))
963: then (setq form `($ ,(caddr form)))
964: else (sfilewrite "*")
965: (setq form (cdr form))))
966: (If (numberp (car form))
967: then (sfilewrite (car form))
968: (sfilewrite "(")
969: (sfilewrite (cadr form))
970: (sfilewrite ")")
971: (If (caddr form)
972: then (sfilewrite "[")
973: (sfilewrite (caddr form))
974: (sfilewrite "]"))
975: elseif (eq '+ (car form))
976: then (sfilewrite '"(")
977: (sfilewrite (cadr form))
978: (sfilewrite '")+")
979: elseif (eq '- (car form))
980: then (sfilewrite '"-(")
981: (sfilewrite (cadr form))
982: (sfilewrite '")")
983: elseif (eq '\# (car form)) ; 5120 is base of small fixnums
984: then (sfilewrite (concat "$" (+ (* (cadr form) 4) 5120)))
985: elseif (eq '$ (car form))
986: then (sfilewrite '"$")
987: (sfilewrite (cadr form)))))
988: ;--- e-cmp :: emit code to compare the two given args
989: ; - arg1, arg2 : EIADRs
990: ;
991: (defun e-cmp (arg1 arg2)
992: (e-write3 'cmpl arg1 arg2))
993:
994: ;--- e-docomment :: print any comment lines
995: ;
996: (defun e-docomment nil
997: (If g-comments
998: then (do ((ll (nreverse g-comments) (cdr ll)))
999: ((null ll))
1000: (sfilewrite '" #")
1001: (sfilewrite (car ll))
1002: (terpr vp-sfile))
1003: (setq g-comments nil)
1004: else (terpr vp-sfile)))
1005: ;--- e-goto :: emit code to jump to the location given
1006: ;
1007: (defun e-goto (lbl)
1008: (e-jump lbl))
1009:
1010: ;--- e-gotonil :: emit code to jump if nil was last computed
1011: ;
1012: (defun e-gotonil (lbl)
1013: (e-write2 'jeql lbl))
1014:
1015: ;--- e-gotot :: emit code to jump if t was last computed
1016: (defun e-gotot (lbl)
1017: (e-write2 'jneq lbl))
1018:
1019: ;--- e-label :: emit a label
1020: (defun e-label (lbl)
1021: (setq g-skipcode nil)
1022: (e-writel lbl))
1023:
1024: ;--- e-move :: move value from one place to anther
1025: ; this corresponds to d-move except the args are EIADRS
1026: ;
1027: (defun e-move (from to)
1028: (If (equal 0 from) then (e-write2 'clrl to)
1029: else (e-write3 'movl from to)))
1030:
1031: ;--- e-pop :: pop the given number of args from the stack
1032: ; g-locs is not! fixed
1033: ;
1034: (defun e-pop (nargs)
1035: (If (greaterp nargs 0)
1036: then (e-dropnp nargs)))
1037:
1038:
1039: ;--- e-pushnil :: push a given number of nils on the stack
1040: ;
1041: (defun e-pushnil (nargs)
1042: (do ((i nargs))
1043: ((zerop i))
1044: (If (greaterp i 1) then (e-write2 'clrq np-plus)
1045: (setq i (- i 2))
1046: elseif (equal i 1) then (e-write2 'clrl np-plus)
1047: (setq i (1- i)))))
1048:
1049: ;--- e-tst :: test a value, arg is an EIADR
1050: ;
1051: (defun e-tst (arg)
1052: (e-write2 'tstl arg))
1053: ;--- e-setupbind :: setup for shallow binding
1054: ;
1055: (defun e-setupbind nil
1056: (e-write3 'movl '#.Bnp-val '#.bNp-reg))
1057:
1058: ;--- e-unsetupbind :: restore temp value of bnp to real loc
1059: ;
1060: (defun e-unsetupbind nil
1061: (e-write3 'movl '#.bNp-reg '#.Bnp-val))
1062:
1063: ;--- e-shallowbind :: shallow bind value of variable and initialize it
1064: ; - name : variable name
1065: ; - val : IADR value for variable
1066: ;
1067: (defun e-shallowbind (name val)
1068: (let ((vloc (d-loclit name t)))
1069: (e-write3 'movl (e-cvt vloc) '(+ #.bNp-reg)) ; store old val
1070: (e-write3 'movl (e-cvt `(lbind ,@(cdr vloc)))
1071: '(+ #.bNp-reg)) ; now name
1072: (d-move val vloc)))
1073:
1074: ;--- e-unshallowbind :: un shallow bind n variable from top of stack
1075: ;
1076: (defun e-unshallowbind (n)
1077: (e-setupbind) ; set up binding register
1078: (do ((i 1 (1+ i)))
1079: ((greaterp i n))
1080: (e-write3 'movl `(,(* -8 i) ,bNp-reg) `(* ,(+ 4 (* -8 i)) ,bNp-reg)))
1081: (e-write4 'subl3 `($ ,(* 8 n)) bNp-reg Bnp-val))
1082:
1083: ;----------- very low level routines
1084: ; all output to the assembler file goes through these routines.
1085: ; They filter out obviously extraneous instructions as well as
1086: ; combine sequential drops of np.
1087:
1088: ;--- e-dropnp :: unstack n values from np.
1089: ; rather than output the instruction now, we just remember that it
1090: ; must be done before any other instructions are done. This will
1091: ; enable us to catch sequential e-dropnp's
1092: ;
1093: (defun e-dropnp (n)
1094: (If (not g-skipcode)
1095: then (setq g-dropnpcnt (+ n (If g-dropnpcnt thenret else 0)))))
1096:
1097: ;--- em-checknpdrop :: check if we have a pending npdrop
1098: ; and do it if so.
1099: ;
1100: (defmacro em-checknpdrop nil
1101: `(If g-dropnpcnt then (let ((dr g-dropnpcnt))
1102: (setq g-dropnpcnt nil)
1103: (e-write3 'subl2 `($ ,(* dr 4)) Np-reg))))
1104:
1105: ;--- em-checkskip :: check if we are skipping this code due to jump
1106: ;
1107: (defmacro em-checkskip nil
1108: '(If g-skipcode then (sfilewrite "# ")))
1109:
1110:
1111: ;--- e-jump :: jump to given label
1112: ; and set g-skipcode so that all code following until the next label
1113: ; will be skipped.
1114: ;
1115: (defun e-jump (l)
1116: (em-checknpdrop)
1117: (e-write2 'jbr l)
1118: (setq g-skipcode t))
1119:
1120: ;--- e-return :: do return, and dont check for np drop
1121: ;
1122: (defun e-return nil
1123: (setq g-dropnpcnt nil) ; we dont need to worry about nps
1124: (e-write1 'ret))
1125:
1126:
1127: ;--- e-writel :: write out a label
1128: ;
1129: (defun e-writel (label)
1130: (setq g-skipcode nil)
1131: (em-checknpdrop)
1132: (sfilewrite label)
1133: (sfilewrite '":")
1134: (e-docomment))
1135:
1136: ;--- e-write1 :: write out one litteral
1137: ;
1138: (defun e-write1 (lit)
1139: (em-checkskip)
1140: (em-checknpdrop)
1141: (sfilewrite lit)
1142: (e-docomment))
1143:
1144: ;--- e-write2 :: write one one litteral, and one operand
1145: ;
1146: (defun e-write2 (lit frm)
1147: (em-checkskip)
1148: (em-checknpdrop)
1149: (sfilewrite lit)
1150: (sfilewrite '" ")
1151: (e-cvtas frm)
1152: (e-docomment))
1153:
1154: ;--- e-write3 :: write one one litteral, and two operands
1155: ;
1156: (defun e-write3 (lit frm1 frm2)
1157: (em-checkskip)
1158: (em-checknpdrop)
1159: (sfilewrite lit)
1160: (sfilewrite '" ")
1161: (e-cvtas frm1)
1162: (sfilewrite '",")
1163: (e-cvtas frm2)
1164: (e-docomment))
1165:
1166: ;--- e-write4 :: write one one litteral, and three operands
1167: ;
1168: (defun e-write4 (lit frm1 frm2 frm3)
1169: (em-checkskip)
1170: (em-checknpdrop)
1171: (sfilewrite lit)
1172: (sfilewrite '" ")
1173: (e-cvtas frm1)
1174: (sfilewrite '",")
1175: (e-cvtas frm2)
1176: (sfilewrite '",")
1177: (e-cvtas frm3)
1178: (e-docomment))
1179:
1180:
1181: ;--- e-write5 :: write one one litteral, and four operands
1182: ;
1183: (defun e-write5 (lit frm1 frm2 frm3 frm4)
1184: (em-checkskip)
1185: (em-checknpdrop)
1186: (sfilewrite lit)
1187: (sfilewrite '" ")
1188: (e-cvtas frm1)
1189: (sfilewrite '",")
1190: (e-cvtas frm2)
1191: (sfilewrite '",")
1192: (e-cvtas frm3)
1193: (sfilewrite '",")
1194: (e-cvtas frm4)
1195: (e-docomment))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.