![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to util.l CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt|
Return to util.l CVS log | Up to [CSRG BSD Unix] / 43BSD / ucb / lisp / liszt |
1.1 root 1: (include-if (null (get 'chead 'version)) "../chead.l")
2: (Liszt-file util
3: "$Header: util.l,v 1.14 83/08/28 17:13:11 layer Exp $")
4:
5: ;;; ---- u t i l general utility functions
6: ;;;
7: ;;; -[Tue Aug 16 17:17:32 1983 by layer]-
8:
9:
10: ;--- d-handlecc :: handle g-cc
11: ; at this point the Z condition code has been set up and if g-cc is
12: ; non nil, we must jump on condition to the label given in g-cc
13: ;
14: (defun d-handlecc nil
15: (if (car g-cc)
16: then (e-gotot (car g-cc))
17: elseif (cdr g-cc)
18: then (e-gotonil (cdr g-cc))))
19:
20: ;--- d-invert :: handle inverted condition codes
21: ; this routine is called if a result has just be computed which alters
22: ; the condition codes such that Z=1 if the result is t, and Z=0 if the
23: ; result is nil (this is the reverse of the usual sense). The purpose
24: ; of this routine is to handle g-cc and g-loc. That is if g-loc is
25: ; specified, we must convert the value of the Z bit of the condition
26: ; code to t or nil and store that in g-loc. After handling g-loc we
27: ; must handle g-cc, that is if the part of g-cc is non nil which matches
28: ; the inverse of the current condition code, we must jump to that.
29: ;
30: (defun d-invert nil
31: (if (null g-loc)
32: then (if (car g-cc) then (e-gotonil (car g-cc))
33: elseif (cdr g-cc) then (e-gotot (cdr g-cc)))
34: else (let ((lab1 (d-genlab))
35: (lab2 (if (cdr g-cc) thenret else (d-genlab))))
36: (e-gotonil lab1)
37: ; Z=1, but remember that this implies nil due to inversion
38: (d-move 'Nil g-loc)
39: (e-goto lab2)
40: (e-label lab1)
41: ; Z=0, which means t
42: (d-move 'T g-loc)
43: (if (car g-cc) then (e-goto (car g-cc)))
44: (if (null (cdr g-cc)) then (e-label lab2)))))
45:
46: ;--- d-noninvert :: handle g-cc and g-loc assuming cc non inverted
47: ;
48: ; like d-invert except Z=0 implies nil, and Z=1 implies t
49: ;
50: (defun d-noninvert nil
51: (if (null g-loc)
52: then (if (car g-cc) then (e-gotot (car g-cc))
53: elseif (cdr g-cc) then (e-gotonil (cdr g-cc)))
54: else (let ((lab1 (d-genlab))
55: (lab2 (if (cdr g-cc) thenret else (d-genlab))))
56: (e-gotot lab1)
57: ; Z=0, this implies nil
58: (d-move 'Nil g-loc)
59: (e-goto lab2)
60: (e-label lab1)
61: ; Z=1, which means t
62: (d-move 'T g-loc)
63: (if (car g-cc) then (e-goto (car g-cc)))
64: (if (null (cdr g-cc)) then (e-label lab2)))))
65:
66: ;--- d-macroexpand :: macro expand a form as much as possible
67: ;
68: ; only macro expands the top level though.
69: (defun d-macroexpand (i)
70: (prog (first type)
71: loop
72: (if (and (dtpr i) (symbolp (setq first (car i))))
73: then (if (eq 'macro (setq type (d-functyp first 'macro-ok)))
74: then (setq i (apply first i))
75: (go loop)
76: elseif (eq 'cmacro type)
77: then (setq i (apply (get first 'cmacro) i))
78: (go loop)))
79: (return i)))
80:
81: ;--- d-fullmacroexpand :: macro expand down all levels
82: ; this is not always possible to due since it is not always clear
83: ; if a function is a lambda or nlambda, and there are lots of special
84: ; forms. This is just a first shot at such a function, this should
85: ; be improved upon.
86: ;
87: (defun d-fullmacroexpand (form)
88: (if (not (dtpr form))
89: then form
90: else (setq form (d-macroexpand form)) ; do one level
91: (if (and (dtpr form) (symbolp (car form)))
92: then (let ((func (getd (car form))))
93: (if (or (and (bcdp func)
94: (eq 'lambda (getdisc func)))
95: (and (dtpr func)
96: (memq (car func) '(lambda lexpr)))
97: (memq (car form) '(or and)))
98: then `(,(car form)
99: ,@(mapcar 'd-fullmacroexpand
100: (cdr form)))
101: elseif (eq (car form) 'setq)
102: then (d-setqexpand form)
103: else form))
104: else form)))
105:
106: ;--- d-setqexpand :: macro expand a setq statemant
107: ; a setq is unusual in that alternate values are macroexpanded.
108: ;
109: (defun d-setqexpand (form)
110: (if (oddp (length (cdr form)))
111: then (comp-err "wrong number of args to setq " form)
112: else (do ((xx (reverse (cdr form)) (cddr xx))
113: (res))
114: ((null xx) (cons 'setq res))
115: (setq res `(,(cadr xx)
116: ,(d-fullmacroexpand (car xx))
117: ,@res)))))
118:
119: ;--- d-typesimp :: determine the type of the argument
120: ;
121: #+for-vax
122: (defun d-typesimp (arg val)
123: (let ((argloc (d-simple arg)))
124: (if (null argloc)
125: then (let ((g-loc 'reg)
126: g-cc g-ret)
127: (d-exp arg))
128: (setq argloc 'reg))
129: (e-write4 'ashl '$-9 (e-cvt argloc) 'r0)
130: (e-write3 'cmpb '"_typetable+1[r0]" val)
131: (d-invert)))
132:
133: #+for-68k
134: (defun d-typesimp (arg val)
135: (let ((argloc (d-simple arg)))
136: (if (null argloc)
137: then (let ((g-loc 'reg)
138: g-cc g-ret)
139: (d-exp arg))
140: (setq argloc 'reg)
141: else (e-move (e-cvt argloc) 'd0))
142: (e-sub '#.nil-reg 'd0)
143: (e-write3 'moveq '($ 9) 'd1)
144: (e-write3 'asrl 'd1 'd0)
145: (e-write3 'lea '"_typetable+1" 'a5)
146: (e-write3 'cmpb val '(% 0 a5 d0))
147: (d-invert)))
148:
149: ;--- d-typecmplx :: determine if arg has one of many types
150: ; - arg : lcode argument to be evaluated and checked
151: ; - vals : fixnum with a bit in position n if we are to check type n
152: ;
153: #+for-vax
154: (defun d-typecmplx (arg vals)
155: (let ((argloc (d-simple arg))
156: (reg))
157: (if (null argloc) then (let ((g-loc 'reg)
158: g-cc g-ret)
159: (d-exp arg))
160: (setq argloc 'reg))
161: (setq reg 'r0)
162: (e-write4 'ashl '$-9 (e-cvt argloc) reg)
163: (e-write3 'cvtbl (concat "_typetable+1[" reg "]") reg)
164: (e-write4 'ashl reg '$1 reg)
165: (e-write3 'bitw vals reg)
166: (d-noninvert)))
167:
168: #+for-68k
169: (defun d-typecmplx (arg vals)
170: (let ((argloc (d-simple arg))
171: (l1 (d-genlab))
172: (l2 (d-genlab)))
173: (makecomment '(d-typecmplx: type check))
174: (if (null argloc)
175: then (let ((g-loc 'reg)
176: g-cc g-ret)
177: (d-exp arg))
178: (setq argloc 'reg)
179: else (e-move (e-cvt argloc) 'd0))
180: (e-sub '#.nil-reg 'd0)
181: (e-write3 'moveq '($ 9) 'd1)
182: (e-write3 'asrl 'd1 'd0)
183: (e-write3 'lea '"_typetable+1" 'a5)
184: (e-add 'd0 'a5)
185: (e-write3 'movb '(0 a5) 'd0)
186: (e-write2 'extw 'd0)
187: (e-write2 'extl 'd0)
188: (e-write3 'moveq '($ 1) 'd1)
189: (e-write3 'asll 'd0 'd1)
190: (e-move 'd1 'd0)
191: (e-write3 'andw vals 'd0)
192: (d-noninvert)
193: (makecomment '(d-typecmplx: end))))
194:
195: ;---- register handling routines.
196:
197: ;--- d-allocreg :: allocate a register
198: ; name - the name of the register to allocate or nil if we should
199: ; allocate the least recently used.
200: ;
201: (defun d-allocreg (name)
202: (if name
203: then (let ((av (assoc name g-reguse)))
204: (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
205: name)
206: else ; find smallest used count
207: (do ((small (car g-reguse))
208: (smc (cadar g-reguse))
209: (lis (cdr g-reguse) (cdr lis)))
210: ((null lis)
211: (rplaca (cdr small) (1+ smc))
212: (car small))
213: (if (< (cadar lis) smc)
214: then (setq small (car lis)
215: smc (cadr small))))))
216:
217:
218: ;--- d-bestreg :: determine the register which is closest to what we have
219: ; name - name of variable whose subcontents we want
220: ; pat - list of d's and a's which tell which part we want
221: ;
222: (defun d-bestreg (name pat)
223: (do ((ll g-reguse (cdr ll))
224: (val)
225: (best)
226: (tmp)
227: (bestv -1))
228: ((null ll)
229: (if best
230: then (rplaca (cdr best) (1+ (cadr best)))
231: (list (car best)
232: (if (> bestv 0)
233: then (rplacd (nthcdr (1- bestv)
234: (setq tmp
235: (copy pat)))
236: nil)
237: tmp
238: else nil)
239: (nthcdr bestv pat))))
240: (if (and (setq val (cddar ll))
241: (eq name (car val)))
242: then (if (> (setq tmp (d-matchcnt pat (cdr val)))
243: bestv)
244: then (setq bestv tmp
245: best (car ll))))))
246:
247: ;--- d-matchcnt :: determine how many parts of a pattern match
248: ; want - pattern we want to achieve
249: ; have - pattern whose value exists in a register
250: ;
251: ; we return a count of the number of parts of the pattern match.
252: ; If this pattern will be any help at all, we return a value from
253: ; 0 to the length of the pattern.
254: ; If this pattern will not work at all, we return a number smaller
255: ; than -1.
256: ; For `have' to be useful for `want', `have' must be a substring of
257: ; `want'. If it is a substring, we return the length of `have'.
258: ;
259: (defun d-matchcnt (want have)
260: (let ((length 0))
261: (if (do ((hh have (cdr hh))
262: (ww want (cdr ww)))
263: ((null hh) t)
264: (if (or (null ww) (not (eq (car ww) (car hh))))
265: then (return nil)
266: else (incr length)))
267: then length
268: else -2)))
269:
270: ;--- d-clearreg :: clear all values in registers or just one
271: ; if no args are given, clear all registers.
272: ; if an arg is given, clear that register
273: ;
274: (defun d-clearreg n
275: (cond ((zerop n)
276: (mapc '(lambda (x) (rplaca (cdr x) 0)
277: (rplacd (cdr x) nil))
278: g-reguse))
279: (t (let ((av (assoc (arg 1) g-reguse)))
280: (if av
281: then
282: #+for-68k (d-regused (car av))
283: (rplaca (cdr av) 0)
284: (rplacd (cdr av) nil)
285: else nil)))))
286:
287: ;--- d-clearuse :: clear all register which reference a given variable
288: ;
289: (defun d-clearuse (varib)
290: (mapc '(lambda (x)
291: (if (eq (caddr x) varib) then (rplacd (cdr x) nil)))
292: g-reguse))
293:
294: ;--- d-inreg :: declare that a value is in a register
295: ; name - register name
296: ; value - value in a register
297: ;
298: (defun d-inreg (name value)
299: (let ((av (assoc name g-reguse)))
300: (if av then (rplacd (cdr av) value))
301: name))
302:
303: (defun e-setup-np-lbot nil
304: (e-move '#.np-reg '#.np-sym)
305: (e-move '#.lbot-reg '#.lbot-sym))
306:
307: ;---------------MC68000 only routines
308: #+for-68k
309: (progn 'compile
310:
311: ;--- d-regtype :: find out what type of register the operand goes
312: ; in.
313: ; eiadr - an EIADR
314: ;
315: (defun d-regtype (eiadr)
316: (if (symbolp eiadr)
317: then (if (memq eiadr '(d0 d1 d2 d3 d4 d5 d6 d7 reg)) then 'd
318: elseif (memq eiadr '(a0 a1 a2 a3 a4 a5 a6 a7 sp areg)) then 'a)
319: elseif (or (eq '\# (car eiadr))
320: (eq '$ (car eiadr))
321: (and (eq '* (car eiadr))
322: (eq '\# (cadr eiadr))))
323: then 'd
324: else 'a))
325:
326: ;--- d-regused :: declare that a reg is used in a function
327: ; regname - name of the register that is going to be used
328: ; (ie, 'd0 'a2...)
329: ;
330: (defun d-regused (regname)
331: (let ((regnum (diff (cadr (exploden regname)) 48))
332: (regtype (car (explode regname))))
333: (if (memq regname '(a0 a1 d0 d1))
334: thenret
335: elseif (equal 'd regtype)
336: then (rplacx regnum g-regmaskvec t) regname
337: else (rplacx (plus regnum 8) g-regmaskvec t) regname)))
338:
339: ;--- d-makemask :: make register mask for moveml instr
340: ;
341: (defun d-makemask ()
342: (do ((ii 0 (1+ ii))
343: (mask 0))
344: ((greaterp ii 15) mask)
345: (if (cxr ii g-regmaskvec)
346: then (setq mask (plus mask (expt 2 ii))))))
347:
348: ;--- init-regmaskvec :: initalize hunk structure to all default
349: ; save mask.
350: ;
351: ; nil means don't save it, and t means save the register upon function entry.
352: ; order in vector: d0 .. d7, a0 .. a7.
353: ; d3 : lbot (if $global-reg$ is t then save)
354: ; d7 : _nilatom
355: ; a2 : _np
356: ; a3 : literal table ptr
357: ; a4 : old _lbot (if $global-reg$ is t don't save)
358: ; a5 : intermediate address calc
359: ;
360: (defun init-regmaskvec ()
361: (setq g-regmaskvec
362: (makhunk
363: (if $global-reg$
364: then (quote (nil nil nil t nil nil nil t
365: nil nil t t t t nil nil))
366: else (quote (nil nil nil nil nil nil nil t
367: nil nil t t t t nil nil))))))
368:
369: ;--- Cstackspace :: calc local space on C stack
370: ; space = 4 * (no. of register variables saved on stack)
371: ;
372: (defun Cstackspace ()
373: (do ((ii 0 (1+ ii))
374: (retval 0))
375: ((greaterp ii 15) (* 4 retval))
376: (if (cxr ii g-regmaskvec) then (setq retval (1+ retval)))))
377:
378: ;--- d-alloc-register :: allocate a register
379: ; type - type of register (a or d)
380: ; name - the name of the register to allocate or nil if we should
381: ; allocate the least recently used.
382: ;
383: (defun d-alloc-register (type name)
384: (if name
385: then (let ((av (assoc name g-reguse)))
386: (d-regused name)
387: (if av then (rplaca (cdr av) (1+ (cadr av)))) ; inc used count
388: name)
389: else ; find smallest used count
390: (let ((reguse))
391: (do ((cur g-reguse (cdr cur)))
392: ((null cur))
393: (if (eq type (car (explode (caar cur))))
394: then (setq reguse (cons (car cur) reguse))))
395: (do ((small (car reguse))
396: (smc (cadar reguse))
397: (lis (cdr reguse) (cdr lis)))
398: ((null lis)
399: (rplaca (cdr small) (1+ smc))
400: (d-regused (car small))
401: (car small))
402: (if (< (cadar lis) smc)
403: then (setq small (car lis)
404: smc (cadr small)))))))
405:
406: ); end 68000 only routines
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.