![[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] / 43BSDTahoe / ucb / lisp / liszt|
Return to decl.l CVS log | Up to [CSRG BSD Unix] / 43BSDTahoe / 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.9 87/12/15 17:00:21 sklower 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: #+(or for-vax for-tahoe)
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: #+(or for-vax for-tahoe) (putprop '+ 'addl3 'fixop)
117: #+for-68k (putprop '+ 'addl 'fixop)
118:
119: (compile-fcn - c-fixnumop fl-expr)
120: #+(or for-vax for-tahoe) (putprop '- 'subl3 'fixop)
121: #+for-68k (putprop '- 'subl 'fixop)
122:
123: #+(or for-vax for-tahoe)
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: #+for-tahoe
144: (progn 'compile
145: (compile-fcn fixnum-BitOr c-fixnumop fl-expr)
146: (putprop 'fixnum-BitOr 'orl3 'fixop)
147:
148: (compile-fcn fixnum-BitAnd c-fixnumop fl-expr)
149: (putprop 'fixnum-BitAnd 'andl3 'fixop)
150:
151: (compile-fcn fixnum-BitXor c-fixnumop fl-expr)
152: (putprop 'fixnum-BitXor 'xorl3 'fixop))
153:
154: (compile-fcn 1+ cc-oneplus fl-exprcc)
155: (compile-fcn 1- cc-oneminus fl-exprcc)
156:
157: #+(or for-vax for-tahoe)
158: (compile-fcn \\ c-\\ fl-expr) ; done in the old way, should be modified
159:
160: ; these have typically fixnum operands, but not always
161:
162:
163: ; these without the & can be both fixnum or both flonum
164: ;
165: (compile-fcn < cm-< fl-exprm)
166: (compile-fcn <& cc-<& fl-exprcc)
167:
168: (compile-fcn > cm-> fl-exprm)
169: (compile-fcn >& cc->& fl-exprcc)
170:
171: (compile-fcn = cm-= fl-exprm)
172: (compile-fcn =& cm-=& fl-exprm)
173:
174: ; functions which can only be compiled
175: (compile-fcn assembler-code c-assembler-code fl-expr)
176: (compile-fcn fixnum-cxr cm-fixnum-cxr fl-exprm)
177: (compile-fcn internal-fixnum-box c-internal-fixnum-box fl-expr)
178: (compile-fcn offset-cxr cc-offset-cxr fl-exprcc)
179: (compile-fcn internal-bind-vars c-internal-bind-vars fl-expr)
180: (compile-fcn internal-unbind-vars c-internal-unbind-vars fl-expr)
181:
182: ; functions which can be converted to fixnum functions if
183: ; proper declarations are done
184: (mapc
185: '(lambda (arg) (putprop (car arg) (cdr arg) 'if-fixnum-args))
186: '((lessp . <&) (greaterp . >&) (= . =&) (equal . =&)))
187:
188:
189: ;--- doevalwhen, process evalwhen directive. This is inadequate.
190: ;
191: (def doevalwhen
192: (lambda (v-f)
193: (prog (docom dolod)
194: (setq docom (memq 'compile (cadr v-f))
195:
196: dolod (memq 'load (cadr v-f)))
197: (mapc '(lambda (frm) (cond (docom (eval frm)))
198: (cond (dolod
199: ((lambda (internal-macros)
200: (liszt-form frm))
201: t))))
202: (cddr v-f)))))
203:
204:
205: ;---- declare - the compiler version of the declare function
206: ; process the declare forms given. We evaluate each arg
207: ;
208: (defun liszt-declare fexpr (forms)
209: (cond ((status feature complr)
210: (do ((i forms (cdr i)))
211: ((null i))
212: (cond ((and (atom (caar i))
213: (getd (caar i)))
214: (eval (car i))) ; if this is a function
215: (t (comp-warn "Unknown declare attribute: " (car i))))))))
216:
217: ;---> handlers for declare forms
218: ; declaration information for declarations which occur outside of
219: ; functions is stored on the property list for rapid access.
220: ; The indicator to look under is the value of one of the symbols:
221: ; g-functype, g-vartype, g-bindtype, or g-calltype
222: ; The value of the property is the declared function, declaration, binding
223: ; or call type for that variable.
224: ; For local declarations, the information is kept on the g-decls stack.
225: ; It is an assq list, the car of which is the name of the variable or
226: ; function name, the cdr of which is the particular type. To tell
227: ; whether the particular type is a function type declaration, check the
228: ; property list of the particular type for a 'functype' indicator.
229: ; Likewise, to see if a particular type is a variable declaration, look
230: ; for a 'vartype' indicator on the particular type's property list.
231: ;
232: (defmacro declare-handler (args name type toplevind)
233: `(mapc '(lambda (var)
234: (cond ((symbolp var)
235: (cond (g-compfcn ; if compiling a function
236: (Push g-decls (cons var ',name)))
237: (t ; if at top level
238: (putprop var ',name ,toplevind))))))
239: ,args))
240:
241:
242: (defun *fexpr fexpr (args)
243: (declare-handler args nlambda functype g-functype))
244:
245: (defun nlambda fexpr (args)
246: (declare-handler args nlambda functype g-functype))
247:
248: (defun *expr fexpr (args)
249: (declare-handler args lambda functype g-functype))
250:
251: (defun lambda fexpr (args)
252: (declare-handler args lambda functype g-functype))
253:
254: (defun *lexpr fexpr (args)
255: (declare-handler args lexpr functype g-functype))
256:
257: (defun special fexpr (args)
258: (declare-handler args special bindtype g-bindtype))
259:
260: (defun unspecial fexpr (args)
261: (declare-handler args unspecial bindtype g-bindtype))
262:
263: (defun fixnum fexpr (args)
264: (declare-handler args fixnum vartype g-vartype))
265:
266: (defun flonum fexpr (args)
267: (declare-handler args flonum vartype g-vartype))
268:
269: (defun notype fexpr (args)
270: (declare-handler args notype vartype g-vartype))
271:
272:
273:
274: ;--- special case, this is only allowed at top level. It will
275: ; be removed when vectors are fully supported
276: (def macarray
277: (nlambda (v-l)
278: (mapc '(lambda (x)
279: (if (dtpr x)
280: then (putprop (car x) (cdr x) g-arrayspecs)
281: (putprop (car x) 'array g-functype)
282: else (comp-err "Bad macerror form" x)))
283: v-l)))
284:
285:
286: (def macros
287: (nlambda (args) (setq macros (car args))))
288:
289: (def specials
290: (nlambda (args) (setq special (car args))))
291:
292: ;--- *args
293: ; form is (declare (*args minargs maxargs))
294: ; this must occur within a function definition or it is an error
295: ;
296: (def *args
297: (nlambda (args)
298: (if (not g-compfcn)
299: then (comp-err
300: " *args declaration not given within a function definition "
301: args))
302: (let (min max)
303: (if (not (= (length args) 2))
304: then (comp-err " *args declaration must have two args: "
305: args))
306: (setq min (car args) max (cadr args))
307: (if (not (and (or (null min) (fixp min))
308: (or (null max) (fixp max))))
309: then (comp-err " *args declaration has illegal values: "
310: args))
311: (setq g-arginfo (cons min max))
312: (putprop g-fname (list g-arginfo) 'fcn-info))))
313:
314: ;--- *arginfo
315: ; designed to be used at top level, but can be used within function
316: ; form: (declare (*arginfo (append 2 nil) (showstack 0 1)))
317: ;
318: (def *arginfo
319: (nlambda (args)
320: (do ((xx args (cdr xx))
321: (name)
322: (min)
323: (max))
324: ((null xx))
325: (if (and (dtpr (car xx))
326: (eq (length (car xx)) 3))
327: then (setq name (caar xx)
328: min (cadar xx)
329: max (caddar xx))
330: (if (not (and (symbolp name)
331: (or (null min) (fixp min))
332: (or (null max) (fixp max))))
333: then (comp-err " *arginfo, illegal declaration "
334: (car xx))
335: else (putprop name (list (cons min max)) 'fcn-info))))))
336:
337:
338: ;--- another top level only.
339: ;
340: (def localf
341: (nlambda (args)
342: (mapc '(lambda (ar)
343: (if (null (get ar g-localf))
344: then (putprop ar
345: (cons (d-genlab) -1)
346: g-localf))
347: (if (get ar g-stdref)
348: then (comp-err
349: "function " ar " is being declared local" N
350: " yet it has already been called in a non local way")))
351: args)))
352:
353: ; g-decls is a stack of forms like
354: ; ((foo . special) (bar . fixnum) (pp . nlambda))
355: ; there are 4 types of cdr's:
356: ; function types (lambda, nlambda, lexpr)
357: ; variable types (fixnum, flonum, notype)
358: ; call types (localf, <unspecified>)
359: ; bind types (special, unspecial)
360: ;
361: (mapc '(lambda (x) (putprop x t 'functype)) '(lambda nlambda lexpr))
362: (mapc '(lambda (x) (putprop x t 'vartype)) '(fixnum flonum notype))
363: (mapc '(lambda (x) (putprop x t 'calltype)) '(localf))
364: (mapc '(lambda (x) (putprop x t 'bindtype)) '(special unspecial))
365:
366: ;---> end declare form handlers
367:
368:
369:
370:
371:
372:
373: ;--- d-makespec :: declare a variable to be special
374: ;
375: (defun d-makespec (vrb)
376: (putprop vrb 'special g-bindtype))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.