~ chicken-core (chicken-5) 150644df9793b774686f94561f8681897f5bad22
commit 150644df9793b774686f94561f8681897f5bad22
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jun 10 08:33:19 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jun 10 08:33:19 2011 +0200
doc and test fixes; added notes in code about type-qualifications for FFI forms; added type-conversion routine (unused yet)
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index dd07b0e2..b8e9a0d7 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -112,27 +112,28 @@
(##sys#check-syntax 'let-location form '(_ #((variable _ . #(_ 0 1)) 0) . _))
(let* ((bindings (cadr form))
(body (cddr form))
- [aliases (map (lambda (_) (r (gensym))) bindings)])
- `(##core#let ,(append-map
- (lambda (b a)
- (if (pair? (cddr b))
- (list (cons a (cddr b)))
- '() ) )
- bindings aliases)
- ,(fold-right
- (lambda (b a rest)
- (if (= 3 (length b))
- `(##core#let-location
- ,(car b)
- ,(cadr b)
- ,a
- ,rest)
- `(##core#let-location
- ,(car b)
- ,(cadr b)
- ,rest) ) )
- `(##core#let () ,@body)
- bindings aliases) ) ) ) ) )
+ (aliases (map (lambda (_) (r (gensym))) bindings)))
+ `(##core#let
+ ,(append-map
+ (lambda (b a)
+ (if (pair? (cddr b))
+ (list (cons a (cddr b)))
+ '() ) )
+ bindings aliases)
+ ,(fold-right
+ (lambda (b a rest)
+ (if (= 3 (length b))
+ `(##core#let-location
+ ,(car b)
+ ,(cadr b)
+ ,a
+ ,rest)
+ `(##core#let-location
+ ,(car b)
+ ,(cadr b)
+ ,rest) ) )
+ `(##core#let () ,@body)
+ bindings aliases) ) ) ) ) )
;;; Embedding code directly:
@@ -166,10 +167,11 @@
,(cond ((string? code) code)
((symbol? code) (symbol->string code))
(else (syntax-error 'foreign-value "bad argument type - not a string or symbol" code))))
- ,tmp) ) ) ) )
+ ,tmp ;XXX (##core#the ',(foreign-type->scrutiny-type (caddr form) 'result) ,tmp)
+ ) ) ) ) )
-;;; Include/parse foreign code fragments
+;;; Include foreign code fragments
(##sys#extend-macro-environment
'foreign-declare
@@ -201,6 +203,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ ;;XXX check syntax and wrap in "##core#the"
`(##core#foreign-primitive ,@(cdr form)))))
(##sys#extend-macro-environment
@@ -208,6 +211,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ ;;XXX check syntax and wrap in "##core#the"
`(##core#foreign-lambda ,@(cdr form)))))
(##sys#extend-macro-environment
@@ -215,6 +219,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ ;;XXX check syntax and wrap in "##core#the"
`(##core#foreign-lambda* ,@(cdr form)))))
(##sys#extend-macro-environment
@@ -222,6 +227,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ ;;XXX check syntax and wrap in "##core#the"
`(##core#foreign-safe-lambda ,@(cdr form)))))
(##sys#extend-macro-environment
@@ -229,6 +235,7 @@
'()
(##sys#er-transformer
(lambda (form r c)
+ ;;XXX check syntax and wrap in "##core#the"
`(##core#foreign-safe-lambda* ,@(cdr form)))))
(##sys#extend-macro-environment
@@ -245,7 +252,8 @@
(##compiler#foreign-type-declaration t ""))))
`(##core#begin
(##core#define-foreign-variable ,tmp size_t ,(string-append "sizeof(" decl ")"))
- ,tmp) ) ) ) )
+ ,tmp ;XXX (##core#the 'fixnum ,tmp)
+ )))))
(##sys#macro-subset me0)))
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index c965f728..4a304e1d 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -148,6 +148,7 @@
foreign-lambda-stubs
foreign-result-conversion
foreign-string-result-reserve
+ foreign-type->scrutiny-type
foreign-type-check
foreign-type-convert-argument
foreign-type-convert-result
diff --git a/manual/Types b/manual/Types
index 23479d3a..89554858 100644
--- a/manual/Types
+++ b/manual/Types
@@ -64,7 +64,9 @@ compiling the code in unsafe mode will not generate type-checks.
Equivalent to {{EXPRESSION}}, but declares that the result will be of the
given type. Note that this form always declares the type of a single result,
-{{the}} can not be used to declare types for multiple result values.
+{{the}} can not be used to declare types for multiple result values. {{TYPE}}
+should be a subtype of the type inferred for {{EXPRESSION}}, the compiler
+will issue a warning if this should not be the case.
==== Type syntax
diff --git a/manual/Using the compiler b/manual/Using the compiler
index c5c8b2b7..584bb8a4 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -177,7 +177,7 @@ the source text should be read from standard input.
; -version : Prints the version and some copyright information and exit the compiler.
-; -verbose : Prints progress information to standard output during compilation.
+; -verbose : enables output of notes that are not necessarily warnings but might be of interest.
The environment variable {{CHICKEN_OPTIONS}} can be set to a string
with default command-line options for the compiler.
diff --git a/support.scm b/support.scm
index 088cb2b5..3488169f 100644
--- a/support.scm
+++ b/support.scm
@@ -1163,6 +1163,69 @@
body)])))
+;;; Translate foreign-type into scrutinizer type:
+
+(define (foreign-type->scrutiny-type t mode) ; MODE = 'arg | 'result
+ (let ((ft (final-foreign-type t)))
+ (case ft
+ ((char unsigned-char) 'char)
+ ((int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
+ 'fixnum)
+ ((float double)
+ (case mode
+ ((arg) 'number)
+ (else 'float)))
+ ((scheme-pointer nonnull-scheme-pointer) '*)
+ ((blob)
+ (case mode
+ ((arg) '(or boolean blob))
+ (else 'blob)))
+ ((nonnull-blob) 'blob)
+ ((pointer-vector)
+ (case mode
+ ((arg) '(or boolean pointer-vector))
+ (else 'pointer-vector)))
+ ((nonnull-pointer-vector) 'pointer-vector)
+ ((u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
+ (case mode
+ ((arg) `(or boolean (struct ,ft)))
+ (else `(struct ,ft))))
+ ((nonnull-u8vector) '(struct u8vector))
+ ((nonnull-s8vector) '(struct s8vector))
+ ((nonnull-u16vector) '(struct u16vector))
+ ((nonnull-s16vector) '(struct s16vector))
+ ((nonnull-u32vector) '(struct u32vector))
+ ((nonnull-s32vector) '(struct s32vector))
+ ((nonnull-f32vector) '(struct f32vector))
+ ((nonnull-f64vector) '(struct f64vector))
+ ((integer long size_t integer32 unsigned-integer32 integer64 unsigned-integer64
+ unsigned-long)
+ 'number)
+ ((c-pointer c-string-list c-string-list*)
+ (case mode
+ ((arg) '(or boolean pointer))
+ (else 'pointer)))
+ ((nonnull-c-pointer) 'pointer)
+ ((c-string c-string* unsigned-c-string unsigned-c-string*)
+ (case mode
+ ((arg) '(or boolean string))
+ (else 'string)))
+ ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*) 'string)
+ ((symbol) 'symbol)
+ (else
+ (cond ((pair? t)
+ (case (car t)
+ ((ref pointer function c-pointer)
+ (case mode
+ ((arg) '(or boolean pointer))
+ (else 'pointer)))
+ ((const) (foreign-type->scrutiny-type (cadr t) mode))
+ ((enum) 'number)
+ ((nonnull-pointer nonnull-c-pointer) 'pointer)
+ (else '*)))
+ (else '*))))))
+
+
;;; Scan expression-node for variable usage:
(define (scan-used-variables node vars)
@@ -1596,7 +1659,7 @@ Available debugging options:
r show invocation parameters
s show program-size information and other statistics
a show node-matching during simplification
- p show execution of compiler passes
+ p display information about what the compiler is currently doing
m show GC statistics during compilation
n print the line-number database
c print every expression before macro-expansion
diff --git a/tests/runtests.sh b/tests/runtests.sh
index f9178671..6f5c5692 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -70,7 +70,7 @@ $compile inlining-tests.scm -optimize-level 3
./a.out
echo "======================================== scrutiny tests ..."
-$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out
+$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out -verbose
if test -n "$MSYSTEM"; then
dos2unix scrutiny.out
@@ -83,7 +83,7 @@ fi
diff -bu scrutiny.expected scrutiny.out
-$compile scrutiny-tests-2.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny-2.out
+$compile scrutiny-tests-2.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny-2.out -verbose
./a.out
if test -n "$MSYSTEM"; then
diff --git a/tests/scrutiny-2.expected b/tests/scrutiny-2.expected
index 8223e9ce..3596b460 100644
--- a/tests/scrutiny-2.expected
+++ b/tests/scrutiny-2.expected
@@ -1,69 +1,69 @@
-Warning: at toplevel:
+Note: at toplevel:
pair?: in procedure call to `pair?', the predicate is called with an argument of type `pair' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
pair?: in procedure call to `pair?', the predicate is called with an argument of type `null' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
pair?: in procedure call to `pair?', the predicate is called with an argument of type `fixnum' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
pair?: in procedure call to `pair?', the predicate is called with an argument of type `float' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
list?: in procedure call to `list?', the predicate is called with an argument of type `list' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
list?: in procedure call to `list?', the predicate is called with an argument of type `fixnum' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
list?: in procedure call to `list?', the predicate is called with an argument of type `float' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
null?: in procedure call to `null?', the predicate is called with an argument of type `null' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
null?: in procedure call to `null?', the predicate is called with an argument of type `pair' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
null?: in procedure call to `null?', the predicate is called with an argument of type `fixnum' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
null?: in procedure call to `null?', the predicate is called with an argument of type `float' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
fixnum?: in procedure call to `fixnum?', the predicate is called with an argument of type `fixnum' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
fixnum?: in procedure call to `fixnum?', the predicate is called with an argument of type `float' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
exact?: in procedure call to `exact?', the predicate is called with an argument of type `fixnum' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
exact?: in procedure call to `exact?', the predicate is called with an argument of type `float' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
flonum?: in procedure call to `flonum?', the predicate is called with an argument of type `float' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
flonum?: in procedure call to `flonum?', the predicate is called with an argument of type `fixnum' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
inexact?: in procedure call to `inexact?', the predicate is called with an argument of type `float' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
inexact?: in procedure call to `inexact?', the predicate is called with an argument of type `fixnum' and will always return false
-Warning: at toplevel:
+Note: at toplevel:
number?: in procedure call to `number?', the predicate is called with an argument of type `fixnum' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
number?: in procedure call to `number?', the predicate is called with an argument of type `float' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
number?: in procedure call to `number?', the predicate is called with an argument of type `number' and will always return true
-Warning: at toplevel:
+Note: at toplevel:
number?: in procedure call to `number?', the predicate is called with an argument of type `null' and will always return false
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
index 6a81ff9c..47294d4a 100644
--- a/tests/scrutiny.expected
+++ b/tests/scrutiny.expected
@@ -2,7 +2,7 @@
Warning: at toplevel:
use of deprecated library procedure `current-environment'
-Warning: in local procedure `c',
+Note: in local procedure `c',
in local procedure `b',
in toplevel procedure `a':
expected value of type boolean in conditional but were given a value of
@@ -66,4 +66,22 @@ Warning: at toplevel:
Warning: in toplevel procedure `foo9':
scrutiny-tests.scm:97: in procedure call to `+', expected argument #1 of type `number', but was given an argument of type `string'
+Warning: in toplevel procedure `foo10':
+ expression returns a result of type `string', but is declared to return `pair', which is not a subtype
+
+Warning: in toplevel procedure `foo10':
+ scrutiny-tests.scm:101: in procedure call to `string-append', expected argument #1 of type `string', but was given an argument of type `pair'
+
+Warning: in toplevel procedure `foo10':
+ expression returns 2 values but is declared to have a single result
+
+Warning: in toplevel procedure `foo10':
+ expression returns a result of type `fixnum', but is declared to return `*', which is not a subtype
+
+Warning: in toplevel procedure `foo10':
+ expression returns zero values but is declared to have a single result of type `*'
+
+Warning: in toplevel procedure `foo10':
+ scrutiny-tests.scm:104: in procedure call to `*', expected argument #1 of type `number', but was given an argument of type `string'
+
Warning: redefinition of standard binding: car
Trap