1 |
|
;;; CMPENV Environments of the Compiler. |
2 |
|
;;; |
3 |
|
;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa |
4 |
|
|
5 |
|
;; This file is part of GNU Common Lisp, herein referred to as GCL |
6 |
|
;; |
7 |
|
;; GCL is free software; you can redistribute it and/or modify it under |
8 |
|
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by |
9 |
|
;; the Free Software Foundation; either version 2, or (at your option) |
10 |
|
;; any later version. |
11 |
|
;; |
12 |
|
;; GCL is distributed in the hope that it will be useful, but WITHOUT |
13 |
|
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
14 |
|
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public |
15 |
|
;; License for more details. |
16 |
|
;; |
17 |
|
;; You should have received a copy of the GNU Library General Public License |
18 |
|
;; along with GCL; see the file COPYING. If not, write to the Free Software |
19 |
|
;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. |
20 |
|
|
21 |
|
|
22 |
|
(in-package 'compiler) |
23 |
|
|
24 |
|
(defvar *safe-compile* nil) |
25 |
|
(defvar *compiler-check-args* nil) |
26 |
|
(defvar *compiler-push-events* nil) |
27 |
|
(defvar *speed* 3) |
28 |
|
(defvar *space* 0) |
29 |
|
|
30 |
|
;;; Only these flags are set by the user. |
31 |
|
;;; If *safe-compile* is ON, some kind of run-time checks are not |
32 |
|
;;; included in the compiled code. The default value is OFF. |
33 |
|
|
34 |
|
|
35 |
|
|
36 |
|
(defun init-env () |
37 |
|
(setq *next-cvar* 0) |
38 |
|
(setq *next-cmacro* 0) |
39 |
|
(setq *next-vv* -1) |
40 |
|
(setq *next-cfun* 0) |
41 |
|
(setq *last-label* 0) |
42 |
|
(setq *objects* nil) |
43 |
|
(setq *constants* nil) |
44 |
|
(setq *local-funs* nil) |
45 |
|
(setq *global-funs* nil) |
46 |
|
(setq *global-entries* nil) |
47 |
|
(setq *undefined-vars* nil) |
48 |
|
(setq *reservations* nil) |
49 |
|
(setq *closures* nil) |
50 |
|
(setq *top-level-forms* nil) |
51 |
|
(setq *non-package-operation* nil) |
52 |
|
(setq *function-declarations* nil) |
53 |
|
(setq *inline-functions* nil) |
54 |
|
(setq *inline-blocks* 0) |
55 |
|
(setq *notinline* nil) |
56 |
|
) |
57 |
|
|
58 |
|
(defvar *next-cvar* 0) |
59 |
|
(defvar *next-cmacro* 0) |
60 |
|
(defvar *next-vv* -1) |
61 |
|
(defvar *next-cfun* 0) |
62 |
|
|
63 |
|
;;; *next-cvar* holds the last cvar number used. |
64 |
|
;;; *next-cmacro* holds the last cmacro number used. |
65 |
|
;;; *next-vv* holds the last VV index used. |
66 |
|
;;; *next-cfun* holds the last cfun used. |
67 |
|
|
68 |
|
(defmacro next-cfun () '(incf *next-cfun*)) |
69 |
|
|
70 |
|
(defun add-symbol (symbol) |
71 |
|
(let ((x (assoc symbol *objects*))) |
72 |
|
(cond (x (cadr x)) |
73 |
|
(t (push-data-incf symbol) |
74 |
|
(push (list symbol *next-vv*) *objects*) |
75 |
|
*next-vv*)))) |
76 |
|
|
77 |
|
;; Write to a string with all the *print-.. levels bound appropriately. |
78 |
|
(defun wt-to-string (x &aux |
79 |
|
(*compiler-output-data* (make-string-output-stream)) |
80 |
|
*fasd-data*) |
81 |
|
(wt-data1 x) |
82 |
|
(get-output-stream-string *compiler-output-data*)) |
83 |
|
|
84 |
|
(defun add-object (object &aux x) |
85 |
|
;;; Used only during Pass 1. |
86 |
|
(cond ((si:contains-sharp-comma object) |
87 |
|
;;; SI:CONTAINS-SHARP-COMMA returns T iff OBJECT |
88 |
|
;;; contains a sharp comma OR a structure. |
89 |
|
;; there will be an eval and we want the eval to happen |
90 |
|
(cond ((and |
91 |
|
(consp object) |
92 |
|
(eq (car object) 'si::|#,|) |
93 |
|
(not (si:contains-sharp-comma (cdr object)))) |
94 |
|
(setq object (cdr object))) |
95 |
|
(t (setq object `(si::string-to-object |
96 |
|
,(wt-to-string object))))) |
97 |
|
(push-data-incf nil) |
98 |
|
(push (list *next-vv* object) *sharp-commas*) |
99 |
|
*next-vv*) |
100 |
|
((setq x (assoc object *objects*)) |
101 |
|
(cadr x)) |
102 |
|
((typep object 'compiled-function) |
103 |
|
(push-data-incf nil) |
104 |
|
(push (list *next-vv* `(function |
105 |
|
,(or (si::compiled-function-name |
106 |
|
object) |
107 |
|
(cmperr "Can't dump un named compiled funs") |
108 |
|
))) |
109 |
|
*sharp-commas*) |
110 |
|
*next-vv* |
111 |
|
) |
112 |
|
(t |
113 |
|
(push-data-incf object) |
114 |
|
(push (list object *next-vv*) *objects*) |
115 |
|
*next-vv*))) |
116 |
|
|
117 |
|
(defun add-constant (symbol &aux x) |
118 |
|
;;; Used only during Pass 1. |
119 |
|
(cond ((setq x (assoc symbol *constants*)) |
120 |
|
(cadr x)) |
121 |
|
(t (push-data-incf nil) |
122 |
|
(push (list *next-vv* symbol) *sharp-commas*) |
123 |
|
(push (list symbol *next-vv*) *constants*) |
124 |
|
*next-vv*))) |
125 |
|
|
126 |
|
(defmacro next-cvar () '(incf *next-cvar*)) |
127 |
|
(defmacro next-cmacro () '(incf *next-cmacro*)) |
128 |
|
|
129 |
|
;;; Tail recursion information. |
130 |
|
(defvar *do-tail-recursion* t) |
131 |
|
(defvar *tail-recursion-info* nil) |
132 |
|
;;; Tail recursion optimization never occurs if *do-tail-recursion* is NIL. |
133 |
|
;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. |
134 |
|
;;; If possible, *tail-recursion-info* holds |
135 |
|
;;; ( fname required-arg .... required-arg ), |
136 |
|
;;; where each required-arg is a var-object. |
137 |
|
|
138 |
|
|
139 |
|
(defvar *function-declarations* nil) |
140 |
|
;;; *function-declarations* holds : |
141 |
|
;;; (... ( { function-name | fun-object } arg-types return-type ) ...) |
142 |
|
;;; Function declarations for global functions are ASSOCed by function names, |
143 |
|
;;; whereas those for local functions are ASSOCed by function objects. |
144 |
|
;;; |
145 |
|
;;; The valid argment type declaration is: |
146 |
|
;;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] ) |
147 |
|
;;; though &optional, &rest, and &key return types are simply ignored. |
148 |
|
|
149 |
|
(defun function-arg-types (arg-types &aux vararg (types nil) result) |
150 |
|
(setq result |
151 |
|
(do ((al arg-types (cdr al)) |
152 |
|
(i 0 (the fixnum (+ 1 i)))) |
153 |
|
((endp al) |
154 |
|
(reverse types)) |
155 |
|
(declare (fixnum i)) |
156 |
|
(cond ((or (member (car al) '(&optional &rest &key)) |
157 |
|
(equal (car al) '* )) |
158 |
|
(setq vararg t) |
159 |
|
(return (reverse (cons '* types))))) |
160 |
|
;; only the first 9 args may have proclaimed type different from T |
161 |
|
(push (cond |
162 |
|
((< i 9) |
163 |
|
(let ((tem |
164 |
|
(type-filter (car al)))) |
165 |
|
(if (eq 'integer tem) t tem))) |
166 |
|
(t (if (eq (car al) '*) '* t))) |
167 |
|
types))) |
168 |
|
;;only type t args for var arg so far. |
169 |
|
(cond (vararg (do ((v result (cdr v))) |
170 |
|
((null v)) |
171 |
|
(setf (car v) (if (eq (car v) '*) '* t))))) |
172 |
|
|
173 |
|
result) |
174 |
|
|
175 |
|
|
176 |
|
;;; The valid return type declaration is: |
177 |
|
;;; (( VALUES {type}* )) or ( {type}* ). |
178 |
|
|
179 |
|
(defun function-return-type (return-types) |
180 |
|
(and (eq (car return-types) 'values) |
181 |
|
(setq return-types (cdr return-types))) |
182 |
|
(cond ((endp return-types) nil) |
183 |
|
((and (consp (car return-types)) |
184 |
|
(eq (caar return-types) 'values)) |
185 |
|
(function-return-type (cdr (car return-types)))) |
186 |
|
(t (do ((v return-types (cdr v)) |
187 |
|
(result)) |
188 |
|
((endp v)(or (null v) |
189 |
|
(warn "The function return type ~s is illegal." |
190 |
|
return-types)) |
191 |
|
(nreverse result)) |
192 |
|
(let ((tem (if (eq (car v) '*) '* (type-filter (car v))))) |
193 |
|
(if (eq tem 'integer) (setq tem t)) |
194 |
|
(push tem result)))))) |
195 |
|
|
196 |
|
(defun add-function-proclamation (fname decl list &aux (procl t) |
197 |
|
arg-types return-types) |
198 |
|
(cond |
199 |
|
((and (symbolp fname) |
200 |
|
(listp decl) (listp (cdr decl))) |
201 |
|
(cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '(*))) |
202 |
|
(t (setq arg-types (function-arg-types (car decl))) |
203 |
|
|
204 |
|
)) |
205 |
|
(setq return-types (function-return-type (cdr decl))) |
206 |
|
(cond ((and (consp return-types) ; ie not nil |
207 |
|
(endp (cdr return-types)) |
208 |
|
(not (eq (car return-types) '*))) |
209 |
|
(setq return-types |
210 |
|
;; varargs must return type t currently. |
211 |
|
(if (member '* (and (consp arg-types) arg-types)) t |
212 |
|
(car return-types)))) |
213 |
|
(t (setq procl nil))) |
214 |
|
(cond ((and (listp arg-types) |
215 |
|
(< (length arg-types) call-arguments-limit))) |
216 |
|
(t (setq procl nil))) |
217 |
|
(do ((fname fname (car list))) |
218 |
|
(()) |
219 |
|
(or (symbolp fname) |
220 |
|
(return (add-function-proclamation fname decl nil))) |
221 |
|
(if (eq arg-types '*) |
222 |
|
(remprop fname 'proclaimed-arg-types) |
223 |
|
(si:putprop fname arg-types 'proclaimed-arg-types)) |
224 |
|
(si:putprop fname return-types 'proclaimed-return-type) |
225 |
|
|
226 |
|
;;; A non-local function may have local entry only if it returns |
227 |
|
;;; a single value. |
228 |
|
|
229 |
|
(if procl (si:putprop fname t 'proclaimed-function) |
230 |
|
(remprop fname 'proclaimed-function)) |
231 |
|
(setq list (cdr list)) |
232 |
|
(or (consp list) (return 'done)) |
233 |
|
)) |
234 |
|
(t (warn "The function procl ~s ~s is not valid." fname decl)))) |
235 |
|
|
236 |
|
(defun add-function-declaration (fname arg-types return-types) |
237 |
|
(cond ((symbolp fname) |
238 |
|
(push (list (sch-local-fun fname) |
239 |
|
(function-arg-types arg-types) |
240 |
|
(function-return-type return-types)) |
241 |
|
*function-declarations*)) |
242 |
|
(t (warn "The function name ~s is not a symbol." fname)))) |
243 |
|
|
244 |
|
(defun get-arg-types (fname &aux x) |
245 |
|
(if (setq x (assoc fname *function-declarations*)) |
246 |
|
(cadr x) |
247 |
|
(get fname 'proclaimed-arg-types))) |
248 |
|
|
249 |
|
(defun get-return-type (fname) |
250 |
|
(let* ((x (assoc fname *function-declarations*)) |
251 |
|
(type1 (if x (caddr x) (get fname 'proclaimed-return-type))) |
252 |
|
(type (if (get fname 'predicate) 'boolean |
253 |
|
(get fname 'return-type)))) |
254 |
|
(cond (type1 |
255 |
|
(cond (type |
256 |
|
(cond ((setq type (type-and type type1)) type) |
257 |
|
(t |
258 |
|
(cmpwarn |
259 |
|
"The return type of ~s was badly declared." |
260 |
|
fname)))) |
261 |
|
(t type1))) |
262 |
|
(t type)))) |
263 |
|
|
264 |
|
(defun get-local-arg-types (fun &aux x) |
265 |
|
(if (setq x (assoc fun *function-declarations*)) |
266 |
|
(cadr x) |
267 |
|
nil)) |
268 |
|
|
269 |
|
(defun get-local-return-type (fun &aux x) |
270 |
|
(if (setq x (assoc fun *function-declarations*)) |
271 |
|
(caddr x) |
272 |
|
nil)) |
273 |
|
|
274 |
|
(defvar *sup-used* nil) |
275 |
|
(defvar *base-used* nil) |
276 |
|
|
277 |
|
(defun reset-top () |
278 |
|
(wt "vs_top=sup;") |
279 |
|
(setq *sup-used* t)) |
280 |
|
|
281 |
|
(defmacro base-used () '(setq *base-used* t)) |
282 |
|
|
283 |
|
;;; Proclamation and declaration handling. |
284 |
|
|
285 |
|
(defvar *alien-declarations* nil) |
286 |
|
(defvar *notinline* nil) |
287 |
|
|
288 |
|
(defun inline-possible (fname) |
289 |
|
(not (or *compiler-push-events* |
290 |
|
(member fname *notinline*) |
291 |
|
(get fname 'cmp-notinline)))) |
292 |
|
|
293 |
|
(defun proclaim (decl) |
294 |
|
(case (car decl) |
295 |
|
(special |
296 |
|
(dolist** (var (cdr decl)) |
297 |
|
(if (symbolp var) |
298 |
|
(si:*make-special var) |
299 |
|
(warn "The variable name ~s is not a symbol." var)))) |
300 |
|
(optimize |
301 |
|
(dolist (x (cdr decl)) |
302 |
|
(when (symbolp x) (setq x (list x 3))) |
303 |
|
(if (or (not (consp x)) |
304 |
|
(not (consp (cdr x))) |
305 |
|
(not (numberp (cadr x))) |
306 |
|
(not (<= 0 (cadr x) 3))) |
307 |
|
(warn "The OPTIMIZE proclamation ~s is illegal." x) |
308 |
|
(case (car x) |
309 |
|
(safety (setq *compiler-check-args* (>= (cadr x) 1)) |
310 |
|
(setq *safe-compile* (>= (cadr x) 2)) |
311 |
|
(setq *compiler-push-events* (>= (cadr x) 3))) |
312 |
|
(space (setq *space* (cadr x))) |
313 |
|
(speed (setq *speed* (cadr x))) |
314 |
|
(compilation-speed (setq *speed* (- 3 (cadr x)))) |
315 |
|
(t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) |
316 |
|
(type |
317 |
|
(if (consp (cdr decl)) |
318 |
|
(proclaim-var (cadr decl) (cddr decl)) |
319 |
|
(warn "The type declaration ~s is illegal." decl))) |
320 |
|
((fixnum character short-float long-float) |
321 |
|
(proclaim-var (car decl) (cdr decl))) |
322 |
|
(ftype |
323 |
|
(cond ((and (consp (cdr decl)) |
324 |
|
(consp (cadr decl)) |
325 |
|
(eq (caadr decl) 'function)) |
326 |
|
(add-function-proclamation (caddr decl) (cdr (cadr decl)) |
327 |
|
(cddr decl))) |
328 |
|
(t (cmpwarn "Bad function proclamation ~a" decl)))) |
329 |
|
(function |
330 |
|
(cond ((and (consp (cdr decl))) |
331 |
|
(add-function-proclamation (cadr decl) (cddr decl) nil)) |
332 |
|
(t (cmpwarn "Bad function proclamation ~a" decl)))) |
333 |
|
(inline |
334 |
|
(dolist** (fun (cdr decl)) |
335 |
|
(if (symbolp fun) |
336 |
|
(remprop fun 'cmp-notinline) |
337 |
|
(warn "The function name ~s is not a symbol." fun)))) |
338 |
|
(notinline |
339 |
|
(dolist** (fun (cdr decl)) |
340 |
|
(if (symbolp fun) |
341 |
|
(si:putprop fun t 'cmp-notinline) |
342 |
|
(warn "The function name ~s is not a symbol." fun)))) |
343 |
|
((object ignore) |
344 |
|
(dolist** (var (cdr decl)) |
345 |
|
(unless (symbolp var) |
346 |
|
(warn "The variable name ~s is not a symbol." var)))) |
347 |
|
(declaration |
348 |
|
(dolist** (x (cdr decl)) |
349 |
|
(if (symbolp x) |
350 |
|
(unless (member x *alien-declarations*) |
351 |
|
(push x *alien-declarations*)) |
352 |
|
(warn "The declaration specifier ~s is not a symbol." x)))) |
353 |
|
((array atom bignum bit bit-vector character common compiled-function |
354 |
|
complex cons double-float fixnum float hash-table integer keyword list |
355 |
|
long-float nil null number package pathname random-state ratio rational |
356 |
|
readtable sequence short-float simple-array simple-bit-vector |
357 |
|
simple-string simple-vector single-float standard-char stream string |
358 |
|
string-char symbol t vector signed-byte unsigned-byte) |
359 |
|
(proclaim-var (car decl) (cdr decl))) |
360 |
|
(otherwise |
361 |
|
(unless (member (car decl) *alien-declarations*) |
362 |
|
(warn "The declaration specifier ~s is unknown." (car decl))) |
363 |
|
(and (functionp (get (car decl) :proclaim)) |
364 |
|
(dolist** (v (cdr decl)) |
365 |
|
(funcall (get (car decl) :proclaim) v))) |
366 |
|
) |
367 |
|
) |
368 |
|
nil |
369 |
|
) |
370 |
|
|
371 |
|
(defun proclaim-var (type vl) |
372 |
|
(setq type (type-filter type)) |
373 |
|
(dolist** (var vl) |
374 |
|
(cond ((symbolp var) |
375 |
|
(let ((type1 (get var 'cmp-type)) |
376 |
|
(v (sch-global var))) |
377 |
|
(setq type1 (if type1 (type-and type1 type) type)) |
378 |
|
(when v (setq type1 (type-and type1 (var-type v)))) |
379 |
|
(when (null type1) (warn |
380 |
|
"Inconsistent type declaration was found for the variable ~s." |
381 |
|
var)) |
382 |
|
(si:putprop var type1 'cmp-type) |
383 |
|
(when v (setf (var-type v) type1)))) |
384 |
|
(t |
385 |
|
(warn "The variable name ~s is not a symbol." var))))) |
386 |
|
|
387 |
|
(defun c1body (body doc-p &aux (ss nil) (is nil) (ts nil) (others nil) |
388 |
|
doc form) |
389 |
|
(loop |
390 |
|
(when (endp body) (return)) |
391 |
|
(setq form (cmp-macroexpand (car body))) |
392 |
|
(cond |
393 |
|
((stringp form) |
394 |
|
(when (or (null doc-p) (endp (cdr body)) doc) (return)) |
395 |
|
(setq doc form)) |
396 |
|
((and (consp form) (eq (car form) 'declare)) |
397 |
|
(dolist** (decl (cdr form)) |
398 |
|
(cmpck (or (not (consp decl)) (not (symbolp (car decl)))) |
399 |
|
"The declaration ~s is illegal." decl) |
400 |
|
(case (car decl) |
401 |
|
(special |
402 |
|
(dolist** (var (cdr decl)) |
403 |
|
(cmpck (not (symbolp var)) |
404 |
|
"The special declaration ~s contains a non-symbol ~s." |
405 |
|
decl var) |
406 |
|
(push var ss))) |
407 |
|
(ignore |
408 |
|
(dolist** (var (cdr decl)) |
409 |
|
(cmpck (not (symbolp var)) |
410 |
|
"The ignore declaration ~s contains a non-symbol ~s." |
411 |
|
decl var) |
412 |
|
(push var is))) |
413 |
|
(type |
414 |
|
(cmpck (endp (cdr decl)) |
415 |
|
"The type declaration ~s is illegal." decl) |
416 |
|
(let ((type (type-filter (cadr decl)))) |
417 |
|
(when type |
418 |
|
(dolist** (var (cddr decl)) |
419 |
|
(cmpck (not (symbolp var)) |
420 |
|
"The type declaration ~s contains a non-symbol ~s." |
421 |
|
decl var) |
422 |
|
(push (cons var type) ts))))) |
423 |
|
(object |
424 |
|
(dolist** (var (cdr decl)) |
425 |
|
(cmpck (not (symbolp var)) |
426 |
|
"The object declaration ~s contains a non-symbol ~s." |
427 |
|
decl var) |
428 |
|
(push (cons var 'object) ts))) |
429 |
|
(:register |
430 |
|
(dolist** (var (cdr decl)) |
431 |
|
(cmpck (not (symbolp var)) |
432 |
|
"The register declaration ~s contains a non-symbol ~s." |
433 |
|
decl var) |
434 |
|
(push (cons var 'register) ts) |
435 |
|
)) |
436 |
|
((fixnum character double-float short-float array atom bignum bit |
437 |
|
bit-vector common compiled-function complex cons float hash-table |
438 |
|
integer keyword list long-float nil null number package pathname |
439 |
|
random-state ratio rational readtable sequence simple-array |
440 |
|
simple-bit-vector simple-string simple-vector single-float |
441 |
|
standard-char stream string string-char symbol t vector |
442 |
|
signed-byte unsigned-byte :dynamic-extent) |
443 |
|
(let ((type (if (eq (car decl) ':dynamic-extent) (car decl) |
444 |
|
(type-filter (car decl))))) |
445 |
|
(when type |
446 |
|
(dolist** (var (cdr decl)) |
447 |
|
(cmpck (not (symbolp var)) |
448 |
|
"The type declaration ~s contains a non-symbol ~s." |
449 |
|
decl var) |
450 |
|
(push (cons var type) ts))))) |
451 |
|
(otherwise (push decl others)) |
452 |
|
))) |
453 |
|
(t (return))) |
454 |
|
(pop body) |
455 |
|
) |
456 |
|
(values body ss ts is others doc) |
457 |
|
) |
458 |
|
|
459 |
|
(defun c1decl-body (decls body &aux (dl nil)) |
460 |
|
(if (null decls) |
461 |
|
(c1progn body) |
462 |
|
(let ((*function-declarations* *function-declarations*) |
463 |
|
(*alien-declarations* *alien-declarations*) |
464 |
|
(*notinline* *notinline*) |
465 |
|
(*space* *space*) |
466 |
|
(*safe-compile* *safe-compile*)) |
467 |
|
(dolist** (decl decls dl) |
468 |
|
(case (car decl) |
469 |
|
(optimize |
470 |
|
(dolist (x (cdr decl)) |
471 |
|
(when (symbolp x) (setq x (list x 3))) |
472 |
|
(if (or (not (consp x)) |
473 |
|
(not (consp (cdr x))) |
474 |
|
(not (numberp (cadr x))) |
475 |
|
(not (<= 0 (cadr x) 3))) |
476 |
|
(warn "The OPTIMIZE proclamation ~s is illegal." x) |
477 |
|
(case (car x) |
478 |
|
(safety |
479 |
|
(setq *safe-compile* |
480 |
|
(>= (the fixnum (cadr x)) 2)) |
481 |
|
(push (list 'safety (cadr x)) dl)) |
482 |
|
(space (setq *space* (cadr x)) |
483 |
|
(push (list 'space (cadr x)) dl)) |
484 |
|
((speed compilation-speed)) |
485 |
|
(t (warn "The OPTIMIZE quality ~s is unknown." |
486 |
|
(car x))))))) |
487 |
|
(ftype |
488 |
|
(if (or (endp (cdr decl)) |
489 |
|
(not (consp (cadr decl))) |
490 |
|
(not (eq (caadr decl) 'function)) |
491 |
|
(endp (cdadr decl))) |
492 |
|
(warn "The function declaration ~s is illegal." decl) |
493 |
|
(dolist** (fname (cddr decl)) |
494 |
|
(add-function-declaration |
495 |
|
fname (cadadr decl) (cddadr decl))))) |
496 |
|
(function |
497 |
|
(if (or (endp (cdr decl)) |
498 |
|
(endp (cddr decl)) |
499 |
|
(not (symbolp (cadr decl)))) |
500 |
|
(warn "The function declaration ~s is illegal." decl) |
501 |
|
(add-function-declaration |
502 |
|
(cadr decl) (caddr decl) (cdddr decl)))) |
503 |
|
(inline |
504 |
|
(dolist** (fun (cdr decl)) |
505 |
|
(if (symbolp fun) |
506 |
|
(progn (push (list 'inline fun) dl) |
507 |
|
(setq *notinline* (remove fun *notinline*))) |
508 |
|
(warn "The function name ~s is not a symbol." fun)))) |
509 |
|
(notinline |
510 |
|
(dolist** (fun (cdr decl)) |
511 |
|
(if (symbolp fun) |
512 |
|
(progn (push (list 'notinline fun) dl) |
513 |
|
(push fun *notinline*)) |
514 |
|
(warn "The function name ~s is not a symbol." fun)))) |
515 |
|
(declaration |
516 |
|
(dolist** (x (cdr decl)) |
517 |
|
(if (symbolp x) |
518 |
|
(unless (member x *alien-declarations*) |
519 |
|
(push x *alien-declarations*)) |
520 |
|
(warn "The declaration specifier ~s is not a symbol." |
521 |
|
x)))) |
522 |
|
(otherwise |
523 |
|
(unless (member (car decl) *alien-declarations*) |
524 |
|
(warn "The declaration specifier ~s is unknown." |
525 |
|
(car decl)))) |
526 |
|
)) |
527 |
|
(setq body (c1progn body)) |
528 |
|
(list 'decl-body (cadr body) dl body) |
529 |
|
) |
530 |
|
) |
531 |
|
) |
532 |
|
|
533 |
|
(si:putprop 'decl-body 'c2decl-body 'c2) |
534 |
|
|
535 |
|
(defun c2decl-body (decls body) |
536 |
|
(let ((*compiler-check-args* *compiler-check-args*) |
537 |
|
(*safe-compile* *safe-compile*) |
538 |
|
(*compiler-push-events* *compiler-push-events*) |
539 |
|
(*notinline* *notinline*) |
540 |
|
(*space* *space*) |
541 |
|
) |
542 |
|
(dolist** (decl decls) |
543 |
|
(case (car decl) |
544 |
|
(safety |
545 |
|
(let ((level (cadr decl))) |
546 |
|
(declare (fixnum level)) |
547 |
|
(setq *compiler-check-args* (>= level 1) |
548 |
|
*safe-compile* (>= level 2) |
549 |
|
*compiler-push-events* (>= level 3)))) |
550 |
|
(space (setq *space* (cadr decl))) |
551 |
|
(notinline (push (cadr decl) *notinline*)) |
552 |
|
(inline |
553 |
|
(setq *notinline* (remove (cadr decl) *notinline*))) |
554 |
|
(otherwise (baboon)))) |
555 |
|
(c2expr body)) |
556 |
|
) |
557 |
|
|
558 |
|
(defun check-vdecl (vnames ts is) |
559 |
|
(dolist** (x ts) |
560 |
|
(unless (member (car x) vnames) |
561 |
|
(cmpwarn "Type declaration was found for not bound variable ~s." |
562 |
|
(car x)))) |
563 |
|
(dolist** (x is) |
564 |
|
(unless (member x vnames) |
565 |
|
(cmpwarn "Ignore declaration was found for not bound variable ~s." x))) |
566 |
|
) |
567 |
|
|
568 |
|
(defun proclamation (decl) |
569 |
|
(case (car decl) |
570 |
|
(special |
571 |
|
(dolist** (var (cdr decl) t) |
572 |
|
(if (symbolp var) |
573 |
|
(unless (si:specialp var) (return nil)) |
574 |
|
(warn "The variable name ~s is not a symbol." var)))) |
575 |
|
(optimize |
576 |
|
(dolist (x (cdr decl) t) |
577 |
|
(when (symbolp x) (setq x (list x 3))) |
578 |
|
(if (or (not (consp x)) |
579 |
|
(not (consp (cdr x))) |
580 |
|
(not (numberp (cadr x))) |
581 |
|
(not (<= 0 (cadr x) 3))) |
582 |
|
(warn "The OPTIMIZE proclamation ~s is illegal." x) |
583 |
|
(case (car x) |
584 |
|
(safety |
585 |
|
(unless (= (cadr x) |
586 |
|
(cond ((null *compiler-check-args*) 0) |
587 |
|
((null *safe-compile*) 1) |
588 |
|
((null *compiler-push-events*) 2) |
589 |
|
(t 3))) |
590 |
|
(return nil))) |
591 |
|
(space (unless (= (cadr x) *space*) (return nil))) |
592 |
|
(speed (unless (= (cadr x) *speed*) (return nil))) |
593 |
|
(compilation-speed |
594 |
|
(unless (= (- 3 (cadr x)) *speed*) (return nil))) |
595 |
|
(t (warn "The OPTIMIZE quality ~s is unknown." |
596 |
|
(car x))))))) |
597 |
|
(type |
598 |
|
(if (consp (cdr decl)) |
599 |
|
(let ((type (type-filter (cadr decl))) |
600 |
|
x) |
601 |
|
(dolist** (var (cddr decl) t) |
602 |
|
(if (symbolp var) |
603 |
|
(unless (and (setq x (get var 'cmp-type)) |
604 |
|
(equal x type)) |
605 |
|
(return nil)) |
606 |
|
(warn "The variable name ~s is not a symbol." var)))) |
607 |
|
(warn "The type declaration ~s is illegal." decl))) |
608 |
|
((fixnum character short-float long-float) |
609 |
|
(let ((type (type-filter (car decl))) |
610 |
|
x) |
611 |
|
(dolist** (var (cdr decl) t) |
612 |
|
(if (symbolp var) |
613 |
|
(unless (and (setq x (get var 'cmp-type)) (equal x type)) |
614 |
|
(return nil)) |
615 |
|
(warn "The variable name ~s is not a symbol." var))))) |
616 |
|
(ftype |
617 |
|
(if (or (endp (cdr decl)) |
618 |
|
(not (consp (cadr decl))) |
619 |
|
(not (eq (caadr decl) 'function)) |
620 |
|
(endp (cdadr decl))) |
621 |
|
(warn "The function declaration ~s is illegal." decl) |
622 |
|
(dolist** (fname (cddr decl) t) |
623 |
|
(unless (and (get fname 'proclaimed-function) |
624 |
|
(equal (function-arg-types (cadadr decl)) |
625 |
|
(get fname 'proclaimed-arg-types)) |
626 |
|
(equal (function-return-type (cddadr decl)) |
627 |
|
(get fname 'proclaimed-return-type))) |
628 |
|
(return nil))))) |
629 |
|
(function |
630 |
|
(if (or (endp (cdr decl)) (endp (cddr decl))) |
631 |
|
(warn "The function declaration ~s is illegal." decl) |
632 |
|
(and (get (cadr decl) 'proclaimed-function) |
633 |
|
(equal (function-arg-types (caddr decl)) |
634 |
|
(get (cadr decl) 'proclaimed-arg-types)) |
635 |
|
(equal (function-return-type (cdddr decl)) |
636 |
|
(get (cadr decl) 'proclaimed-return-type))))) |
637 |
|
(inline (dolist** (fun (cdr decl) t) |
638 |
|
(if (symbolp fun) |
639 |
|
(when (get fun 'cmp-notinline) (return nil)) |
640 |
|
(warn "The function name ~s is not a symbol." fun)))) |
641 |
|
(notinline (dolist** (fun (cdr decl) t) |
642 |
|
(if (symbolp fun) |
643 |
|
(unless (get fun 'cmp-notinline) (return nil)) |
644 |
|
(warn "The function name ~s is not a symbol." fun)))) |
645 |
|
((object ignore) |
646 |
|
(dolist** (var (cdr decl) t) |
647 |
|
(unless (symbolp var) |
648 |
|
(warn "The variable name ~s is not a symbol." var)))) |
649 |
|
(declaration (dolist** (x (cdr decl) t) |
650 |
|
(if (symbolp x) |
651 |
|
(unless (member x *alien-declarations*) (return nil)) |
652 |
|
(warn "The declaration specifier ~s is not a symbol." |
653 |
|
x)))) |
654 |
|
((array atom bignum bit bit-vector character common compiled-function |
655 |
|
complex cons double-float fixnum float hash-table integer keyword list |
656 |
|
long-float nil null number package pathname random-state ratio rational |
657 |
|
readtable sequence short-float simple-array simple-bit-vector |
658 |
|
simple-string simple-vector single-float standard-char stream string |
659 |
|
string-char symbol t vector signed-byte unsigned-byte) |
660 |
|
(let ((type (type-filter (car decl)))) |
661 |
|
(dolist** (var (cdr decl) t) |
662 |
|
(if (symbolp var) |
663 |
|
(unless (equal (get var 'cmp-type) type) (return nil)) |
664 |
|
(warn "The variable name ~s is not a symbol." var))))) |
665 |
|
(otherwise |
666 |
|
(unless (member (car decl) *alien-declarations*) |
667 |
|
(warn "The declaration specifier ~s is unknown." (car decl)))) |
668 |
|
) |
669 |
|
) |
670 |
|
|