![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to decl.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 decl.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 decl
3: "$Header: decl.l,v 1.8 83/08/28 17:13:00 layer Exp $")
4:
5: ;;; ---- d e c l declaration handling
6: ;;;
7: ;;; -[Sat Aug 6 23:58:35 1983 by layer]-
8:
9:
10: (setq original-readtable readtable)
11: (setq raw-readtable (makereadtable t))
12:
13: ;--- compile-fcn :: declare a open coded function
14: ; name - name of the function
15: ; fcnname - function to be funcall'ed to handle the open coding
16: ; indicator - describes what the fcnname will do, one of
17: ; fl-expr : will compile the expression and leave the
18: ; result in r0. Will ignore g-cc and g-loc
19: ; fl-exprcc: will compile the expression and leave the
20: ; result in g-loc. Will handle g-cc
21: ; fl-exprm: will just return another form to be d-exp'ed
22: ; args - (optional) description of the arguments to this function.
23: ; form: (min-args . max-args) . If max-args is nil, then there is
24: ; no max. This is usually done in /usr/lib/lisp/fcninfo.l.
25: ;
26: (defmacro compile-fcn (name fcnname indicator &optional (args nil args-p))
27: `(progn (putprop ',name ',fcnname ',indicator)
28: ;; don't do this here, done in fcn-info
29: ,@(cond (args-p `((putprop ',name (list ',args) 'fcn-info))))))
30:
31:
32: ;--- special handlers
33: (compile-fcn and cc-and fl-exprcc)
34: (compile-fcn arg cc-arg fl-exprcc)
35: (compile-fcn assq cm-assq fl-exprm)
36: (compile-fcn atom cc-atom fl-exprcc)
37: (compile-fcn bigp cc-bigp fl-exprcc)
38: (compile-fcn bcdcall c-bcdcall fl-expr)
39: (compile-fcn Internal-bcdcall c-Internal-bcdcall fl-expr)
40: (compile-fcn bcdp cc-bcdp fl-exprcc)
41: #+for-vax
42: (compile-fcn boole c-boole fl-expr)
43: (compile-fcn *catch c-*catch fl-expr)
44: (compile-fcn comment cc-ignore fl-exprcc)
45: (compile-fcn cond c-cond fl-expr)
46: (compile-fcn cons c-cons fl-expr)
47: (compile-fcn cxr cc-cxr fl-exprcc)
48: (compile-fcn declare c-declare fl-expr)
49: (compile-fcn do c-do fl-expr)
50: (compile-fcn liszt-internal-do c-do fl-expr)
51: (compile-fcn dtpr cc-dtpr fl-exprcc)
52: (compile-fcn eq cc-eq fl-exprcc)
53: (compile-fcn equal cc-equal fl-exprcc)
54: (compile-fcn errset c-errset fl-expr)
55: (compile-fcn fixp cc-fixp fl-exprcc)
56: (compile-fcn floatp cc-floatp fl-exprcc)
57: (compile-fcn funcall c-funcall fl-expr)
58: (compile-fcn function cc-function fl-exprcc)
59: (compile-fcn get c-get fl-expr)
60: (compile-fcn getaccess cm-getaccess fl-exprm)
61: (compile-fcn getaux cm-getaux fl-exprm)
62: (compile-fcn getd cm-getd fl-exprm)
63: (compile-fcn getdata cm-getdata fl-exprm)
64: (compile-fcn getdisc cm-getdisc fl-exprm)
65: (compile-fcn go c-go fl-expr)
66: (compile-fcn list c-list fl-expr)
67: (compile-fcn map cm-map fl-exprm)
68: (compile-fcn mapc cm-mapc fl-exprm)
69: (compile-fcn mapcan cm-mapcan fl-exprm)
70: (compile-fcn mapcar cm-mapcar fl-exprm)
71: (compile-fcn mapcon cm-mapcon fl-exprm)
72: (compile-fcn maplist cm-maplist fl-exprm)
73: (compile-fcn memq cc-memq fl-exprcc)
74: (compile-fcn ncons cm-ncons fl-exprm)
75: (compile-fcn not cc-not fl-exprcc)
76: (compile-fcn null cc-not fl-exprcc)
77: (compile-fcn numberp cc-numberp fl-exprcc)
78: (compile-fcn or cc-or fl-exprcc)
79: (compile-fcn prog c-prog fl-expr)
80: (compile-fcn progn cm-progn fl-exprm)
81: (compile-fcn prog1 cm-prog1 fl-exprm)
82: (compile-fcn prog2 cm-prog2 fl-exprm)
83: (compile-fcn progv c-progv fl-expr)
84: (compile-fcn quote cc-quote fl-exprcc)
85: (compile-fcn return c-return fl-expr)
86: (compile-fcn rplaca c-rplaca fl-expr)
87: (compile-fcn rplacd c-rplacd fl-expr)
88: (compile-fcn rplacx c-rplacx fl-expr)
89: (compile-fcn *rplacx c-rplacx fl-expr)
90: (compile-fcn setarg c-setarg fl-expr)
91: (compile-fcn setq cc-setq fl-exprcc)
92: (compile-fcn stringp cc-stringp fl-exprcc)
93: (compile-fcn symbolp cc-symbolp fl-exprcc)
94: (compile-fcn symeval cm-symeval fl-exprm)
95: (compile-fcn *throw c-*throw fl-expr)
96: (compile-fcn typep cc-typep fl-exprcc)
97: (compile-fcn vectorp cc-vectorp fl-exprcc)
98: (compile-fcn vectorip cc-vectorip fl-exprcc)
99: (compile-fcn vset cc-vset fl-exprcc)
100: (compile-fcn vseti-byte cc-vseti-byte fl-exprcc)
101: (compile-fcn vseti-word cc-vseti-word fl-exprcc)
102: (compile-fcn vseti-long cc-vseti-long fl-exprcc)
103: (compile-fcn vref cc-vref fl-exprcc)
104: (compile-fcn vrefi-byte cc-vrefi-byte fl-exprcc)
105: (compile-fcn vrefi-word cc-vrefi-word fl-exprcc)
106: (compile-fcn vrefi-long cc-vrefi-long fl-exprcc)
107: (compile-fcn vsize c-vsize fl-expr)
108: (compile-fcn vsize-byte c-vsize-byte fl-expr)
109: (compile-fcn vsize-word c-vsize-word fl-expr)
110:
111: (compile-fcn zerop cm-zerop fl-exprm)
112: ; functions which expect fixnum operands
113:
114:
115: (compile-fcn + c-fixnumop fl-expr)
116: #+for-vax (putprop '+ 'addl3 'fixop)
117: #+for-68k (putprop '+ 'addl 'fixop)
118:
119: (compile-fcn - c-fixnumop fl-expr)
120: #+for-vax (putprop '- 'subl3 'fixop)
121: #+for-68k (putprop '- 'subl 'fixop)
122:
123: #+for-vax
124: (progn 'compile
125: (compile-fcn * c-fixnumop fl-expr)
126: (putprop '* 'mull3 'fixop)
127:
128: (compile-fcn / c-fixnumop fl-expr)
129: (putprop '/ 'divl3 'fixop))
130:
131: ;-- boole's derivatives
132: #+for-vax
133: (progn 'compile
134: (compile-fcn fixnum-BitOr c-fixnumop fl-expr)
135: (putprop 'fixnum-BitOr 'bisl3 'fixop)
136:
137: (compile-fcn fixnum-BitAndNot c-fixnumop fl-expr)
138: (putprop 'fixnum-BitAndNot 'bicl3 'fixop)
139:
140: (compile-fcn fixnum-BitXor c-fixnumop fl-expr)
141: (putprop 'fixnum-BitXor 'xorl3 'fixop))
142:
143: (compile-fcn 1+ cc-oneplus fl-exprcc)
144: (compile-fcn 1- cc-oneminus fl-exprcc)
145:
146: #+for-vax
147: (compile-fcn \\ c-\\ fl-expr) ; done in the old way, should be modified
148:
149: ; these have typically fixnum operands, but not always
150:
151:
152: ; these without the & can be both fixnum or both flonum
153: ;
154: (compile-fcn < cm-< fl-exprm)
155: (compile-fcn <& cc-<& fl-exprcc)
156:
157: (compile-fcn > cm-> fl-exprm)
158: (compile-fcn >& cc->& fl-exprcc)
159:
160: (compile-fcn = cm-= fl-exprm)
161: (compile-fcn =& cm-=& fl-exprm)
162:
163: ; functions which can only be compiled
164: (compile-fcn assembler-code c-assembler-code fl-expr)
165: (compile-fcn fixnum-cxr cm-fixnum-cxr fl-exprm)
166: (compile-fcn internal-fixnum-box c-internal-fixnum-box fl-expr)
167: (compile-fcn offset-cxr cc-offset-cxr fl-exprcc)
168: (compile-fcn internal-bind-vars c-internal-bind-vars fl-expr)
169: (compile-fcn internal-unbind-vars c-internal-unbind-vars fl-expr)
170:
171: ; functions which can be converted to fixnum functions if
172: ; proper declarations are done
173: (mapc
174: '(lambda (arg) (putprop (car arg) (cdr arg) 'if-fixnum-args))
175: '((lessp . <&) (greaterp . >&) (= . =&) (equal . =&)))
176:
177:
178: ;--- doevalwhen, process evalwhen directive. This is inadequate.
179: ;
180: (def doevalwhen
181: (lambda (v-f)
182: (prog (docom dolod)
183: (setq docom (memq 'compile (cadr v-f))
184:
185: dolod (memq 'load (cadr v-f)))
186: (mapc '(lambda (frm) (cond (docom (eval frm)))
187: (cond (dolod
188: ((lambda (internal-macros)
189: (liszt-form frm))
190: t))))
191: (cddr v-f)))))
192:
193:
194: ;---- declare - the compiler version of the declare function
195: ; process the declare forms given. We evaluate each arg
196: ;
197: (defun liszt-declare fexpr (forms)
198: (cond ((status feature complr)
199: (do ((i forms (cdr i)))
200: ((null i))
201: (cond ((and (atom (caar i))
202: (getd (caar i)))
203: (eval (car i))) ; if this is a function
204: (t (comp-warn "Unknown declare attribute: " (car i))))))))
205:
206: ;---> handlers for declare forms
207: ; declaration information for declarations which occur outside of
208: ; functions is stored on the property list for rapid access.
209: ; The indicator to look under is the value of one of the symbols:
210: ; g-functype, g-vartype, g-bindtype, or g-calltype
211: ; The value of the property is the declared function, declaration, binding
212: ; or call type for that variable.
213: ; For local declarations, the information is kept on the g-decls stack.
214: ; It is an assq list, the car of which is the name of the variable or
215: ; function name, the cdr of which is the particular type. To tell
216: ; whether the particular type is a function type declaration, check the
217: ; property list of the particular type for a 'functype' indicator.
218: ; Likewise, to see if a particular type is a variable declaration, look
219: ; for a 'vartype' indicator on the particular type's property list.
220: ;
221: (defmacro declare-handler (args name type toplevind)
222: `(mapc '(lambda (var)
223: (cond ((symbolp var)
224: (cond (g-compfcn ; if compiling a function
225: (Push g-decls (cons var ',name)))
226: (t ; if at top level
227: (putprop var ',name ,toplevind))))))
228: ,args))
229:
230:
231: (defun *fexpr fexpr (args)
232: (declare-handler args nlambda functype g-functype))
233:
234: (defun nlambda fexpr (args)
235: (declare-handler args nlambda functype g-functype))
236:
237: (defun *expr fexpr (args)
238: (declare-handler args lambda functype g-functype))
239:
240: (defun lambda fexpr (args)
241: (declare-handler args lambda functype g-functype))
242:
243: (defun *lexpr fexpr (args)
244: (declare-handler args lexpr functype g-functype))
245:
246: (defun special fexpr (args)
247: (declare-handler args special bindtype g-bindtype))
248:
249: (defun unspecial fexpr (args)
250: (declare-handler args unspecial bindtype g-bindtype))
251:
252: (defun fixnum fexpr (args)
253: (declare-handler args fixnum vartype g-vartype))
254:
255: (defun flonum fexpr (args)
256: (declare-handler args flonum vartype g-vartype))
257:
258: (defun notype fexpr (args)
259: (declare-handler args notype vartype g-vartype))
260:
261:
262:
263: ;--- special case, this is only allowed at top level. It will
264: ; be removed when vectors are fully supported
265: (def macarray
266: (nlambda (v-l)
267: (mapc '(lambda (x)
268: (if (dtpr x)
269: then (putprop (car x) (cdr x) g-arrayspecs)
270: (putprop (car x) 'array g-functype)
271: else (comp-err "Bad macerror form" x)))
272: v-l)))
273:
274:
275: (def macros
276: (nlambda (args) (setq macros (car args))))
277:
278: (def specials
279: (nlambda (args) (setq special (car args))))
280:
281: ;--- *args
282: ; form is (declare (*args minargs maxargs))
283: ; this must occur within a function definition or it is an error
284: ;
285: (def *args
286: (nlambda (args)
287: (if (not g-compfcn)
288: then (comp-err
289: " *args declaration not given within a function definition "
290: args))
291: (let (min max)
292: (if (not (= (length args) 2))
293: then (comp-err " *args declaration must have two args: "
294: args))
295: (setq min (car args) max (cadr args))
296: (if (not (and (or (null min) (fixp min))
297: (or (null max) (fixp max))))
298: then (comp-err " *args declaration has illegal values: "
299: args))
300: (setq g-arginfo (cons min max))
301: (putprop g-fname (list g-arginfo) 'fcn-info))))
302:
303: ;--- *arginfo
304: ; designed to be used at top level, but can be used within function
305: ; form: (declare (*arginfo (append 2 nil) (showstack 0 1)))
306: ;
307: (def *arginfo
308: (nlambda (args)
309: (do ((xx args (cdr xx))
310: (name)
311: (min)
312: (max))
313: ((null xx))
314: (if (and (dtpr (car xx))
315: (eq (length (car xx)) 3))
316: then (setq name (caar xx)
317: min (cadar xx)
318: max (caddar xx))
319: (if (not (and (symbolp name)
320: (or (null min) (fixp min))
321: (or (null max) (fixp max))))
322: then (comp-err " *arginfo, illegal declaration "
323: (car xx))
324: else (putprop name (list (cons min max)) 'fcn-info))))))
325:
326:
327: ;--- another top level only.
328: ;
329: (def localf
330: (nlambda (args)
331: (mapc '(lambda (ar)
332: (if (null (get ar g-localf))
333: then (putprop ar
334: (cons (d-genlab) -1)
335: g-localf))
336: (if (get ar g-stdref)
337: then (comp-err
338: "function " ar " is being declared local" N
339: " yet it has already been called in a non local way")))
340: args)))
341:
342: ; g-decls is a stack of forms like
343: ; ((foo . special) (bar . fixnum) (pp . nlambda))
344: ; there are 4 types of cdr's:
345: ; function types (lambda, nlambda, lexpr)
346: ; variable types (fixnum, flonum, notype)
347: ; call types (localf, <unspecified>)
348: ; bind types (special, unspecial)
349: ;
350: (mapc '(lambda (x) (putprop x t 'functype)) '(lambda nlambda lexpr))
351: (mapc '(lambda (x) (putprop x t 'vartype)) '(fixnum flonum notype))
352: (mapc '(lambda (x) (putprop x t 'calltype)) '(localf))
353: (mapc '(lambda (x) (putprop x t 'bindtype)) '(special unspecial))
354:
355: ;---> end declare form handlers
356:
357:
358:
359:
360:
361:
362: ;--- d-makespec :: declare a variable to be special
363: ;
364: (defun d-makespec (vrb)
365: (putprop vrb 'special g-bindtype))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.