variables in the COMMON-LISP package, and will signal errors for
most violations of these type constraints (where previously they
were silently accepted).
+ * minor incompatible change: COMPILE-FILE now uses the freedom
+ afforded (ANSI 3.2.2.3) to use derived function types for
+ functions defined in the same file. This also permits the system
+ to warn on static type mismatches and function redefinition.
* changes in type checking closed the following bugs:
** type checking of unused values (192b, 194d, 203);
** template selection based on unsafe type assertions (192c, 236);
nil)))
(defun (setf interactive-stream-p) (flag stream)
- (etypecase stream
+ (typecase stream
(simple-stream
(if flag
(add-stream-instance-flags stream :interactive)
(progn (sb-impl::stream-must-be-associated-with-file stream)
(funcall (sb-kernel:ansi-stream-misc stream) stream :file-length)))))
-(defun line-length (&optional (stream *standard-output*))
- "Returns the number of characters that will fit on a line of output on the
- given Stream, or Nil if that information is not available."
- (let ((stream (sb-impl::out-synonym-of stream)))
- (etypecase stream
- (simple-stream
- (%simple-stream-line-length stream))
- (ansi-stream
- (funcall (sb-kernel:ansi-stream-misc stream) stream :line-length))
- (fundamental-stream
- (sb-gray:stream-line-length stream)))))
-
(defun charpos (&optional (stream *standard-output*))
"Returns the number of characters on the current line of output of the given
Stream, or Nil if that information is not availible."
;;; On any OS where we don't support foreign object file loading, any
;;; query of a foreign symbol value is answered with "no definition
;;; known", i.e. NIL.
-;;;
-;;; (On any OS which *does* support foreign object file loading, this
-;;; placeholder implementation is overwritten by a subsequent real
-;;; implementation.)
-;;;
-;;; You may want to use SB-SYS:FOREIGN-SYMBOL-ADDRESS instead of
-;;; calling this directly; see code/target-load.lisp.
+#-(or linux sunos FreeBSD OpenBSD)
(defun get-dynamic-foreign-symbol-address (symbol)
(declare (type simple-string symbol) (ignore symbol))
nil)
(let* ((leaf (functional-entry-fun fun))
(defined-ftype (definition-type leaf)))
(setf (leaf-type leaf) defined-ftype)
- (when (leaf-has-source-name-p leaf)
+ (when (and (leaf-has-source-name-p leaf)
+ (eq (leaf-source-name leaf) (functional-debug-name leaf)))
(let ((source-name (leaf-source-name leaf)))
(let* ((where (info :function :where-from source-name))
(*compiler-error-context* (lambda-bind (main-entry leaf)))
(type-specifier declared-ftype)
(type-specifier defined-ftype)))))
(:defined
- (setf (info :function :type source-name) defined-ftype)))))))
+ (setf (info :function :type source-name) defined-ftype)))
+ (when (fasl-output-p *compile-object*)
+ (if (member source-name *fun-names-in-this-file* :test #'equal)
+ (compiler-warn "~@<Duplicate definition for ~S found in ~
+ one static unit (usually a file).~@:>"
+ source-name)
+ (push source-name *fun-names-in-this-file*)))))))
(values))
;;; Find all calls in COMPONENT to assumed functions and update the
gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
the efficiency of stable code.")
+(defvar *fun-names-in-this-file* nil)
+
;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
;;; insertion a (CATCH ...) around code to allow the debugger RETURN
;;; command to function.
\f
;;;; namespace management utilities
+(defun fun-lexically-notinline-p (name)
+ (let ((fun (lexenv-find name funs :test #'equal)))
+ ;; a declaration will trump a proclamation
+ (if (and fun (defined-fun-p fun))
+ (eq (defined-fun-inlinep fun) :notinline)
+ (eq (info :function :inlinep name) :notinline))))
+
;;; Return a GLOBAL-VAR structure usable for referencing the global
;;; function NAME.
(defun find-free-really-fun (name)
;; definedness at runtime, which is what matters.
#-sb-xc-host (not (fboundp name)))
(note-undefined-reference name :function))
- (make-global-var :kind :global-function
- :%source-name name
- :type (if (or *derive-function-types*
- (eq where :declared))
- (info :function :type name)
- (specifier-type 'function))
- :where-from where)))
+ (make-global-var
+ :kind :global-function
+ :%source-name name
+ :type (if (or *derive-function-types*
+ (eq where :declared)
+ (and (member name *fun-names-in-this-file* :test #'equal)
+ (not (fun-lexically-notinline-p name))))
+ (info :function :type name)
+ (specifier-type 'function))
+ :where-from where)))
;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
;;;
:inline-expansion expansion
:inlinep inlinep
:where-from (info :function :where-from name)
- :type (info :function :type name))
+ :type (if (eq inlinep :notinline)
+ (specifier-type 'function)
+ (info :function :type name)))
(find-free-really-fun name))))))))
;;; Return the LEAF structure for the lexically apparent function
(make-lexenv :default res :vars (new-venv))
res)))
-;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP.
+;;; Return a DEFINED-FUN which copies a GLOBAL-VAR but for its INLINEP
+;;; (and TYPE if notinline).
(defun make-new-inlinep (var inlinep)
(declare (type global-var var) (type inlinep inlinep))
(let ((res (make-defined-fun
:%source-name (leaf-source-name var)
:where-from (leaf-where-from var)
- :type (leaf-type var)
+ :type (if (eq inlinep :notinline)
+ (specifier-type 'function)
+ (leaf-type var))
:inlinep inlinep)))
(when (defined-fun-p var)
(setf (defined-fun-inline-expansion res)
#!+sb-show *compiler-trace-output*
*last-source-context* *last-original-source*
*last-source-form* *last-format-string* *last-format-args*
- *last-message-count* *lexenv*))
+ *last-message-count* *lexenv* *fun-names-in-this-file*))
;;; Whether call of a function which cannot be defined causes a full
;;; warning.
(multiple-value-prog1 (funcall fn) (setf succeeded-p t))
(unless succeeded-p
(incf *aborted-compilation-unit-count*)))
- ;; FIXME: Now *COMPILER-FOO-COUNT* stuff is bound in more than
- ;; one place. If we can get rid of the IR1 interpreter, this
- ;; should be easier to clean up.
(let ((*aborted-compilation-unit-count* 0)
(*compiler-error-count* 0)
(*compiler-warning-count* 0)
(sb!xc:*compile-file-pathname* nil)
(sb!xc:*compile-file-truename* nil)
(*toplevel-lambdas* ())
+ (*fun-names-in-this-file* ())
(*compiler-error-bailout*
(lambda ()
(compiler-mumble "~2&; fatal error, aborting compilation~%")
req-args)))
`(list*
:fast-function
- (named-lambda
- ,(or (body-method-name body) '.method.) ; function name
+ (,(if (body-method-name body) 'named-lambda 'lambda)
+ ,@(when (body-method-name body)
+ (list (body-method-name body))) ; function name
(.pv-cell. .next-method-call. ,@args+rest-arg) ; function args
;; body of the function
(declare (ignorable .pv-cell. .next-method-call.))
--- /dev/null
+#!/bin/sh
+
+# This software is part of the SBCL system. See the README file for
+# more information.
+#
+# While most of SBCL is derived from the CMU CL system, the test
+# files (like this one) were written from scratch after the fork
+# from CMU CL.
+#
+# This software is in the public domain and is provided with
+# absolutely no warranty. See the COPYING and CREDITS files for
+# more information.
+
+# FIXME: the functions below should be in their own file, sourced by
+# each of the *.test.sh scripts.
+
+# Check that compiling and loading the file $1 generates an error
+# at load time; also that just loading it directly (into the
+# interpreter) generates an error.
+expect_load_error ()
+{
+ # Test compiling and loading.
+ $SBCL <<EOF
+ (compile-file "$1")
+ ;;; But loading the file should fail.
+ (multiple-value-bind (value0 value1) (ignore-errors (load *))
+ (assert (null value0))
+ (format t "VALUE1=~S (~A)~%" value1 value1)
+ (assert (typep value1 'error)))
+ (sb-ext:quit :unix-status 52)
+EOF
+ if [ $? != 52 ]; then
+ echo compile-and-load $1 test failed: $?
+ exit 1
+ fi
+
+ # Test loading into the interpreter.
+ $SBCL <<EOF
+ (multiple-value-bind (value0 value1) (ignore-errors (load "$1"))
+ (assert (null value0))
+ (format t "VALUE1=~S (~A)~%" value1 value1)
+ (assert (typep value1 'error)))
+ (sb-ext:quit :unix-status 52)
+EOF
+ if [ $? != 52 ]; then
+ echo load-into-interpreter $1 test failed: $?
+ exit 1
+ fi
+}
+
+# Test that a file compiles cleanly, with no ERRORs, WARNINGs or
+# STYLE-WARNINGs.
+expect_clean_compile ()
+{
+ $SBCL <<EOF
+ (multiple-value-bind (pathname warnings-p failure-p)
+ (compile-file "$1")
+ (declare (ignore pathname))
+ (assert (not warnings-p))
+ (assert (not failure-p))
+ (sb-ext:quit :unix-status 52))
+EOF
+ if [ $? != 52 ]; then
+ echo clean-compile $1 test failed: $?
+ exit 1
+ fi
+}
+
+expect_warned_compile ()
+{
+ $SBCL <<EOF
+ (multiple-value-bind (pathname warnings-p failure-p)
+ (compile-file "$1")
+ (declare (ignore pathname))
+ (assert warnings-p)
+ (assert (not failure-p))
+ (sb-ext:quit :unix-status 52))
+EOF
+ if [ $? != 52 ]; then
+ echo warn-compile $1 test failed: $?
+ exit 1
+ fi
+}
+
+expect_failed_compile ()
+{
+ $SBCL <<EOF
+ (multiple-value-bind (pathname warnings-p failure-p)
+ (compile-file "$1")
+ (declare (ignore pathname warnings-p))
+ (assert failure-p)
+ (sb-ext:quit :unix-status 52))
+EOF
+ if [ $? != 52 ]; then
+ echo fail-compile $1 test failed: $?
+ exit 1
+ fi
+}
+
+base_tmpfilename="compiler-test-$$-tmp"
+tmpfilename="$base_tmpfilename.lisp"
+compiled_tmpfilename="$base_tmpfilename.fasl"
+
+# This should fail, as type inference should show that the call to FOO
+# will return something of the wrong type.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defun foo (x) (list x))
+ (defun bar (x) (1+ (foo x)))
+EOF
+expect_failed_compile $tmpfilename
+
+# This should fail, as we define a function multiply in the same file
+# (CLHS 3.2.2.3).
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defun foo (x) (list x))
+ (defun foo (x) (cons x x))
+EOF
+expect_failed_compile $tmpfilename
+
+# This shouldn't fail, as the inner FLETs should not be treated as
+# having the same name.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defun foo (x)
+ (flet ((baz (y) (load y)))
+ (declare (notinline baz))
+ (baz x)))
+ (defun bar (x)
+ (flet ((baz (y) (load y)))
+ (declare (notinline baz))
+ (baz x)))
+EOF
+expect_clean_compile $tmpfilename
+
+# This shouldn't fail despite the apparent type mismatch, because of
+# the NOTINLINE declamation.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defun foo (x) (list x))
+ (declaim (notinline foo))
+ (defun bar (x) (1+ (foo x)))
+EOF
+expect_clean_compile $tmpfilename
+
+# This shouldn't fail despite the apparent type mismatch, because of
+# the NOTINLINE declaration.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defun foo (x) (list x))
+ (defun bar (x)
+ (declare (notinline foo))
+ (1+ (foo x)))
+EOF
+expect_clean_compile $tmpfilename
+
+# This in an ideal world would fail, but at present it doesn't.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defun foo (x) (list x))
+ (defun bar (x)
+ (declare (notinline foo))
+ (locally
+ (declare (inline foo))
+ (1+ (foo x))))
+EOF
+# expect_failed_compile $tmpfilename
+
+rm $tmpfilename
+rm $compiled_tmpfilename
+
+# success
+exit 104
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.0.53"
+"0.8.0.54"
projects / sbcl.git / commitdiff