projects
/
sbcl.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
sb-bsd-sockets: foreign memory leak in GET-PROTOCOL-BY-NAME
[sbcl.git]
/
src
/
compiler
/
ir1tran.lisp
diff --git
a/src/compiler/ir1tran.lisp
b/src/compiler/ir1tran.lisp
index
81b68f7
..
8a4cf1a
100644
(file)
--- a/
src/compiler/ir1tran.lisp
+++ b/
src/compiler/ir1tran.lisp
@@
-43,6
+43,11
@@
(when (source-form-has-path-p form)
(gethash form *source-paths*)))
(when (source-form-has-path-p form)
(gethash form *source-paths*)))
+(defun ensure-source-path (form)
+ (or (get-source-path form)
+ (cons (simplify-source-path-form form)
+ *current-path*)))
+
(defun simplify-source-path-form (form)
(if (consp form)
(let ((op (car form)))
(defun simplify-source-path-form (form)
(if (consp form)
(let ((op (car form)))
@@
-531,7
+536,8
@@
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
\f
;;;; IR1-CONVERT, macroexpansion and special form dispatching
-(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t &optional t)
+ (values))
ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
;; out of the body and converts a condition signalling form
ir1-convert))
(macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
;; out of the body and converts a condition signalling form
@@
-560,11
+566,9
@@
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
;; the creation using backquote of forms that contain leaf
;; references, without having to introduce dummy names into the
;; namespace.
- (defun ir1-convert (start next result form)
+ (defun ir1-convert (start next result form &optional alias)
(ir1-error-bailout (start next result form)
(ir1-error-bailout (start next result form)
- (let* ((*current-path* (or (get-source-path form)
- (cons (simplify-source-path-form form)
- *current-path*)))
+ (let* ((*current-path* (ensure-source-path (or alias form)))
(start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
(start (instrument-coverage start nil form)))
(cond ((atom form)
(cond ((and (symbolp form) (not (keywordp form)))
@@
-1201,6
+1205,9
@@
(declare (type list names fvars)
(type lexenv res))
(let ((type (compiler-specifier-type spec)))
(declare (type list names fvars)
(type lexenv res))
(let ((type (compiler-specifier-type spec)))
+ (unless (csubtypep type (specifier-type 'function))
+ (compiler-style-warn "ignoring declared FTYPE: ~S (not a function type)" spec)
+ (return-from process-ftype-decl res))
(collect ((res nil cons))
(dolist (name names)
(when (fboundp name)
(collect ((res nil cons))
(dolist (name names)
(when (fboundp name)
@@
-1374,13
+1381,17
@@
(setf (lambda-var-ignorep var) t)))))
(values))
(setf (lambda-var-ignorep var) t)))))
(values))
-(defun process-dx-decl (names vars fvars kind)
- (let ((dx (cond ((eq 'truly-dynamic-extent kind)
- :truly)
- ((and (eq 'dynamic-extent kind)
- *stack-allocate-dynamic-extent*)
- t))))
- (if dx
+(defun process-extent-decl (names vars fvars kind)
+ (let ((extent
+ (ecase kind
+ (truly-dynamic-extent
+ :always-dynamic)
+ (dynamic-extent
+ (when *stack-allocate-dynamic-extent*
+ :maybe-dynamic))
+ (indefinite-extent
+ :indefinite))))
+ (if extent
(dolist (name names)
(cond
((symbolp name)
(dolist (name names)
(cond
((symbolp name)
@@
-1391,21
+1402,23
@@
(etypecase var
(leaf
(if bound-var
(etypecase var
(leaf
(if bound-var
- (setf (leaf-dynamic-extent var) dx)
+ (if (and (leaf-extent var) (neq extent (leaf-extent var)))
+ (warn "Multiple incompatible extent declarations for ~S?" name)
+ (setf (leaf-extent var) extent))
(compiler-notify
(compiler-notify
- "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+ "Ignoring free ~S declaration: ~S" kind name)))
(cons
(cons
- (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+ (compiler-error "~S on symbol-macro: ~S" kind name))
(heap-alien-info
(heap-alien-info
- (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S"
- name))
+ (compiler-error "~S on alien-variable: ~S" kind name))
(null
(compiler-style-warn
(null
(compiler-style-warn
- "Unbound variable declared DYNAMIC-EXTENT: ~S" name)))))
+ "Unbound variable declared ~S: ~S" kind name)))))
((and (consp name)
(eq (car name) 'function)
(null (cddr name))
((and (consp name)
(eq (car name) 'function)
(null (cddr name))
- (valid-function-name-p (cadr name)))
+ (valid-function-name-p (cadr name))
+ (neq :indefinite extent))
(let* ((fname (cadr name))
(bound-fun (find fname fvars
:key #'leaf-source-name
(let* ((fname (cadr name))
(bound-fun (find fname fvars
:key #'leaf-source-name
@@
-1415,7
+1428,7
@@
(leaf
(if bound-fun
#!+stack-allocatable-closures
(leaf
(if bound-fun
#!+stack-allocatable-closures
- (setf (leaf-dynamic-extent bound-fun) dx)
+ (setf (leaf-extent bound-fun) extent)
#!-stack-allocatable-closures
(compiler-notify
"Ignoring DYNAMIC-EXTENT declaration on function ~S ~
#!-stack-allocatable-closures
(compiler-notify
"Ignoring DYNAMIC-EXTENT declaration on function ~S ~
@@
-1428,7
+1441,7
@@
(compiler-style-warn
"Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
(t
(compiler-style-warn
"Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
(t
- (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+ (compiler-error "~S on a weird thing: ~S" kind name))))
(when (policy *lexenv* (= speed 3))
(compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
(when (policy *lexenv* (= speed 3))
(compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
@@
-1483,8
+1496,8
@@
(car types)
`(values ,@types)))))
res))
(car types)
`(values ,@types)))))
res))
- ((dynamic-extent truly-dynamic-extent)
- (process-dx-decl (cdr spec) vars fvars (first spec))
+ ((dynamic-extent truly-dynamic-extent indefinite-extent)
+ (process-extent-decl (cdr spec) vars fvars (first spec))
res)
((disable-package-locks enable-package-locks)
(make-lexenv
res)
((disable-package-locks enable-package-locks)
(make-lexenv