~ chicken-core (chicken-5) /tests/compiler-tests.scm
Trap1;;;; compiler-tests.scm234(import (chicken bitwise) (chicken flonum) (chicken foreign)5 (chicken condition) (srfi 4))6(import-for-syntax (chicken syntax) (chicken string))78;; test dropping of previous toplevel assignments910(define (foo) (define (bar) 1) (bar 2)) ; will trigger error later11(define bar 1)12(define (baz) 2)13(define (foo) 'ok)1415(assert (eq? 'ok (foo)))1617(assert (= 1 (foreign-type-size "char")))18(let* ((words->bytes (foreign-lambda int "C_wordstobytes" int))19 (bytes-in-a-word (words->bytes 1)))20 (assert (= bytes-in-a-word (foreign-type-size "C_word"))))2122;; test hiding of unexported toplevel variables2324(module foo (bar)25 (import scheme chicken.base)26 (declare (hide bar))27 (define (bar x) (+ x 1)))2829(assert (not (##sys#symbol-has-toplevel-binding? 'foo#bar)))303132;;; rev. 12104 (reported by Jörg Wittenberger)33;34; - canonicalization of assignment to location didn't walk expansion recursively3536(define test-location37 (let-location ((again bool #f))38 (lambda ()39 ((foreign-lambda*40 int41 (((c-pointer bool) again))42 "*again=1; return(1);")43 (location again))44 again)))4546(assert (test-location))474849;;; rev. 12188 (reported by Jörg Wittenberger)50;51; - generated init-assignment refers to alias, but alias isn't seen later)5253(module54 x55 (bar)56 (import scheme chicken.base chicken.foreign)5758 (define (bar n)59 (let-location ((off integer 0))60 (lambda ()61 ((foreign-lambda*62 void63 (((c-pointer integer) i))64 "(*i)++;")65 (location off))66 off)))67)6869(import x)70(assert (= 1 ((bar 42))))717273;; Test custom foreign type conversions7475(module y (my-add1)76 (import scheme (chicken base) (chicken foreign))7778 (define-foreign-type my-int integer add1 sub1)7980 (define my-add1 (foreign-lambda* my-int ((my-int x)) "C_return(x+1);")))8182(import y)83(assert (= 2 (my-add1 1)))8485;;; rev. 14574 (reported by Peter Bex)86;87; - type specifiers in foreign-lambda in macros are incorrectly renamed88; - variable names and type specifiers in foreign-lambda* and89; foreign-primitive in macros are incorrectly renamed9091(let-syntax ((strlen-macro92 (syntax-rules ()93 ((strlen-macro arg)94 (print ((foreign-lambda int strlen c-string) arg)))))95 (strlen-macro*96 (syntax-rules ()97 ((strlen-macro* arg)98 (print ((foreign-lambda* int ((c-string str))99 "C_return(strlen(str));") arg)))))100 (strlen-safe-macro101 (syntax-rules ()102 ((strlen-safe-macro arg)103 (print ((foreign-safe-lambda int strlen c-string) arg)))))104 (strlen-safe-macro*105 (syntax-rules ()106 ((strlen-safe-macro* arg)107 (print ((foreign-safe-lambda* int ((c-string str))108 "C_return(strlen(str));") arg)))))109 (strlen-primitive-macro110 (syntax-rules ()111 ((strlen-primitive-macro* arg)112 (print ((foreign-primitive int ((c-string str))113 "C_return(strlen(str));") arg))))))114 (strlen-macro "hello, world")115 (strlen-macro* "hello, world")116 (strlen-safe-macro "hello, world")117 (strlen-safe-macro* "hello, world")118 (strlen-primitive-macro "hello, world"))119120;; Type specifiers and variable names in foreign-lambda in macros121;; are incorrectly renamed in modules, too.122(foreign-declare "void foo(void *abc) { printf(\"hi\\n\"); }")123;; This is silly but at least it ensures we can represent enum values124(foreign-declare "enum intlimits {min=INT_MIN, zero=0, max=INT_MAX};")125126(module foo ()127 (import scheme chicken.base chicken.foreign)128129 (let-syntax ((fl130 (syntax-rules ()131 ((_)132 (foreign-lambda void foo (c-pointer void)))))133 (fl*134 (syntax-rules ()135 ((_)136 (foreign-lambda* void (((c-pointer void) a))137 "C_return(a);"))))138 (fp139 (syntax-rules ()140 ((_)141 (foreign-primitive void (((c-pointer void) a))142 "C_return(a);")))))143 (fl)144 (fl*)145 (fp)))146147148;; "const" qualifier should have no visible effect in Scheme149(define-syntax generate-external150 (syntax-rules ()151 ((_) (define-external152 (print_foo ((const c-string) foo))153 void154 (assert (string? foo))155 (print foo)))))156(generate-external)157((foreign-safe-lambda* void ()158 "print_foo(\"bar\");"))159160161;; Unused arguments in foreign callback wrappers are not optimized away (#584)162(module bla (foo)163164(import (prefix scheme s:) (only chicken.base assert) chicken.foreign)165166(define-external167 (blabla (int a) (c-string b) (int c) (int d) (c-string e) (int f))168 int169 f)170171(s:define (foo) ((foreign-safe-lambda* int () "C_return(blabla(1, \"2\", 3, 4, \"5\", 6));")))172173(assert (location blabla))174)175176(import bla)177(assert (= (foo) 6))178179180;;; compiler-syntax for map/for-each must be careful when the181; operator may have side-effects (currently only lambda exprs and symbols182; are allowed)183184(let ((x #f))185 (define (f1 x) (print* x " "))186 (map f1 '(1 2 3))187 (newline)188 (map (begin (assert (not x))189 (set! x #t)190 f1)191 '(1 2 3))192 (map (lambda (x) (print* ":" x)) '(1 2 3))193 (newline))194195(let ((x #f))196 (define (f1 x) (print* x " "))197 (let-syntax ((f1 (syntax-rules ()198 ((_ y)199 (begin200 (assert (not x))201 (set! x #t)202 f1)))))203 (for-each f1 '(1 2 3))))204205(newline)206207;; Test safety of ##sys#make-c-string208(handle-exceptions exn (print "Good, unrepresentable C strings cause errors")209 (print "BUG! We got, without error, length = "210 ((foreign-lambda* int ((c-string str))211 "C_return(strlen(str));")212 "foo\x00bar")))213214215;; failed compile-time argument count check (reported by Alan Post)216;; cbb27fe380ff8e45cdf04d812e1ec649bf45ca47217218(define (foo)219 (define (bar #!key a)220 (define (baz)221 (bar a: #t))222 baz)223 bar)224225226;; global-propagation must also invalidate alias to global if global227;; itself is assigned (reported by Sven Hartrumpf)228229(define gp-test-global 0)230231(define (gp-test)232 (let ((a gp-test-global)233 (b gp-test-global))234 (set! gp-test-global 1)235 (assert (zero? a))236 (assert (zero? b))))237238(gp-test)239240;; Optimizer would "lift" inner-bar out of its let and replace241;; outer-bar with it, even though it wasn't visible yet. Caused by242;; broken cps-conversion (underlying problem for #1068).243(assert (equal? 1 (let ((outer-bar (##core#undefined)))244 (let ((inner-bar (let ((tmp (lambda (x)245 (if x '1 (outer-bar '#t)))))246 tmp)))247 (set! outer-bar inner-bar)248 (outer-bar #f)))))249250;; Slightly modified version which broke after fixing the above due251;; to replacement optimization getting triggered. This replacement252;; caused outer-bar to get replaced by inner-bar, even within itself,253;; thereby causing an undefined variable reference.254(assert (equal? 1 (let ((outer-bar (##core#undefined)))255 (let ((inner-bar (lambda (x)256 (if x '1 (outer-bar outer-bar)))))257 (set! outer-bar inner-bar)258 (outer-bar '#f)))))259260;; Found by Claude Marinier: Huge literals with a length which need261;; more than 3 bytes to encode would get silently truncated. We'll262;; prevent constant-folding if it would lead to such large literals.263(let* ((bignum (expt 2 70000000))264 ;; This prevents complete evaluation at compile-time265 (unknown-bignum ((foreign-lambda* scheme-object266 ((scheme-object n)) "C_return(n);") bignum)))267 (assert (equal? 70000001 (integer-length unknown-bignum))))268269270;; Test that encode-literal/decode-literal use the proper functions271;; to decode number literals.272(assert (equal? '(+inf.0 -inf.0) (list (fp/ 1.0 0.0) (fp/ -1.0 0.0))))273274;; Test that encode-literal doesn't drop digits for extreme flonum values.275276;; This number is 2^971 * (2^53 - 1), and is the positive "all ones" number for277;; 64-bit flonums with precision 53 and significand/mantissa 10.278;; If we want to support 32-bit flonums or flonums with different precision279;; or significand, we need a cond-expand here or something.280;; Technically, even larger decimal numbers can be represented by flonums.281;; This number can correctly be compared exactly.282(assert (= (* (- (expt 2 flonum-precision) 1)283 (expt 2 (- flonum-maximum-exponent flonum-precision)))284 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0285 (string->number "179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.0")))286287;; #955: unsigned-integer64 arg returned magnitude instead of Scheme object.288(assert (eqv? #xAB54A98CEB1F0AD2289 ((foreign-lambda* unsigned-integer64 ((unsigned-integer64 x))290 "C_return(x);")291 #xAB54A98CEB1F0AD2)))292293294;; Test the maximum and minimum values of the FFI's integer types295(define-syntax test-ffi-type-limits296 (syntax-rules (signed unsigned)297 ((_ ?type-name unsigned ?bits)298 (let ((limit (arithmetic-shift 1 ?bits)))299 (print "Testing unsigned FFI type \"" '?type-name "\" (" ?bits " bits):")300 (print "Can hold maximum value " (sub1 limit) "...")301 (assert302 (eqv? (sub1 limit)303 ((foreign-lambda* ?type-name ((?type-name x))304 "C_return(x);") (sub1 limit))))305 (print "Cannot hold one more than maximum value, " limit "...")306 (assert307 (handle-exceptions exn #t308 (begin ((foreign-lambda* ?type-name ((?type-name x))309 "C_return(x);") limit)310 #f)))311 (print "Cannot hold -1 (any fixnum negative value)")312 (assert313 (handle-exceptions exn #t314 (begin ((foreign-lambda* ?type-name ((?type-name x))315 "C_return(x);") -1)316 #f)))317 (print "Cannot hold -2^64 (any bignum negative value < smallest int64)")318 (assert319 (handle-exceptions exn #t320 (begin ((foreign-lambda* ?type-name ((?type-name x))321 "C_return(x);") #x-10000000000000000)322 #f)))))323 ((_ ?type-name signed ?bits)324 (let ((limit (arithmetic-shift 1 (sub1 ?bits))))325 (print "Testing signed FFI type \"" '?type-name "\" (" ?bits " bits):")326 (print "Can hold maximum value " (sub1 limit) "...")327 (assert328 (eqv? (sub1 limit)329 ((foreign-lambda* ?type-name ((?type-name x))330 "C_return(x);") (sub1 limit))))331 (print "Can hold minimum value " (- limit) "...")332 (assert333 (eqv? (- limit)334 ((foreign-lambda* ?type-name ((?type-name x))335 "C_return(x);") (- limit))))336 (print "Cannot hold one more than maximum value " limit "...")337 (assert338 (handle-exceptions exn #t339 (begin ((foreign-lambda* ?type-name ((?type-name x))340 "C_return(x);") limit)341 #f)))342 (print "Cannot hold one less than minimum value " (- limit) "...")343 (assert344 (handle-exceptions exn #t345 (begin ((foreign-lambda* ?type-name ((?type-name x))346 "C_return(x);") (sub1 (- limit)))347 #f)))))))348349(test-ffi-type-limits unsigned-integer32 unsigned 32)350(test-ffi-type-limits integer32 signed 32)351352(test-ffi-type-limits unsigned-integer64 unsigned 64)353(test-ffi-type-limits integer64 signed 64)354355(test-ffi-type-limits356 unsigned-integer unsigned357 (foreign-value "sizeof(unsigned int) * CHAR_BIT" int))358359(test-ffi-type-limits360 integer signed (foreign-value "sizeof(int) * CHAR_BIT" int))361362(test-ffi-type-limits363 (enum intlimits) signed364 (foreign-value "sizeof(enum intlimits) * CHAR_BIT" int))365366(test-ffi-type-limits367 unsigned-long unsigned368 (foreign-value "sizeof(unsigned long) * CHAR_BIT" int))369370(test-ffi-type-limits371 long signed (foreign-value "sizeof(long) * CHAR_BIT" int))372373(test-ffi-type-limits374 ssize_t signed (foreign-value "sizeof(ssize_t) * CHAR_BIT" int))375376(test-ffi-type-limits377 size_t unsigned (foreign-value "sizeof(size_t) * CHAR_BIT" int))378379380;; #1059: foreign vector types use wrong lolevel accessors, causing381;; paranoid DEBUGBUILD assertions to fail.382(define-syntax srfi-4-vector-length383 (er-macro-transformer384 (lambda (e r c)385 (let* ((type (symbol->string (strip-syntax (cadr e))))386 (base-type (string-translate* type '(("nonnull-" . ""))))387 (length-procedure-name (string-append base-type "-length")))388 `(,(string->symbol length-procedure-name) ,(caddr e))))))389390(define-syntax s4v-sum391 (syntax-rules ()392 ((_ "integer" type arg)393 ((foreign-lambda* int ((type v) (int len))394 "int i, result = 0;"395 "for (i = 0; i < len; ++i) {"396 " result += (int)v[i];"397 "}"398 "C_return(result);") arg (srfi-4-vector-length type arg)))399 ((_ "float" type arg)400 ((foreign-lambda* double ((type v) (int len))401 "int i; double result = 0.0;"402 "for (i = 0; i < len; ++i) {"403 " result += v[i];"404 "}"405 "C_return(result);") arg (srfi-4-vector-length type arg)))))406(assert (= 10 (s4v-sum "integer" u8vector '#u8(1 2 3 4))))407(assert (= 10 (s4v-sum "integer" u16vector '#u16(1 2 3 4))))408(assert (= 10 (s4v-sum "integer" u32vector '#u32(1 2 3 4))))409(assert (= 10 (s4v-sum "integer" s64vector '#s64(1 2 3 4))))410(assert (= 10 (s4v-sum "integer" nonnull-u8vector '#u8(1 2 3 4))))411(assert (= 10 (s4v-sum "integer" nonnull-u16vector '#u16(1 2 3 4))))412(assert (= 10 (s4v-sum "integer" nonnull-u32vector '#u32(1 2 3 4))))413(assert (= 10 (s4v-sum "integer" nonnull-u64vector '#u64(1 2 3 4))))414(assert (= -10 (s4v-sum "integer" s8vector '#s8(-1 -2 -3 -4))))415(assert (= -10 (s4v-sum "integer" s16vector '#s16(-1 -2 -3 -4))))416(assert (= -10 (s4v-sum "integer" s32vector '#s32(-1 -2 -3 -4))))417(assert (= -10 (s4v-sum "integer" s64vector '#s64(-1 -2 -3 -4))))418(assert (= -10 (s4v-sum "integer" nonnull-s8vector '#s8(-1 -2 -3 -4))))419(assert (= -10 (s4v-sum "integer" nonnull-s16vector '#s16(-1 -2 -3 -4))))420(assert (= -10 (s4v-sum "integer" nonnull-s32vector '#s32(-1 -2 -3 -4))))421(assert (= -10 (s4v-sum "integer" nonnull-s64vector '#s64(-1 -2 -3 -4))))422(assert (= 12.0 (s4v-sum "float" f32vector '#f32(1.5 2.5 3.5 4.5))))423(assert (= 12.0 (s4v-sum "float" f64vector '#f64(1.5 2.5 3.5 4.5))))424(assert (= 12.0 (s4v-sum "float" nonnull-f32vector '#f32(1.5 2.5 3.5 4.5))))425(assert (= 12.0 (s4v-sum "float" nonnull-f64vector '#f64(1.5 2.5 3.5 4.5))))426427428;; Reported by Jörg Wittenberger: in some cases, -profile would429;; generate calls to procedures. This was due to calls to pure430;; procedures not getting replaced with explicitly consed rest431;; list when the procedures themselves were hidden.432(module explicitly-consed-rest-args-bug (do-it also-do-it)433 (import scheme chicken.base chicken.type)434435 (: get-value (* * #!rest * --> *))436 (define (get-value x y . rest)437 (apply x y rest))438 (define (do-it arg)439 (get-value arg 2))440 (define (also-do-it arg)441 (get-value arg 3))442)443444; let-location with const-wrapped type445(let-location ((foo (const c-string) "boo"))446 (assert (equal? foo "boo")))447448; #1424: a foreign lambda with const return type was wrongly rejected449(let ((v0 ((foreign-lambda* c-string () "C_return(\"str\");")))450 (v1 ((foreign-lambda* (const c-string) () "C_return(\"str\");"))))451 (assert (equal? v0 v1)))452453; #1630: inlining may result in incorrectly flagged argument-454; count errors.455(define (outer x y)456 (define (append-map proc . lsts)457 (if (null? lsts)458 (proc 1)459 (apply proc lsts)))460 (append-map (lambda (a) (assert (= a 1))))461 (append-map (lambda (a b) (assert (and (= a 3) (= b 4))))462 x y))463(outer 3 4)464465; #1703: argvector re-use interfered with rest-arg optimization466(define reduce (lambda (_l ini) (+ ini 1)))467468(print ((lambda xs (reduce xs (car xs))) 1 2 3)) ;; prints 2469470(define fold- (lambda xs (reduce xs (car xs))))471(print (fold- 1 2 3))472473; libraries are only loaded when entry point is called474(let ()475 (if #f (require-library (chicken repl)))476 (assert (not (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl)))477 (if #t (require-library (chicken repl)))478 (assert (##sys#symbol-has-toplevel-binding? 'chicken.repl#repl)))