![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to datab.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 datab.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 datab
3: "$Header: datab.l,v 1.5 83/08/28 17:14:27 layer Exp $")
4:
5: ;;; ---- d a t a b data base
6: ;;;
7: ;;; -[Sat Aug 6 23:59:11 1983 by layer]-
8:
9: ;--- d-tranloc :: locate a function in the transfer table
10: ;
11: ; return the offset we should use for this function call
12: ;
13: (defun d-tranloc (fname)
14: (cond ((get fname g-tranloc))
15: (t (Push g-tran fname)
16: (let ((newval (* 8 g-trancnt)))
17: (putprop fname newval g-tranloc)
18: (incr g-trancnt)
19: newval))))
20:
21:
22: ;--- d-loc :: return the location of the variable or value in IADR form
23: ; - form : form whose value we are to locate
24: ;
25: ; if we are given a xxx as form, we check yyy;
26: ; xxx yyy
27: ; -------- ---------
28: ; nil Nil is always returned
29: ; symbol return the location of the symbols value, first looking
30: ; in the registers, then on the stack, then the bind list.
31: ; If g-ingorereg is t then we don't check the registers.
32: ; We would want to do this if we were interested in storing
33: ; something in the symbol's value location.
34: ; number always return the location of the number on the bind
35: ; list (as a (lbind n))
36: ; other always return the location of the other on the bind
37: ; list (as a (lbind n))
38: ;
39: (defun d-loc (form)
40: (if (null form) then 'Nil
41: elseif (numberp form) then
42: (if (and (fixp form) (greaterp form -1025) (lessp form 1024))
43: then `(fixnum ,form) ; small fixnum
44: else (d-loclit form nil))
45: elseif (symbolp form)
46: then (if (and (null g-ignorereg) (car (d-bestreg form nil))) thenret
47: else (if (d-specialp form) then (d-loclit form t)
48: else (do ((ll g-locs (cdr ll)) ; check stack
49: (n g-loccnt))
50: ((null ll)
51: (comp-warn (or form)
52: " declared special by compiler")
53: (d-makespec form)
54: (d-loclit form t))
55: (if (atom (car ll))
56: then (if (eq form (car ll))
57: then (return `(stack ,n))
58: else (setq n (1- n)))))))
59: else (d-loclit form nil)))
60:
61:
62: ;--- d-loclit :: locate or add litteral to bind list
63: ; - form : form to check for and add if not present
64: ; - flag : if t then if we are given a symbol, return the location of
65: ; its value, else return the location of the symbol itself
66: ;
67: ; scheme: we share the locations of atom (symbols,numbers,string) but always
68: ; create a fresh copy of anything else.
69: (defun d-loclit (form flag)
70: (prog (loc onplist symboltype)
71: (if (null form)
72: then (return 'Nil)
73: elseif (symbolp form)
74: then (setq symboltype t)
75: (cond ((setq loc (get form g-bindloc))
76: (setq onplist t)))
77: elseif (atom form)
78: then (do ((ll g-lits (cdr ll)) ; search for atom on list
79: (n g-litcnt (1- n)))
80: ((null ll))
81: (if (eq form (car ll))
82: then (setq loc n) ; found it
83: (return)))) ; leave do
84: (if (null loc)
85: then (Push g-lits form)
86: (setq g-litcnt (1+ g-litcnt)
87: loc g-litcnt)
88: (cond ((and symboltype (null onplist))
89: (putprop form loc g-bindloc))))
90:
91: (return (if (and flag symboltype) then `(bind ,loc)
92: else `(lbind ,loc)))))
93:
94:
95:
96: ;--- d-locv :: find the location of a value cell, and dont return a register
97: ;
98: (defun d-locv (sm)
99: (let ((g-ignorereg t))
100: (d-loc sm)))
101:
102:
103: ;--- d-simple :: see of arg can be addresses in one instruction
104: ; we define simple and really simple as follows
105: ; <rsimple> ::= number
106: ; quoted anything
107: ; local symbol
108: ; t
109: ; nil
110: ; <simple> ::= <rsimple>
111: ; (cdr <rsimple>)
112: ; global symbol
113: ;
114: (defun d-simple (arg)
115: (let (tmp)
116: (if (d-rsimple arg) thenret
117: elseif (atom arg) then (d-loc arg)
118: elseif (and (memq (car arg) '(cdr car cddr cdar))
119: (setq tmp (d-rsimple (cadr arg))))
120: then (if (eq 'Nil tmp) then tmp
121: elseif (atom tmp)
122: then #+for-vax
123: (if (eq 'car (car arg))
124: then `(racc 4 ,tmp)
125: elseif (eq 'cdr (car arg))
126: then `(racc 0 ,tmp)
127: elseif (eq 'cddr (car arg))
128: then `(racc * 0 ,tmp)
129: elseif (eq 'cdar (car arg))
130: then `(racc * 4 ,tmp))
131: #+for-68k
132: (if (eq 'car (car arg))
133: then `(racc 4 ,tmp)
134: elseif (eq 'cdr (car arg))
135: then `(racc 0 ,tmp))
136: elseif (not (eq 'cdr (car arg)))
137: then nil
138: elseif (eq 'lbind (car tmp))
139: then `(bind ,(cadr tmp))
140: elseif (eq 'stack (car tmp))
141: then `(vstack ,(cadr tmp))
142: elseif (eq 'fixnum (car tmp))
143: then `(immed ,(cadr tmp))
144: elseif (atom (car tmp))
145: then `(0 ,(cadr tmp))
146: else (comp-err "bad arg to d-simple: " (or arg))))))
147:
148: (defun d-rsimple (arg)
149: (if (atom arg) then
150: (if (null arg) then 'Nil
151: elseif (eq t arg) then 'T
152: elseif (or (numberp arg)
153: (memq arg g-locs))
154: then (d-loc arg)
155: else (car (d-bestreg arg nil)))
156: elseif (eq 'quote (car arg)) then (d-loclit (cadr arg) nil)))
157:
158: ;--- d-specialp :: check if a variable is special
159: ; a varible is special if it has been declared as such, or if
160: ; the variable special is t
161: (defun d-specialp (vrb)
162: (or special
163: (eq 'special (d-findfirstprop vrb 'bindtype)) ; local special decl
164: (eq 'special (get vrb g-bindtype))))
165:
166: (defun d-fixnump (vrb)
167: (and (symbolp vrb)
168: (or (eq 'fixnum (d-findfirstprop vrb 'vartype))
169: (eq 'fixnum (get vrb g-vartype)))))
170:
171: ;--- d-functyp :: return the type of function
172: ; - name : function name
173: ;
174: ; If name had a macro function definition, we return `macro'. Otherwise
175: ; we see if name as a declared type, if so we return that. Otherwise
176: ; we see if name is defined and we return that if so, and finally if
177: ; we have no idea what this function is, we return lambda.
178: ; This is not really satisfactory, but will handle most cases.
179: ;
180: ; If macrochk is nil then we don't check for the macro case. This
181: ; is important to prevent recursive macroexpansion.
182: ;
183: (defun d-functyp (name macrochk)
184: (let (func ftyp)
185: (if (atom name)
186: then
187: (setq func (getd name))
188: (setq ftyp (if (and macrochk (get name 'cmacro)) ;compiler macro
189: then 'cmacro
190: elseif (bcdp func)
191: then (let ((type (getdisc func)))
192: (if (memq type '(lambda nlambda macro))
193: then type
194: elseif (stringp type)
195: then 'lambda ; foreign function
196: else (comp-warn
197: "function "
198: name
199: " has a strange discipline "
200: type)
201: 'lambda ; assume lambda
202: ))
203: elseif (dtpr func)
204: then (car func)
205: elseif (and macrochk (get name 'macro-autoload))
206: then 'macro))
207: (if (memq ftyp '(macro cmacro)) then ftyp
208: elseif (d-findfirstprop name 'functype) thenret
209: elseif (get name g-functype) thenret ; check if declared first
210: elseif ftyp thenret
211: else 'lambda)
212: else 'lambda))) ; default is lambda
213:
214: ;--- d-allfixnumargs :: check if all forms are fixnums
215: ; make sure all forms are fixnums or symbols whose declared type are fixnums
216: ;
217: (defun d-allfixnumargs (forms)
218: (do ((xx forms (cdr xx))
219: (arg))
220: ((null xx) t)
221: (cond ((and (fixp (setq arg (car xx))) (not (bigp arg))))
222: ((d-fixnump arg))
223: (t (return nil)))))
224:
225:
226: (defun d-findfirstprop (name type)
227: (do ((xx g-decls (cdr xx))
228: (rcd))
229: ((null xx))
230: (if (and (eq name (caar xx))
231: (get (setq rcd (cdar xx)) type))
232: then (return rcd))))
233:
234:
235:
236:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.