1
;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
2
;;;; Copyright (c) 1990, Giuseppe Attardi.
4
;;;; This program is free software; you can redistribute it and/or
5
;;;; modify it under the terms of the GNU Library General Public
6
;;;; License as published by the Free Software Foundation; either
7
;;;; version 2 of the License, or (at your option) any later version.
9
;;;; See file '../Copyright' for full details.
11
;;;; CMPENV Environments of the Compiler.
13
(in-package "COMPILER")
15
;;; Only these flags are set by the user.
16
;;; If (safe-compile) is ON, some kind of run-time checks are not
17
;;; included in the compiled code. The default value is OFF.
20
(setq *callbacks* nil)
23
(setq *next-cmacro* 0)
26
(setq *permanent-objects* nil)
27
(setq *temporary-objects* nil)
28
(setq *local-funs* nil)
29
(setq *global-var-objects* nil)
30
(setq *global-vars* nil)
31
(setq *global-funs* nil)
32
(setq *linking-calls* nil)
33
(setq *global-entries* nil)
34
(setq *undefined-vars* nil)
35
(setq *reservations* nil)
36
(setq *top-level-forms* nil)
37
(setq *compile-time-too* nil)
38
(setq *clines-string-list* '())
39
(setq *function-declarations* nil)
40
(setq *inline-functions* nil)
41
(setq *inline-blocks* 0)
42
(setq *notinline* nil)
45
(defun next-lcl () (list 'LCL (incf *lcl*)))
47
(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil))
48
(let ((code (incf *next-cfun*)))
49
(format nil prefix code (lisp-to-c-name lisp-name))))
54
(setq *max-temp* (max *temp* *max-temp*))))
57
(prog1 (cons *level* *lex*)
59
(setq *max-lex* (max *lex* *max-lex*))))
61
(defun next-env () (prog1 *env*
63
(setq *max-env* (max *env* *max-env*))))
65
(defun function-arg-types (arg-types &aux (types nil))
66
(do ((al arg-types (cdr al)))
68
(member (car al) '(&optional &rest &key)))
71
(push (type-filter (car al)) types)))
73
;;; The valid return type declaration is:
74
;;; (( VALUES {type}* )) or ( {type}* ).
76
(defun function-return-type (return-types)
77
(cond ((endp return-types) t)
78
((and (consp (car return-types))
79
(eq (caar return-types) 'VALUES))
80
(cond ((not (endp (cdr return-types)))
81
(warn "The function return types ~s is illegal." return-types)
83
((or (endp (cdar return-types))
84
(member (cadar return-types) '(&optional &rest &key)))
86
(t (type-filter (cadar return-types)))))
87
(t (type-filter (car return-types)))))
89
(defun add-function-proclamation (fname decl &aux
90
arg-types return-types)
91
(cond ((and (symbolp fname)
92
(listp decl) (listp (cdr decl)))
93
(cond ((or (null decl)(eq (car decl) '*)) (setq arg-types '*)
94
(rem-sysprop fname 'PROCLAIMED-ARG-TYPES))
95
(t (setq arg-types (function-arg-types (car decl)))
96
(put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)))
97
(cond ((or (null (cdr decl))(eq (second decl) '*))
98
(setq return-types '*))
99
(t (setq return-types (function-return-type (cdr decl)))))
100
(put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types)
101
(cond((eql return-types '*))
102
(t(setq return-types (cdr decl))))
103
;;; A non-local function may have local entry only if it returns
105
(if (and (not (endp return-types))
106
(endp (cdr return-types))
107
(not (and (consp (car return-types))
108
(eq (caar return-types) 'VALUES)
109
(or (endp (cdar return-types))
110
(not (endp (cddar return-types)))))))
111
(put-sysprop fname 'PROCLAIMED-FUNCTION t)
112
(rem-sysprop fname 'PROCLAIMED-FUNCTION)))
113
(t (warn "The function procl ~s ~s is not valid." fname decl))))
115
(defun add-function-declaration (fname arg-types return-types)
116
(if (si::valid-function-name-p fname)
117
(push (list (sch-local-fun fname)
118
(function-arg-types arg-types)
119
(function-return-type return-types))
120
*function-declarations*)
121
(warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)))
123
(defun get-arg-types (fname)
124
(let ((x (assoc fname *function-declarations*)))
127
(get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
129
(defun get-return-type (fname)
130
(let ((x (assoc fname *function-declarations*)))
133
(get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
135
(defun get-local-arg-types (fun &aux x)
136
(if (setq x (assoc fun *function-declarations*))
140
(defun get-local-return-type (fun &aux x)
141
(if (setq x (assoc fun *function-declarations*))
145
(defun get-proclaimed-narg (fun)
146
(multiple-value-bind (x found)
147
(get-sysprop fun 'PROCLAIMED-ARG-TYPES)
149
(let ((minarg (length x)))
150
(if (eq (first (last x)) '*)
151
(setf minarg (1- minarg)
152
maxarg call-arguments-limit)
153
(setf maxarg minarg))
154
(values minarg maxarg))
155
(values 0 call-arguments-limit))))
157
;;; Proclamation and declaration handling.
159
(defun inline-possible (fname)
160
(not (or ; (compiler-push-events)
161
(member fname *notinline* :test #'same-fname-p)
162
(and (symbolp fname) (get-sysprop fname 'CMP-NOTINLINE)))))
165
(defun proclaim (decl)
167
(error "The proclamation specification ~s is not a list" decl))
170
(dolist (var (cdr decl))
172
(sys:*make-special var)
173
(error "Syntax error in proclamation ~s" decl))))
175
(dolist (x (cdr decl))
176
(when (symbolp x) (setq x (list x 3)))
177
(if (or (not (consp x))
178
(not (consp (cdr x)))
179
(not (numberp (second x)))
180
(not (<= 0 (second x) 3)))
181
(warn "The OPTIMIZE proclamation ~s is illegal." x)
184
(SAFETY (setq *safety* (second x)))
185
(SPACE (setq *space* (second x)))
186
(SPEED (setq *speed* (second x)))
187
(COMPILATION-SPEED (setq *speed* (- 3 (second x))))
188
(t (warn "The OPTIMIZE quality ~s is unknown." (car x)))))))
190
(if (consp (cdr decl))
191
(proclaim-var (second decl) (cddr decl))
192
(error "Syntax error in proclamation ~s" decl)))
195
(cond ((and (consp (cdr decl))
196
(consp (setf ftype (second decl)))
197
(eq (first ftype) 'FUNCTION))
198
(dolist (v (cddr decl))
199
(add-function-proclamation v (rest ftype))))
200
(t (error "Syntax error in proclamation ~a" decl)))))
202
(dolist (fun (cdr decl))
203
(if (si::valid-function-name-p fun)
204
(rem-sysprop fun 'CMP-NOTINLINE)
205
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
207
(dolist (fun (cdr decl))
208
(if (si::valid-function-name-p fun)
209
(put-sysprop fun 'CMP-NOTINLINE t)
210
(error "Not a valid function name ~s in proclamation ~s" fun decl))))
211
((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE)
213
(dolist (var (cdr decl))
214
(unless (si::valid-function-name-p var)
215
(error "Not a valid function name ~s in ~s proclamation" fun (car decl)))))
217
(do-declaration (rest decl) #'error))
219
(dolist (x (cdr decl))
221
(multiple-value-bind (found fname)
222
(si::mangle-name x t)
224
(warn "The function ~s is already in the runtime." x)
225
(put-sysprop x 'Lfun fname)))
226
(error "Syntax error in proclamation ~s" decl))))
227
((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMPILED-FUNCTION
228
COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
229
LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL
230
READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR
231
SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING
232
SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION)
233
(proclaim-var (car decl) (cdr decl)))
235
(unless (member (car decl) si:*alien-declarations*)
236
(warn "The declaration specifier ~s is unknown." (car decl)))
237
(and (functionp (get-sysprop (car decl) :proclaim))
238
(dolist (v (cdr decl))
239
(funcall (get-sysprop (car decl) :proclaim) v))))
244
(defun type-name-p (name)
245
(or (get-sysprop name 'SI::DEFTYPE-DEFINITION)
246
(find-class name nil)
247
(get-sysprop name 'SI::STRUCTURE-TYPE)))
249
(defun do-declaration (names-list error)
250
(declare (si::c-local))
251
(dolist (new-declaration names-list)
252
(unless (symbolp new-declaration)
253
(funcall error "The declaration ~s is not a symbol" new-declaration))
254
(when (type-name-p new-declaration)
255
(funcall error "Symbol name ~S cannot be both the name of a type and of a declaration"
257
(pushnew new-declaration si:*alien-declarations*)))
259
(defun proclaim-var (type vl)
260
(setq type (type-filter type))
263
(let ((type1 (get-sysprop var 'CMP-TYPE))
264
(v (sch-global var)))
265
(setq type1 (if type1 (type-and type1 type) type))
266
(when v (setq type1 (type-and type1 (var-type v))))
269
"Inconsistent type declaration was found for the variable ~s."
272
(put-sysprop var 'CMP-TYPE type1)
273
(when v (setf (var-type v) type1)))
274
(warn "The variable name ~s is not a symbol." var))))
276
(defun c1body (body doc-p &aux
277
(all-declarations nil)
278
(ss nil) ; special vars
279
(is nil) ; ignored vars
280
(ts nil) ; typed vars (var . type)
281
(others nil) ; all other vars
284
(when (endp body) (return))
285
(setq form (cmp-macroexpand (car body)))
288
(when (or (null doc-p) (endp (cdr body)) doc) (return))
290
((and (consp form) (eq (car form) 'DECLARE))
291
(push form all-declarations)
292
(dolist (decl (cdr form))
293
(cmpassert (and (proper-list-p decl) (symbolp (first decl)))
294
"Syntax error in declaration ~s" form)
295
(let* ((decl-name (first decl))
296
(decl-args (rest decl)))
297
(flet ((declare-variables (type var-list)
298
(cmpassert (proper-list-p var-list #'symbolp)
299
"Syntax error in declaration ~s" decl)
301
(dolist (var var-list)
302
(push (cons var type) ts)))))
305
(cmpassert (proper-list-p decl-args #'symbolp)
306
"Syntax error in declaration ~s" decl)
307
(setf ss (append decl-args ss)))
309
(cmpassert (proper-list-p decl-args #'symbolp)
310
"Syntax error in declaration ~s" decl)
311
(setf is (append decl-args is)))
313
(cmpassert decl-args "Syntax error in declaration ~s" decl)
314
(declare-variables (type-filter (first decl-args))
317
(declare-variables 'OBJECT decl-args))
318
;; read-only variable treatment. obsolete!
320
((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL
321
DYNAMIC-EXTENT IGNORABLE VALUES)
324
(if (member decl-name si::*alien-declarations*)
326
(multiple-value-bind (ok type)
327
(valid-type-specifier decl-name)
328
(cmpassert ok "The declaration specifier ~s is unknown." decl-name)
329
(declare-variables type decl-args))))
334
(values body ss ts is others doc all-declarations)
337
(defun c1add-declarations (decls &aux (dl nil))
338
(dolist (decl decls dl)
342
(dolist (x (cdr decl))
343
(when (symbolp x) (setq x (list x 3)))
344
(if (or (not (consp x))
345
(not (consp (cdr x)))
346
(not (numberp (second x)))
347
(not (<= 0 (second x) 3)))
348
(cmpwarn "The OPTIMIZE proclamation ~s is illegal." x)
351
(SAFETY (setq *safety* (second x)))
352
(SPACE (setq *space* (second x)))
353
((SPEED COMPILATION-SPEED))
354
(t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x)))))))
357
(cond ((and (consp (cdr decl))
358
(consp (setq ftype (second decl)))
359
(eq (first ftype) 'FUNCTION))
360
(dolist (v (cddr decl))
361
(add-function-declaration v (second ftype) (cddr ftype))))
362
(t (cmpwarn "Syntax error in declaration ~s" decl)))))
365
(dolist (fun (cdr decl))
367
(setq *notinline* (remove fun *notinline*))
368
(cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
371
(dolist (fun (cdr decl))
373
(push fun *notinline*)
374
(cmperr "Not a valid function name ~s in declaration ~s" fun decl))))
376
(do-declaration (rest decl) #'cmperr))
377
((SI::C-LOCAL SI::C-GLOBAL))
378
((DYNAMIC-EXTENT IGNORABLE)
379
;; FIXME! SOME ARE IGNORED!
382
(unless (member (car decl) si:*alien-declarations*)
383
(cmpwarn "The declaration specifier ~s is unknown." (car decl)))))))
385
(defun c1decl-body (decls body)
388
(let* ((*function-declarations* *function-declarations*)
389
(si:*alien-declarations* si:*alien-declarations*)
390
(*notinline* *notinline*)
394
(dl (c1add-declarations decls)))
395
(setq body (c1progn body))
396
(make-c1form 'DECL-BODY body dl body))))
398
(put-sysprop 'decl-body 'c2 'c2decl-body)
400
(defun c2decl-body (decls body)
401
(let ((*safety* *safety*)
404
(*notinline* *notinline*))
405
(c1add-declarations decls)
408
(defun check-vdecl (vnames ts is)
410
(unless (member (car x) vnames)
411
(cmpwarn "Type declaration was found for not bound variable ~s."
414
(unless (member x vnames)
415
(cmpwarn "Ignore declaration was found for not bound variable ~s." x)))
added
removed
src/cmp/cmpenv.lsp
