1;;; foreign.ms 2;;; Copyright 1984-2017 Cisco Systems, Inc. 3;;; 4;;; Licensed under the Apache License, Version 2.0 (the "License"); 5;;; you may not use this file except in compliance with the License. 6;;; You may obtain a copy of the License at 7;;; 8;;; http://www.apache.org/licenses/LICENSE-2.0 9;;; 10;;; Unless required by applicable law or agreed to in writing, software 11;;; distributed under the License is distributed on an "AS IS" BASIS, 12;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 13;;; See the License for the specific language governing permissions and 14;;; limitations under the License. 15 16(define-syntax machine-case 17 (lambda (x) 18 (syntax-case x () 19 [(_ [(a ...) e ...] m ...) 20 (if (memq (machine-type) (datum (a ...))) 21 #'(begin (void) e ...) 22 #'(machine-case m ...))] 23 [(_ [else e ...]) #'(begin (void) e ...)] 24 [(_) #'(void)]))) 25 26(machine-case 27 [(pb)] 28 [else 29 30#;(define-syntax foreign-struct-mat 31 (syntax-rules () 32 [(_ name n) 33 (mat name 34 (set! fs-size 35 ((foreign-procedure (format "s~a_size" n) () unsigned-32))) 36 (set! fs-align 37 ((foreign-procedure (format "s~a_align" n) () unsigned-32))) 38 (set! fs-get-s 39 (eval `(foreign-procedure ,(format "get_s~a" n) (char) 40 (foreign-object ,fs-size ,fs-align)))) 41 (set! fs-get-sp 42 (foreign-procedure (format "get_s~ap" n) (char) 43 foreign-pointer)) 44 (set! fs-s_f1_s 45 (eval `(foreign-procedure ,(format "s~a_f1_s~a" n n) 46 ((foreign-object ,fs-size ,fs-align) 47 (foreign-object ,fs-size ,fs-align)) 48 (foreign-object ,fs-size ,fs-align)))) 49 (set! fs-sp_f1_s 50 (eval `(foreign-procedure ,(format "s~ap_f1_s~a" n n) 51 (foreign-pointer 52 (foreign-object ,fs-size ,fs-align)) 53 (foreign-object ,fs-size ,fs-align)))) 54 (set! fs-s_f1_sp 55 (eval `(foreign-procedure ,(format "s~a_f1_s~ap" n n) 56 ((foreign-object ,fs-size ,fs-align) 57 foreign-pointer) 58 (foreign-object ,fs-size ,fs-align)))) 59 (set! fs-sp_f1_sp 60 (eval `(foreign-procedure ,(format "s~ap_f1_s~ap" n n) 61 (foreign-pointer 62 foreign-pointer) 63 (foreign-object ,fs-size ,fs-align)))) 64 (set! fs-s_f2_s 65 (eval `(foreign-procedure ,(format "s~a_f2_s~a" n n) 66 (integer-32 67 (foreign-object ,fs-size ,fs-align) 68 (foreign-object ,fs-size ,fs-align)) 69 (foreign-object ,fs-size ,fs-align)))) 70 (set! fs-sp_f2_s 71 (eval `(foreign-procedure ,(format "s~ap_f2_s~a" n n) 72 (integer-32 73 foreign-pointer 74 (foreign-object ,fs-size ,fs-align)) 75 (foreign-object ,fs-size ,fs-align)))) 76 (set! fs-s_f2_sp 77 (eval `(foreign-procedure ,(format "s~a_f2_s~ap" n n) 78 (integer-32 79 (foreign-object ,fs-size ,fs-align) 80 foreign-pointer) 81 (foreign-object ,fs-size ,fs-align)))) 82 (set! fs-sp_f2_sp 83 (eval `(foreign-procedure ,(format "s~ap_f2_s~ap" n n) 84 (integer-32 85 foreign-pointer 86 foreign-pointer) 87 (foreign-object ,fs-size ,fs-align)))) 88 (set! fs-s_f3_s 89 (eval `(foreign-procedure ,(format "s~a_f3_s~a" n n) 90 ((foreign-object ,fs-size ,fs-align) 91 (foreign-object ,fs-size ,fs-align)) 92 boolean))) 93 (set! fs-sp_f3_s 94 (eval `(foreign-procedure ,(format "s~ap_f3_s~a" n n) 95 (foreign-pointer 96 (foreign-object ,fs-size ,fs-align)) 97 boolean))) 98 (set! fs-s_f3_sp 99 (eval `(foreign-procedure ,(format "s~a_f3_s~ap" n n) 100 ((foreign-object ,fs-size ,fs-align) 101 foreign-pointer) 102 boolean))) 103 (set! fs-sp_f3_sp 104 (eval `(foreign-procedure ,(format "s~ap_f3_s~ap" n n) 105 (foreign-pointer 106 foreign-pointer) 107 boolean))) 108 109 (set! fs-a (fs-get-s #\a)) 110 (string? fs-a) 111 (set! fs-ap (fs-get-sp #\a)) 112 (integer? fs-ap) 113 (set! fs-b (fs-get-s #\b)) 114 (string? fs-b) 115 (set! fs-bp (fs-get-sp #\b)) 116 (integer? fs-bp) 117 118 119 (fs-s_f3_s fs-a fs-a) 120 (fs-s_f3_s fs-a fs-ap) 121 (fs-s_f3_s fs-ap fs-a) 122 (fs-s_f3_s fs-ap fs-ap) 123 (fs-sp_f3_s fs-a fs-a) 124 (fs-sp_f3_s fs-a fs-ap) 125 (fs-sp_f3_s fs-ap fs-a) 126 (fs-sp_f3_s fs-ap fs-ap) 127 (fs-s_f3_sp fs-a fs-a) 128 (fs-s_f3_sp fs-a fs-ap) 129 (fs-s_f3_sp fs-ap fs-a) 130 (fs-s_f3_sp fs-ap fs-ap) 131 (fs-sp_f3_sp fs-a fs-a) 132 (fs-sp_f3_sp fs-a fs-ap) 133 (fs-sp_f3_sp fs-ap fs-a) 134 (fs-sp_f3_sp fs-ap fs-ap) 135 136 (not (fs-s_f3_s fs-a fs-b)) 137 (not (fs-s_f3_s fs-a fs-bp)) 138 (not (fs-s_f3_s fs-ap fs-b)) 139 (not (fs-s_f3_s fs-ap fs-bp)) 140 (not (fs-sp_f3_s fs-a fs-b)) 141 (not (fs-sp_f3_s fs-a fs-bp)) 142 (not (fs-sp_f3_s fs-ap fs-b)) 143 (not (fs-sp_f3_s fs-ap fs-bp)) 144 (not (fs-s_f3_sp fs-a fs-b)) 145 (not (fs-s_f3_sp fs-a fs-bp)) 146 (not (fs-s_f3_sp fs-ap fs-b)) 147 (not (fs-s_f3_sp fs-ap fs-bp)) 148 (not (fs-sp_f3_sp fs-a fs-b)) 149 (not (fs-sp_f3_sp fs-a fs-bp)) 150 (not (fs-sp_f3_sp fs-ap fs-b)) 151 (not (fs-sp_f3_sp fs-ap fs-bp)) 152 153 (fs-sp_f3_sp (fs-s_f1_s fs-ap fs-bp) (fs-sp_f1_s fs-a fs-bp)) 154 (fs-sp_f3_sp (fs-s_f1_sp fs-ap fs-b) (fs-sp_f1_sp fs-a fs-b)) 155 156 (fs-sp_f3_sp (fs-s_f2_s 1 fs-ap fs-bp) (fs-sp_f2_s 1 fs-a fs-bp)) 157 (fs-sp_f3_sp (fs-s_f2_sp 1 fs-ap fs-b) (fs-sp_f2_sp 1 fs-a fs-b)) 158 )])) 159 160(define-syntax auto-mat-ick 161 (lambda (x) 162 (syntax-case x () 163 ((_ name) 164 (let ((ls (let f ([ls (string->list (datum name))]) 165 (if (null? ls) 166 '() 167 (cons (car ls) (f (cddr ls))))))) 168 (with-syntax ([((p v) ...) 169 (map (lambda (c) 170 (case (syntax->datum c) 171 [(#\n) `(,(syntax integer-32) 172 ,(random 1000))] 173 [(#\s) `(,(syntax single-float) 174 ,(truncate (random 1000.0)))] 175 [(#\d) `(,(syntax double-float) 176 ,(truncate (random 1000.0)))])) 177 ls)]) 178 (syntax (= (let ([x (foreign-procedure name (p ...) double-float)]) 179 (x v ...)) 180 (+ v ...))))))))) 181 182(define foreign1.so (format "~a/foreign1.so" *mats-dir*)) 183 184(machine-case 185 [(i3ob ti3ob a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx) 186 (mat load-shared-object 187 (file-exists? foreign1.so) 188 (begin (load-shared-object foreign1.so) #t) 189 (begin (load-shared-object "libc.so") #t) 190 (error? (load-shared-object 3)) 191 ) 192 ] 193 [(i3le ti3le a6le ta6le arm32le tarm32le arm64le tarm64le ppc32le tppc32le) 194 (mat load-shared-object 195 (file-exists? foreign1.so) 196 (begin (load-shared-object foreign1.so) #t) 197 (begin (load-shared-object "libc.so.6") #t) 198 (error? (load-shared-object 3)) 199 ) 200 ] 201 [(i3fb ti3fb a6fb ta6fb) 202 (mat load-shared-object 203 (file-exists? foreign1.so) 204 (begin (load-shared-object foreign1.so) #t) 205 (begin (load-shared-object "libc.so.7") #t) 206 (error? (load-shared-object 3)) 207 ) 208 ] 209 [(i3nb ti3nb a6nb ta6nb) 210 (mat load-shared-object 211 (file-exists? foreign1.so) 212 (begin (load-shared-object foreign1.so) #t) 213 (begin (load-shared-object "libc.so") #t) 214 (error? (load-shared-object 3)) 215 ) 216 ] 217 [(i3nt ti3nt a6nt ta6nt) 218 (mat load-shared-object 219 (file-exists? foreign1.so) 220 (begin (load-shared-object foreign1.so) #t) 221 (begin (load-shared-object "msvcrt.dll") #t) 222 (begin (load-shared-object "kernel32.dll") #t) 223 (error? (load-shared-object 3)) 224 ) 225 ] 226 [(i3osx ti3osx a6osx ta6osx ppc32osx tppc32osx arm64osx tarm64osx) 227 (mat load-shared-object 228 (file-exists? foreign1.so) 229 (begin (load-shared-object foreign1.so) #t) 230 (begin (load-shared-object "libc.dylib") #t) 231 #t 232 (error? (load-shared-object 3)) 233 ) 234 ] 235 [else 236 (mat foreign-procedure 237 (error? (foreign-procedure "foo" () scheme-object)) 238 (begin (define (idint32 x) 239 (errorf 'idint32 "invalid foreign-procedure argument ~s" x)) 240 (procedure? idint32)) 241 (error? (idint32 #x80000000)) 242 (error? (idint32 #x80000001)) 243 (error? (idint32 #xffffffff)) 244 (error? (idint32 #x8000000080000000)) 245 (error? (idint32 #x-80000001)) 246 (error? (idint32 #x-8000000080000000)) 247 (error? (idint32 #f)) 248 (error? (idint32 "hi")) 249 (begin (define (iduns32 x) 250 (errorf 'iduns32 "invalid foreign-procedure argument ~s" x)) 251 (procedure? iduns32)) 252 (error? (iduns32 #x100000000)) 253 (error? (iduns32 #x8000000080000000)) 254 (error? (iduns32 -1)) 255 (error? (iduns32 #x-7fffffff)) 256 (error? (iduns32 #x-80000000)) 257 (error? (iduns32 #x-80000001)) 258 (error? (iduns32 #x-8000000080000000)) 259 (error? (iduns32 #f)) 260 (error? (iduns32 "hi")) 261 (begin (define (idfix x) 262 (errorf 'idfix "invalid foreign-procedure argument ~s" x)) 263 (procedure? idfix)) 264 (error? (idfix (+ (most-positive-fixnum) 1))) 265 (error? (idfix (- (most-negative-fixnum) 1))) 266 (error? (errorf 'id "return value ~s is out of range" #x7fffffff)) 267 (error? (errorf 'id "return value ~s is out of range" #x-80000000)) 268 (error? (errorf 'id "invalid foreign-procedure argument ~s" 0)) 269 (error? (errorf 'id "return value ~s is out of range" #x7fffffff)) 270 (error? (errorf 'id "invalid foreign-procedure argument ~s" 'foo)) 271 (error? (foreign-procedure 'abcde (integer-32) integer-32)) 272 (error? (errorf 'float_id "invalid foreign-procedure argument ~s" 0)) 273 ) 274 ]) 275 276(mat foreign-entry? 277 (foreign-entry? "id") 278 (foreign-entry? "idid") 279 (foreign-entry? "ididid") 280 (not (foreign-entry? "foo"))) 281 282(mat foreign-procedure 283 (procedure? (foreign-procedure "idiptr" (scheme-object) scheme-object)) 284 (error? (foreign-procedure "i do not exist" (scheme-object) scheme-object)) 285 (error? (begin (foreign-procedure "i do not exist" () scheme-object) 'q)) 286 (error? (if (foreign-procedure "i do not exist" () scheme-object) 'q 'q)) 287 (error? (foreign-procedure 'foo () scheme-object)) 288 (error? (begin (foreign-procedure 'foo () scheme-object) 'q)) 289 (error? (if (foreign-procedure 'foo () scheme-object) 'q 'q)) 290 291 (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) scheme-object) 'foo)) 292 293 (parameterize ([current-eval interpret]) 294 (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) scheme-object) 'foo))) 295 296 (not (eq? 'foo ((foreign-procedure "idiptr" (scheme-object) void) 'foo))) 297 298 (begin (define idint32 (foreign-procedure "id" (integer-32) integer-32)) 299 (procedure? idint32)) 300 (eqv? (idint32 0) 0) 301 (eqv? (idint32 #x7fffffff) #x7fffffff) 302 (eqv? (idint32 -1) -1) 303 (eqv? (idint32 #x-7fffffff) #x-7fffffff) 304 (eqv? (idint32 #x-80000000) #x-80000000) 305 (eqv? (idint32 #x80000000) (+ #x-100000000 #x80000000)) 306 (eqv? (idint32 #x80000001) (+ #x-100000000 #x80000001)) 307 (eqv? (idint32 #xffffffff) (+ #x-100000000 #xffffffff)) 308 (error? (idint32 #x100000000)) 309 (error? (idint32 #x100000001)) 310 (error? (idint32 #xfffffffffffffffffffffffffffff)) 311 (error? (idint32 #x8000000080000000)) 312 (error? (idint32 #x-80000001)) 313 (error? (idint32 #x-8000000080000000)) 314 (error? (idint32 #f)) 315 (error? (idint32 "hi")) 316 317 (begin (define iduns32 (foreign-procedure "id" (unsigned-32) unsigned-32)) 318 (procedure? iduns32)) 319 (eqv? (iduns32 0) 0) 320 (eqv? (iduns32 #x7fffffff) #x7fffffff) 321 (eqv? (iduns32 #x80000000) #x80000000) 322 (eqv? (iduns32 #x80000001) #x80000001) 323 (eqv? (iduns32 #x88000000) #x88000000) 324 (eqv? (iduns32 #xffffffff) #xffffffff) 325 (error? (iduns32 #x100000000)) 326 (error? (iduns32 #x8000000080000000)) 327 (eqv? (iduns32 -1) (+ #x100000000 -1)) 328 (eqv? (iduns32 #x-7fffffff) (+ #x100000000 #x-7fffffff)) 329 (eqv? (iduns32 #x-80000000) (+ #x100000000 #x-80000000)) 330 (error? (iduns32 #x-80000001)) 331 (error? (iduns32 #x-ffffffff)) 332 (error? (iduns32 #x-fffffffffffffffffffffffffffffffff)) 333 (error? (iduns32 #x-80000001)) 334 (error? (iduns32 #x-8000000080000000)) 335 (error? (iduns32 #f)) 336 (error? (iduns32 "hi")) 337 338 (eqv? #xffffffff ((foreign-procedure "id" (integer-32) unsigned-32) -1)) 339 (eqv? -1 ((foreign-procedure "id" (unsigned-32) integer-32) #xffffffff)) 340 341 (begin (define idfix (foreign-procedure "idiptr" (fixnum) fixnum)) 342 (procedure? idfix)) 343 (eqv? 0 (idfix 0)) 344 (eqv? -1 (idfix -1)) 345 (eqv? (quotient (most-positive-fixnum) 2) 346 (idfix (quotient (most-positive-fixnum) 2))) 347 (eqv? (quotient (most-negative-fixnum) 2) 348 (idfix (quotient (most-negative-fixnum) 2))) 349 (eqv? (most-positive-fixnum) (idfix (most-positive-fixnum))) 350 (eqv? (most-negative-fixnum) (idfix (most-negative-fixnum))) 351 (error? (idfix (+ (most-positive-fixnum) 1))) 352 (error? (idfix (- (most-negative-fixnum) 1))) 353 354; we've eliminated the return range checks---caveat emptor 355; (error? ((foreign-procedure "id" (integer-32) fixnum) #x7fffffff)) 356; (error? ((foreign-procedure "id" (integer-32) fixnum) #x-80000000)) 357; (error? ((foreign-procedure "id" (integer-32) char) #x7fffffff)) 358 359 (error? (foreign-procedure "id" (booleen) char)) 360 (error? (foreign-procedure "id" (integer-32 integer-34) char)) 361 (error? (foreign-procedure "id" () chare)) 362 (error? (foreign-procedure "id" (void) char)) 363 364 ((foreign-procedure "id" (boolean) boolean) #t) 365 (not ((foreign-procedure "id" (boolean) boolean) #f)) 366 ((foreign-procedure "id" (boolean) boolean) 0) 367 (= 1 ((foreign-procedure "id" (boolean) integer-32) #t)) 368 (= 1 ((foreign-procedure "id" (boolean) integer-32) 0)) 369 (= 0 ((foreign-procedure "id" (boolean) integer-32) #f)) 370 (not ((foreign-procedure "id" (integer-32) boolean) 0)) 371 ((foreign-procedure "id" (integer-32) boolean) 1) 372 373 (char=? #\a ((foreign-procedure "id" (char) char) #\a)) 374 (= 0 ((foreign-procedure "id" (char) integer-32) #\nul)) 375 (char=? #\nul ((foreign-procedure "id" (integer-32) char) 0)) 376 (eqv? ((foreign-procedure "id" (integer-32) char) -1) #\377) 377 (error? ((foreign-procedure "id" (char) void) 0)) 378 379 (let ([s "now is the time for all good men"]) 380 (string=? s ((foreign-procedure "idiptr" (string) string) s))) 381 (let ([s "now is the time for all good men"]) 382 (not (eq? s ((foreign-procedure "idiptr" (string) string) s)))) 383 ; assuming iptr is same size as char *: 384 (let ([id1 (foreign-procedure "idiptr" (string) string)] 385 [id2 (foreign-procedure "idiptr" (string) iptr)] 386 [id3 (foreign-procedure "idiptr" (iptr) string)]) 387 (and (eq? (id1 #f) #f) (eq? (id2 #f) 0) (eq? (id3 0) #f))) 388 (let () 389 (define $string->bytevector 390 (lambda (s) 391 (let ([n (string-length s)]) 392 (let ([bv (make-bytevector (+ n 1))]) 393 (do ([i 0 (fx+ i 1)]) 394 ((fx= i n)) 395 (bytevector-u8-set! bv i (char->integer (string-ref s i)))) 396 (bytevector-u8-set! bv n 0) 397 bv)))) 398 (let ([s "now is the time for all good men"] 399 [r " "]) 400 (let ([bv ($string->bytevector r)]) 401 ((foreign-procedure (if (windows?) "windows_strcpy" "strcpy") (u8* string) void) bv s) 402 (= 0 ((foreign-procedure (if (windows?) "windows_strcmp" "strcmp") (u8* string) integer-32) bv s))))) 403 (error? ((foreign-procedure "id" (string) void) 'foo)) 404 405 (= ((foreign-procedure "idid" (integer-32) integer-32) #xc7c7c7) #xc7c7c7) 406 (= ((foreign-procedure "ididid" (integer-32) integer-32) #x7c7c7c7c) 407 #x7c7c7c7c) 408 409 (= ((foreign-procedure "id" (unsigned-32) unsigned-32) #x80000000) 410 #x80000000) 411 (= ((foreign-procedure "id" (unsigned-32) integer-32) #x80000000) 412 #x-80000000) 413 414 (error? (foreign-procedure 'abcde (integer-32) integer-32)) 415 (let ([template 416 (lambda (x) 417 (foreign-procedure x (char) boolean))]) 418 (let ([id (template "id")] 419 [idid (template "idid")] 420 [ididid (template "ididid")]) 421 (and (eqv? (id #\nul) #f) 422 (eqv? (idid #\001) #t) 423 (eqv? (idid #\a) #t)))) 424 425 (= 0.0 ((foreign-procedure "float_id" (double-float) double-float) 0.0)) 426 (= 1.1 ((foreign-procedure "float_id" (double-float) double-float) 1.1)) 427 (error? ((foreign-procedure "float_id" (double-float) void) 0)) 428 429 (let ([fid (foreign-procedure "float_id" (double-float) double-float)]) 430 (let f ((n 10000)) 431 (or (= n 0) 432 (let ([x (random 1.0)]) 433 (and (eqv? x (fid x)) 434 (f (- n 1))))))) 435 436 (= (+ (* 1 29) (* 2 31) (* 3 37) (* 5 41) (* 7 43) 437 (* 11 47) (* 13 49) (* 17 53) (* 19 59) (* 23 61)) 438 ((foreign-procedure "testten" 439 (integer-32 integer-32 integer-32 integer-32 integer-32 440 integer-32 integer-32 integer-32 integer-32 integer-32) 441 integer-32) 442 29 31 37 41 43 47 49 53 59 61)) 443 444 (= (+ 1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8) 445 ((foreign-procedure "flsum8" 446 (double-float double-float double-float double-float 447 double-float double-float double-float double-float) 448 double-float) 449 1.1 2.2 3.3 4.4 5.5 6.6 7.7 8.8)) 450 451 (= (+ 1 2 3 4 5 6.75 7 8.5) 452 ((foreign-procedure "sparcfltest" 453 (integer-32 integer-32 integer-32 integer-32 454 integer-32 double-float integer-32 double-float) 455 double-float) 456 1 2 3 4 5 6.75 7 8.5)) 457 458 (= (+ 1 2 3.3) 459 ((foreign-procedure "mipsfltest1" 460 (integer-32 integer-32 double-float) 461 double-float) 462 1 2 3.3)) 463 464 (= (+ 1 2.2 3.3) 465 ((foreign-procedure "mipsfltest2" 466 (integer-32 double-float double-float) 467 double-float) 468 1 2.2 3.3)) 469 470 (= (+ 1 2.25 3 4.5 5 6.75 7 8.25 9.5 10.75 11.25 12.5 13.75 14.25 15.5 471 16.75 17.25 18.75 19.25) 472 ((foreign-procedure "ppcfltest" 473 (integer-32 double-float integer-32 double-float integer-32 474 double-float integer-32 double-float double-float double-float 475 double-float double-float double-float double-float double-float 476 double-float double-float double-float double-float) 477 double-float) 478 1 2.25 3 4.5 5 6.75 7 8.25 9.5 10.75 11.25 12.5 13.75 14.25 15.5 479 16.75 17.25 18.75 19.25)) 480 481 (= (+ 1 2.25 3 4.5 5 482 (expt 2 36) 6.75 7 8.25 483 (expt 2 39) 75 484 9.5 10.75 11.25 12.5 485 13.75 14.25 15.5 486 20 16.75 21 (expt 2 37) 18.75 22 487 19.25) 488 ((foreign-procedure "ppcfltest2" 489 (integer-32 double-float integer-32 double-float integer-32 490 integer-64 double-float integer-32 double-float 491 ; next integer should be stack-allocated with the PPC ABI 492 integer-64 integer-32 493 ; but next four floats should still get registers 494 double-float double-float double-float double-float 495 ; and remaining floags and ints should go on the stack 496 double-float single-float double-float 497 integer-32 double-float integer-32 integer-64 double-float integer-32 498 double-float) 499 double-float) 500 1 2.25 3 4.5 5 501 (expt 2 36) 6.75 7 8.25 502 (expt 2 39) 75 503 9.5 10.75 11.25 12.5 504 13.75 14.25 15.5 505 20 16.75 21 (expt 2 37) 18.75 22 506 19.25)) 507 508 ((foreign-procedure "chk_data" () boolean)) 509 ((foreign-procedure "chk_bss" () boolean)) 510 ((foreign-procedure "chk_malloc" () boolean)) 511 512 (begin 513 (define $fp-tlv (foreign-procedure "(cs)s_tlv" (ptr) ptr)) 514 (define $fp-stlv! (foreign-procedure "(cs)s_stlv" (ptr ptr) void)) 515 #t) 516 517 (equal? 518 (let () 519 (define-syntax list-in-order 520 (syntax-rules () 521 [(_) '()] 522 [(_ e . rest) (let ([t e]) (cons t (list-in-order . rest)))])) 523 (list-in-order 524 ($fp-tlv 'cons) 525 ($fp-stlv! '$fp-spam 'yum) 526 ($fp-tlv '$fp-spam) 527 (top-level-value '$fp-spam))) 528 `(,cons ,(void) yum yum)) 529 530 (equal? 531 (let () 532 (define-syntax list-in-order 533 (syntax-rules () 534 [(_) '()] 535 [(_ e . rest) (let ([t e]) (cons t (list-in-order . rest)))])) 536 (parameterize ([interaction-environment (copy-environment (scheme-environment))]) 537 (list-in-order 538 (define-top-level-value 'foo 17) 539 ($fp-tlv 'foo) 540 ($fp-stlv! 'bar 55) 541 ($fp-tlv 'bar) 542 (top-level-value 'bar)))) 543 `(,(void) 17 ,(void) 55 55)) 544 545 (equal? 546 (parameterize ([interaction-environment (copy-environment (scheme-environment))]) 547 ; should have no effect 548 ($fp-stlv! cons 3) 549 (list 550 (#%$tc-field 'disable-count (#%$tc)) 551 cons 552 ($fp-tlv 'cons))) 553 `(0 ,cons ,cons)) 554 555 (equal? 556 (parameterize ([interaction-environment (copy-environment (scheme-environment))]) 557 ; should have no effect 558 ($fp-stlv! 'let 3) 559 (list 560 (#%$tc-field 'disable-count (#%$tc)) 561 (eval '(let ((x 23)) x)))) 562 '(0 23)) 563 564 (equal? 565 (let ([x ($fp-tlv '$fp-i-am-not-bound)]) 566 (list (#%$tc-field 'disable-count (#%$tc)) x)) 567 `(0 ,(#%$unbound-object))) 568 569 (equal? 570 (let ([x ($fp-tlv 'let)]) 571 (list (#%$tc-field 'disable-count (#%$tc)) x)) 572 `(0 ,(#%$unbound-object))) 573 574 (equal? ((foreign-procedure "(cs)s_test_schlib" () void)) (void)) 575 576 (begin 577 (define $siv (foreign-procedure "(cs)Sinteger_value" (ptr) void)) 578 (define $si32v (foreign-procedure "(cs)Sinteger32_value" (ptr) void)) 579 (define $si64v (foreign-procedure "(cs)Sinteger64_value" (ptr) void)) 580 (define ($check p n) 581 (or (= (optimize-level) 3) 582 (guard (c [(and (assertion-violation? c) 583 (irritants-condition? c) 584 (equal? (condition-irritants c) (list n))) 585 #t]) 586 (p n) 587 #f))) 588 #t) 589 590 ; make sure no errors for in-range inputs 591 (begin 592 ($si32v (- (expt 2 32) 1)) 593 ($si32v (- (expt 2 31))) 594 ($si64v (- (expt 2 64) 1)) 595 ($si64v (- (expt 2 63))) 596 (if (< (fixnum-width) 32) 597 (begin ; assume 32-bit words 598 ($siv (- (expt 2 32) 1)) 599 ($siv (- (expt 2 31)))) 600 (begin ; assume 64-bit words 601 ($siv (- (expt 2 64) 1)) 602 ($siv (- (expt 2 63))))) 603 #t) 604 605 ; check barely out-of-range inputs 606 ($check $si32v (expt 2 32)) 607 ($check $si32v (- -1 (expt 2 31))) 608 ($check $si64v (expt 2 64)) 609 ($check $si64v (- -1 (expt 2 63))) 610 ($check $siv (expt 2 (if (< (fixnum-width) 32) 32 64))) 611 ($check $siv (- -1 (expt 2 (if (< (fixnum-width) 32) 31 63)))) 612 613 ; check further out-of-range inputs 614 ($check $si32v (expt 2 36)) 615 ($check $si32v (- -1 (expt 2 35))) 616 ($check $si64v (expt 2 68)) 617 ($check $si64v (- -1 (expt 2 67))) 618 ($check $siv (expt 2 (if (< (fixnum-width) 32) 36 68))) 619 ($check $siv (- -1 (expt 2 (if (< (fixnum-width) 32) 35 67)))) 620 ($check $si32v (expt 2 100)) 621 ($check $si32v (- -1 (expt 2 100))) 622 ($check $si64v (expt 2 100)) 623 ($check $si64v (- -1 (expt 2 100))) 624 ($check $siv (expt 2 100)) 625 ($check $siv (- -1 (expt 2 100))) 626) 627 628(mat foreign-sizeof 629 (equal? 630 (list 631 (foreign-sizeof 'integer-8) 632 (foreign-sizeof 'unsigned-8) 633 (foreign-sizeof 'integer-16) 634 (foreign-sizeof 'unsigned-16) 635 (foreign-sizeof 'integer-24) 636 (foreign-sizeof 'unsigned-24) 637 (foreign-sizeof 'integer-32) 638 (foreign-sizeof 'unsigned-32) 639 (foreign-sizeof 'integer-40) 640 (foreign-sizeof 'unsigned-40) 641 (foreign-sizeof 'integer-48) 642 (foreign-sizeof 'unsigned-48) 643 (foreign-sizeof 'integer-56) 644 (foreign-sizeof 'unsigned-56) 645 (foreign-sizeof 'integer-64) 646 (foreign-sizeof 'unsigned-64) 647 (foreign-sizeof 'single-float) 648 (foreign-sizeof 'double-float)) 649 '(1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 4 8)) 650 ((foreign-procedure "check_types" (int int int int int int int int int) boolean) 651 (foreign-sizeof 'char) 652 (foreign-sizeof 'wchar) 653 (foreign-sizeof 'short) 654 (foreign-sizeof 'int) 655 (foreign-sizeof 'long) 656 (foreign-sizeof 'long-long) 657 (foreign-sizeof 'float) 658 (foreign-sizeof 'double) 659 (foreign-sizeof 'void*)) 660 (equal? (foreign-sizeof 'unsigned) (foreign-sizeof 'int)) 661 (equal? (foreign-sizeof 'unsigned-int) (foreign-sizeof 'int)) 662 (equal? (foreign-sizeof 'unsigned-short) (foreign-sizeof 'short)) 663 (equal? (foreign-sizeof 'unsigned-long) (foreign-sizeof 'long)) 664 (equal? (foreign-sizeof 'unsigned-long-long) (foreign-sizeof 'long-long)) 665 (equal? (foreign-sizeof 'boolean) (foreign-sizeof 'int)) 666 (equal? (foreign-sizeof 'fixnum) (foreign-sizeof 'iptr)) 667 (equal? (foreign-sizeof 'scheme-object) (foreign-sizeof 'void*)) 668 (equal? (foreign-sizeof 'ptr) (foreign-sizeof 'void*)) 669 (equal? (foreign-sizeof 'iptr) (foreign-sizeof 'void*)) 670 (equal? (foreign-sizeof 'uptr) (foreign-sizeof 'void*)) 671 (error? (foreign-sizeof)) 672 (error? (foreign-sizeof 'int 'int)) 673 (error? (foreign-sizeof 'i-am-not-a-type)) 674 (error? (foreign-sizeof '1)) 675) 676 677(mat foreign-bytevectors 678 ; test u8*, u16*, u32* 679 (begin 680 (define u8*->u8* (foreign-procedure "u8_star_to_u8_star" (u8*) u8*)) 681 (define u16*->u16* (foreign-procedure "u16_star_to_u16_star" (u16*) u16*)) 682 (define u32*->u32* (foreign-procedure "u32_star_to_u32_star" (u32*) u32*)) 683 #t) 684 (equal? (u8*->u8* #vu8(1 2 3 4 0)) #vu8(2 3 4)) 685 (equal? (u16*->u16* #vu8(1 2 3 4 5 6 7 8 0 0)) #vu8(3 4 5 6 7 8)) 686 (equal? (u32*->u32* #vu8(1 2 3 4 5 6 7 8 9 10 11 12 0 0 0 0)) #vu8(5 6 7 8 9 10 11 12)) 687 688 (eq? (u8*->u8* #vu8(1 0)) #vu8()) 689 (eq? (u16*->u16* #vu8(1 2 0 0)) #vu8()) 690 (eq? (u32*->u32* #vu8(1 2 3 4 0 0 0 0)) #vu8()) 691 692 (eq? (u8*->u8* #f) #f) 693 (eq? (u16*->u16* #f) #f) 694 (eq? (u32*->u32* #f) #f) 695 696 (error? (u8*->u8* "hello")) 697 (error? (u16*->u16* "hello")) 698 (error? (u32*->u32* "hello")) 699 (error? (u8*->u8* 0)) 700 (error? (u16*->u16* 0)) 701 (error? (u32*->u32* 0)) 702 703 (begin 704 (define call-u8* (foreign-procedure "call_u8_star" (ptr u8*) u8*)) 705 (define call-u16* (foreign-procedure "call_u16_star" (ptr u16*) u16*)) 706 (define call-u32* (foreign-procedure "call_u32_star" (ptr u32*) u32*)) 707 (define $bytevector-map 708 (lambda (p bv) 709 (u8-list->bytevector (map p (bytevector->u8-list bv))))) 710 #t) 711 (equal? 712 (call-u8* (foreign-callable 713 (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x)) 714 (u8*) u8*) 715 #vu8(1 2 3 4 5 255 0 )) 716 '#vu8(103 104 105)) 717 (equal? 718 (call-u16* (foreign-callable 719 (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x)) 720 (u16*) u16*) 721 #vu8(1 2 3 4 5 6 255 255 0 0)) 722 '#vu8(105 106)) 723 (equal? 724 (call-u32* (foreign-callable 725 (lambda (x) ($bytevector-map (lambda (x) (if (= x 255) 0 (+ x 100))) x)) 726 (u32*) u32*) 727 #vu8(1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 255 255 255 255 0 0 0 0)) 728 '#vu8(109 110 111 112 113 114 115 116 117 118 119 120)) 729 (error? 730 (let ([frotz (foreign-callable 731 (lambda (x) (list x (bytevector-length x))) 732 (u8*) u8*)]) 733 (call-u8* frotz #vu8(1 2 3 4 5 0)))) 734 (error? 735 (call-u16* (foreign-callable 736 (lambda (x) (list x (bytevector-length x))) 737 (u16*) u16*) 738 #vu8(1 2 3 4 5 6 0 0))) 739 (error? 740 (call-u32* (foreign-callable 741 (lambda (x) (list x (bytevector-length x))) 742 (u32*) u32*) 743 #vu8(1 2 3 4 5 6 7 8 0 0 0 0))) 744 (error? 745 (call-u8* (foreign-callable 746 (lambda (x) (list x (bytevector-length x))) 747 (u8*) u8*) 748 '#(1 2 3 4 5 0))) 749 (error? 750 (call-u16* (foreign-callable 751 (lambda (x) (list x (bytevector-length x))) 752 (u16*) u16*) 753 '#(1 2 3 4 5 6 0 0))) 754 (error? 755 (call-u32* (foreign-callable 756 (lambda (x) (list x (bytevector-length x))) 757 (u32*) u32*) 758 '#(1 2 3 4 5 6 7 8 0 0 0 0))) 759) 760 761(mat foreign-strings 762 ; test utf-8, utf-16le, utf-16be, utf-32le, utf-32be, string, wstring 763 (begin 764 (define utf-8->utf-8 (foreign-procedure "u8_star_to_u8_star" (utf-8) utf-8)) 765 (define utf-16le->utf-16le (foreign-procedure "u16_star_to_u16_star" (utf-16le) utf-16le)) 766 (define utf-16be->utf-16be (foreign-procedure "u16_star_to_u16_star" (utf-16be) utf-16be)) 767 (define utf-32le->utf-32le (foreign-procedure "u32_star_to_u32_star" (utf-32le) utf-32le)) 768 (define utf-32be->utf-32be (foreign-procedure "u32_star_to_u32_star" (utf-32be) utf-32be)) 769 (define string->string (foreign-procedure "char_star_to_char_star" (string) string)) 770 (define wstring->wstring (foreign-procedure "wchar_star_to_wchar_star" (wstring) wstring)) 771 #t) 772 (equal? (utf-8->utf-8 "hello") "ello") 773 (equal? (utf-16le->utf-16le "hello") "ello") 774 (equal? (utf-16be->utf-16be "hello") "ello") 775 (equal? (utf-32le->utf-32le "hello") "ello") 776 (equal? (utf-32be->utf-32be "hello") "ello") 777 (equal? (string->string "hello") "ello") 778 (equal? (wstring->wstring "hello") "ello") 779 780 (eq? (utf-8->utf-8 "h") "") 781 (eq? (utf-16le->utf-16le "h") "") 782 (eq? (utf-16be->utf-16be "h") "") 783 (eq? (utf-32le->utf-32le "h") "") 784 (eq? (utf-32be->utf-32be "h") "") 785 (eq? (string->string "h") "") 786 (eq? (wstring->wstring "h") "") 787 788 (eq? (utf-8->utf-8 #f) #f) 789 (eq? (utf-16le->utf-16le #f) #f) 790 (eq? (utf-16be->utf-16be #f) #f) 791 (eq? (utf-32le->utf-32le #f) #f) 792 (eq? (utf-32be->utf-32be #f) #f) 793 (eq? (string->string #f) #f) 794 (eq? (wstring->wstring #f) #f) 795 796 (error? (utf-8->utf-8 #vu8(1 2 3 4 0 0 0 0))) 797 (error? (utf-16le->utf-16le #vu8(1 2 3 4 0 0 0 0))) 798 (error? (utf-16be->utf-16be #vu8(1 2 3 4 0 0 0 0))) 799 (error? (utf-32le->utf-32le #vu8(1 2 3 4 0 0 0 0))) 800 (error? (utf-32be->utf-32be #vu8(1 2 3 4 0 0 0 0))) 801 (error? (string->string #vu8(1 2 3 4 0 0 0 0))) 802 (error? (wstring->wstring #vu8(1 2 3 4 0 0 0 0))) 803 804 (error? (utf-8->utf-8 0)) 805 (error? (utf-16le->utf-16le 0)) 806 (error? (utf-16be->utf-16be 0)) 807 (error? (utf-32le->utf-32le 0)) 808 (error? (utf-32be->utf-32be 0)) 809 (error? (string->string 0)) 810 (error? (wstring->wstring 0)) 811 812 (begin 813 (define call-utf-8 (foreign-procedure "call_u8_star" (ptr utf-8) utf-8)) 814 (define call-utf-16le (foreign-procedure "call_u16_star" (ptr utf-16le) utf-16le)) 815 (define call-utf-16be (foreign-procedure "call_u16_star" (ptr utf-16be) utf-16be)) 816 (define call-utf-32le (foreign-procedure "call_u32_star" (ptr utf-32le) utf-32le)) 817 (define call-utf-32be (foreign-procedure "call_u32_star" (ptr utf-32be) utf-32be)) 818 (define call-string (foreign-procedure "call_string" (ptr string) string)) 819 (define call-wstring (foreign-procedure "call_wstring" (ptr wstring) wstring)) 820 #t) 821 (equal? 822 (call-utf-8 (foreign-callable 823 (lambda (x) (string-append x "$q")) 824 (utf-8) utf-8) 825 "hello") 826 "llo$q") 827 (equal? 828 (call-utf-16le (foreign-callable 829 (lambda (x) (string-append x "$q")) 830 (utf-16le) utf-16le) 831 "hello") 832 "llo$q") 833 (equal? 834 (call-utf-16be (foreign-callable 835 (lambda (x) (string-append x "$q")) 836 (utf-16be) utf-16be) 837 "hello") 838 "llo$q") 839 (equal? 840 (call-utf-32le (foreign-callable 841 (lambda (x) (string-append x "$q")) 842 (utf-32le) utf-32le) 843 "hello") 844 "llo$q") 845 (equal? 846 (call-utf-32be (foreign-callable 847 (lambda (x) (string-append x "$q")) 848 (utf-32be) utf-32be) 849 "hello") 850 "llo$q") 851 (equal? 852 (call-string (foreign-callable 853 (lambda (x) (string-append x "$q")) 854 (string) string) 855 "hello") 856 "llo$q") 857 (equal? 858 (call-wstring (foreign-callable 859 (lambda (x) (string-append x "$q")) 860 (wstring) wstring) 861 "hello") 862 "llo$q") 863 (error? 864 (call-utf-8 (foreign-callable 865 (lambda (x) (list x (string-length x))) 866 (utf-8) utf-8) 867 "hello")) 868 (error? 869 (call-utf-16le (foreign-callable 870 (lambda (x) (list x (string-length x))) 871 (utf-16le) utf-16le) 872 "hello")) 873 (error? 874 (call-utf-16be (foreign-callable 875 (lambda (x) (list x (string-length x))) 876 (utf-16be) utf-16be) 877 "hello")) 878 (error? 879 (call-utf-32le (foreign-callable 880 (lambda (x) (list x (string-length x))) 881 (utf-32le) utf-32le) 882 "hello")) 883 (error? 884 (call-utf-32be (foreign-callable 885 (lambda (x) (list x (string-length x))) 886 (utf-32be) utf-32be) 887 "hello")) 888 (error? 889 (call-string (foreign-callable 890 (lambda (x) (list x (string-length x))) 891 (string) string) 892 "hello")) 893 (error? 894 (call-wstring (foreign-callable 895 (lambda (x) (list x (string-length x))) 896 (wstring) wstring) 897 "hello")) 898) 899 900(mat foreign-fixed-types 901 ; test {integer,unsigned}-8, {single,double}-float 902 (begin 903 (define i8-to-i8 (foreign-procedure "i8_to_i8" (integer-8 int) integer-8)) 904 (define u8-to-u8 (foreign-procedure "u8_to_u8" (unsigned-8 int) unsigned-8)) 905 (define i16-to-i16 (foreign-procedure "i16_to_i16" (integer-16 int) integer-16)) 906 (define u16-to-u16 (foreign-procedure "u16_to_u16" (unsigned-16 int) unsigned-16)) 907 (define i24-to-i24 (foreign-procedure "i32_to_i32" (integer-24 int) integer-24)) 908 (define u24-to-u24 (foreign-procedure "u32_to_u32" (unsigned-24 int) unsigned-24)) 909 (define i32-to-i32 (foreign-procedure "i32_to_i32" (integer-32 int) integer-32)) 910 (define u32-to-u32 (foreign-procedure "u32_to_u32" (unsigned-32 int) unsigned-32)) 911 (define i40-to-i40 (foreign-procedure "i64_to_i64" (integer-40 int) integer-40)) 912 (define u40-to-u40 (foreign-procedure "u64_to_u64" (unsigned-40 int) unsigned-40)) 913 (define i48-to-i48 (foreign-procedure "i64_to_i64" (integer-48 int) integer-48)) 914 (define u48-to-u48 (foreign-procedure "u64_to_u64" (unsigned-48 int) unsigned-48)) 915 (define i56-to-i56 (foreign-procedure "i64_to_i64" (integer-56 int) integer-56)) 916 (define u56-to-u56 (foreign-procedure "u64_to_u64" (unsigned-56 int) unsigned-56)) 917 (define i64-to-i64 (foreign-procedure "i64_to_i64" (integer-64 int) integer-64)) 918 (define u64-to-u64 (foreign-procedure "u64_to_u64" (unsigned-64 int) unsigned-64)) 919 (define sf-to-sf (foreign-procedure "sf_to_sf" (single-float) single-float)) 920 (define df-to-df (foreign-procedure "df_to_df" (double-float) double-float)) 921 (define $test-int-to-int 922 (lambda (fp size signed?) 923 (define n10000 (expt 256 size)) 924 (define nffff (- n10000 1)) 925 (define nfffe (- nffff 1)) 926 (define n8000 (ash n10000 -1)) 927 (define n8001 (+ n8000 1)) 928 (define n7fff (- n8000 1)) 929 (define n7ffe (- n7fff 1)) 930 (define n100 (expt 16 size)) 931 (define n101 (+ n100 1)) 932 (define nff (- n100 1)) 933 (define nfe (- nff 1)) 934 (define n80 (ash n100 -1)) 935 (define n81 (+ n80 1)) 936 (define n7f (- n80 1)) 937 (define n7e (- n7f 1)) 938 (define (expect x k) 939 (if signed? 940 (if (<= (- n8000) x nffff) 941 (mod0 (+ x k) n10000) 942 'err) 943 (if (<= (- n8000) x nffff) 944 (mod (+ x k) n10000) 945 'err))) 946 (define (check x) 947 (define (do-one x k) 948 (let ([a (expect x k)]) 949 (if (eq? a 'err) 950 (or (= (optimize-level) 3) 951 (guard (c [#t (display-condition c) (newline) #t]) 952 (fp x k) 953 (printf "no error for x = ~x, k = ~d\n" x k) 954 #f)) 955 (or (eqv? (fp x k) a) 956 (begin 957 (printf "incorrect answer ~x should be ~x for x = ~x, k = ~d\n" (fp x k) a x k) 958 #f))))) 959 (list 960 (do-one x 1) 961 (do-one x -1) 962 (do-one (- x) 1) 963 (do-one (- x) -1))) 964 (andmap 965 (lambda (x) (and (list? x) (= (length x) 4) (andmap (lambda (x) (eq? x #t)) x))) 966 (list 967 (check n10000) 968 (check nffff) 969 (check nfffe) 970 (check n8001) 971 (check n8000) 972 (check n7fff) 973 (check n7ffe) 974 (check n101) 975 (check n100) 976 (check nff) 977 (check nfe) 978 (check n81) 979 (check n80) 980 (check n7f) 981 (check n7e) 982 (check 73) 983 (check 5) 984 (check 1) 985 (check 0))))) 986 #t) 987 ($test-int-to-int i8-to-i8 1 #t) 988 ($test-int-to-int u8-to-u8 1 #f) 989 ($test-int-to-int i16-to-i16 2 #t) 990 ($test-int-to-int u16-to-u16 2 #f) 991 ($test-int-to-int i24-to-i24 3 #t) 992 ($test-int-to-int u24-to-u24 3 #f) 993 ($test-int-to-int i32-to-i32 4 #t) 994 ($test-int-to-int u32-to-u32 4 #f) 995 ($test-int-to-int i40-to-i40 5 #t) 996 ($test-int-to-int u40-to-u40 5 #f) 997 ($test-int-to-int i48-to-i48 6 #t) 998 ($test-int-to-int u48-to-u48 6 #f) 999 ($test-int-to-int i56-to-i56 7 #t) 1000 ($test-int-to-int u56-to-u56 7 #f) 1001 ($test-int-to-int i64-to-i64 8 #t) 1002 ($test-int-to-int u64-to-u64 8 #f) 1003 (eqv? (sf-to-sf 73.5) 74.5) 1004 (eqv? (df-to-df 73.5) 74.5) 1005 1006 (error? (i8-to-i8 'qqq 0)) 1007 (error? (u8-to-u8 'qqq 0)) 1008 (error? (i16-to-i16 'qqq 0)) 1009 (error? (u16-to-u16 'qqq 0)) 1010 (error? (i24-to-i24 'qqq 0)) 1011 (error? (u24-to-u24 'qqq 0)) 1012 (error? (i32-to-i32 'qqq 0)) 1013 (error? (u32-to-u32 'qqq 0)) 1014 (error? (i64-to-i64 'qqq 0)) 1015 (error? (u64-to-u64 'qqq 0)) 1016 (error? (i8-to-i8 0 "oops")) 1017 (error? (u8-to-u8 0 "oops")) 1018 (error? (i16-to-i16 0 "oops")) 1019 (error? (u16-to-u16 0 "oops")) 1020 (error? (i32-to-i32 0 "oops")) 1021 (error? (u32-to-u32 0 "oops")) 1022 (error? (i64-to-i64 0 "oops")) 1023 (error? (u64-to-u64 0 "oops")) 1024 1025 (error? (sf-to-sf 'qqq)) 1026 (error? (df-to-df 'qqq)) 1027 1028 (begin 1029 (define call-i8 (foreign-procedure "call_i8" (ptr integer-8 int int) integer-8)) 1030 (define call-u8 (foreign-procedure "call_u8" (ptr unsigned-8 int int) unsigned-8)) 1031 (define call-i16 (foreign-procedure "call_i16" (ptr integer-16 int int) integer-16)) 1032 (define call-u16 (foreign-procedure "call_u16" (ptr unsigned-16 int int) unsigned-16)) 1033 (define call-i24 (foreign-procedure "call_i32" (ptr integer-24 int int) integer-24)) 1034 (define call-u24 (foreign-procedure "call_u32" (ptr unsigned-24 int int) unsigned-24)) 1035 (define call-i32 (foreign-procedure "call_i32" (ptr integer-32 int int) integer-32)) 1036 (define call-u32 (foreign-procedure "call_u32" (ptr unsigned-32 int int) unsigned-32)) 1037 (define call-i40 (foreign-procedure "call_i64" (ptr integer-40 int int) integer-40)) 1038 (define call-u40 (foreign-procedure "call_u64" (ptr unsigned-40 int int) unsigned-40)) 1039 (define call-i48 (foreign-procedure "call_i64" (ptr integer-48 int int) integer-48)) 1040 (define call-u48 (foreign-procedure "call_u64" (ptr unsigned-48 int int) unsigned-48)) 1041 (define call-i56 (foreign-procedure "call_i64" (ptr integer-56 int int) integer-56)) 1042 (define call-u56 (foreign-procedure "call_u64" (ptr unsigned-56 int int) unsigned-56)) 1043 (define call-i64 (foreign-procedure "call_i64" (ptr integer-64 int int) integer-64)) 1044 (define call-u64 (foreign-procedure "call_u64" (ptr unsigned-64 int int) unsigned-64)) 1045 (define call-sf (foreign-procedure "call_sf" (ptr single-float int int) single-float)) 1046 (define call-df (foreign-procedure "call_df" (ptr double-float int int) double-float)) 1047 (define call-varargs-df (foreign-procedure "call_varargs_df" (ptr double-float int int) double-float)) 1048 (define call-varargs-i7df (foreign-procedure "call_varargs_i7df" (ptr int 1049 double-float double-float double-float 1050 double-float double-float double-float 1051 double-float) 1052 double-float)) 1053 (define call-varargs-dfii (foreign-procedure "call_varargs_dfii" (ptr double-float int int) double-float)) 1054 (define call-varargs-dfidf (foreign-procedure "call_varargs_dfidf" (ptr double-float int double-float) double-float)) 1055 (define call-varargs-dfsfi (foreign-procedure "call_varargs_dfsfi" (ptr double-float single-float int) double-float)) 1056 (define ($test-call-int signed? size call-int make-fc) 1057 (define n10000 (expt 256 size)) 1058 (define nffff (- n10000 1)) 1059 (define nfffe (- nffff 1)) 1060 (define n8000 (ash n10000 -1)) 1061 (define n8001 (+ n8000 1)) 1062 (define n7fff (- n8000 1)) 1063 (define n7ffe (- n7fff 1)) 1064 (define n100 (expt 16 size)) 1065 (define n101 (+ n100 1)) 1066 (define nff (- n100 1)) 1067 (define nfe (- nff 1)) 1068 (define n80 (ash n100 -1)) 1069 (define n81 (+ n80 1)) 1070 (define n7f (- n80 1)) 1071 (define n7e (- n7f 1)) 1072 (define (expect x m k) 1073 (if signed? 1074 (if (<= (- n8000) x nffff) 1075 (mod0 (+ x m k) n10000) 1076 'err) 1077 (if (<= (- n8000) x nffff) 1078 (mod (+ x m k) n10000) 1079 'err))) 1080 (define fc (make-fc values)) 1081 (define fp (lambda (x m k) (call-int fc x m k))) 1082 (define (check x) 1083 (define (do-one x m k) 1084 (let ([a (expect x m k)]) 1085 (if (eq? a 'err) 1086 (or (= (optimize-level) 3) 1087 (guard (c [#t (display-condition c) (newline) #t]) (fp x m k))) 1088 (eqv? (fp x m k) a)))) 1089 (list 1090 (do-one x 0 0) 1091 (do-one x 5 7) 1092 (do-one x -5 7) 1093 (do-one x 5 -7) 1094 (do-one x -5 -7) 1095 (do-one (- x) 0 0) 1096 (do-one (- x) 5 7) 1097 (do-one (- x) -5 7) 1098 (do-one (- x) 5 -7) 1099 (do-one (- x) -5 -7))) 1100 (andmap 1101 (lambda (x) (and (list? x) (= (length x) 10) (andmap (lambda (x) (eq? x #t)) x))) 1102 (list 1103 (check n10000) 1104 (check nffff) 1105 (check nfffe) 1106 (check n8001) 1107 (check n8000) 1108 (check n7fff) 1109 (check n7ffe) 1110 (check n101) 1111 (check n100) 1112 (check nff) 1113 (check nfe) 1114 (check n81) 1115 (check n80) 1116 (check n7f) 1117 (check n7e) 1118 (check 73) 1119 (check 5) 1120 (check 1) 1121 (check 0)))) 1122 #t) 1123 ($test-call-int #t (foreign-sizeof 'integer-8) call-i8 1124 (lambda (p) (foreign-callable p (integer-8) integer-8))) 1125 ($test-call-int #t (foreign-sizeof 'integer-16) call-i16 1126 (lambda (p) (foreign-callable p (integer-16) integer-16))) 1127 ($test-call-int #t (foreign-sizeof 'integer-24) call-i24 1128 (lambda (p) (foreign-callable p (integer-24) integer-24))) 1129 ($test-call-int #t (foreign-sizeof 'integer-32) call-i32 1130 (lambda (p) (foreign-callable p (integer-32) integer-32))) 1131 ($test-call-int #t (foreign-sizeof 'integer-40) call-i40 1132 (lambda (p) (foreign-callable p (integer-40) integer-40))) 1133 ($test-call-int #t (foreign-sizeof 'integer-48) call-i48 1134 (lambda (p) (foreign-callable p (integer-48) integer-48))) 1135 ($test-call-int #t (foreign-sizeof 'integer-56) call-i56 1136 (lambda (p) (foreign-callable p (integer-56) integer-56))) 1137 ($test-call-int #t (foreign-sizeof 'integer-64) call-i64 1138 (lambda (p) (foreign-callable p (integer-64) integer-64))) 1139 ($test-call-int #f (foreign-sizeof 'unsigned-8) call-u8 1140 (lambda (p) (foreign-callable p (unsigned-8) unsigned-8))) 1141 ($test-call-int #f (foreign-sizeof 'unsigned-16) call-u16 1142 (lambda (p) (foreign-callable p (unsigned-16) unsigned-16))) 1143 ($test-call-int #f (foreign-sizeof 'unsigned-24) call-u24 1144 (lambda (p) (foreign-callable p (unsigned-24) unsigned-24))) 1145 ($test-call-int #f (foreign-sizeof 'unsigned-32) call-u32 1146 (lambda (p) (foreign-callable p (unsigned-32) unsigned-32))) 1147 ($test-call-int #f (foreign-sizeof 'unsigned-40) call-u40 1148 (lambda (p) (foreign-callable p (unsigned-40) unsigned-40))) 1149 ($test-call-int #f (foreign-sizeof 'unsigned-48) call-u48 1150 (lambda (p) (foreign-callable p (unsigned-48) unsigned-48))) 1151 ($test-call-int #f (foreign-sizeof 'unsigned-56) call-u56 1152 (lambda (p) (foreign-callable p (unsigned-56) unsigned-56))) 1153 ($test-call-int #f (foreign-sizeof 'unsigned-64) call-u64 1154 (lambda (p) (foreign-callable p (unsigned-64) unsigned-64))) 1155 (equal? 1156 (call-sf 1157 (foreign-callable 1158 (lambda (x) (+ x 5)) 1159 (single-float) single-float) 1160 73.25 7 23) 1161 108.25) 1162 (equal? 1163 (call-df 1164 (foreign-callable 1165 (lambda (x) (+ x 5)) 1166 (double-float) double-float) 1167 73.25 7 23) 1168 108.25) 1169 (equal? 1170 (call-varargs-df 1171 (foreign-callable 1172 __varargs 1173 (lambda (x y) (+ x y 5)) 1174 (double-float double-float) double-float) 1175 10.25 20 300) 1176 325.5) 1177 (equal? 1178 (call-varargs-i7df 1179 (foreign-callable 1180 __varargs 1181 (lambda (i a b c d e f g) (+ i a b c d e f g 7)) 1182 (int double-float double-float double-float double-float double-float double-float double-float) double-float) 1183 1 2.2 3.2 4.5 6.7 8.9 10.1 11.5) 1184 55.1) 1185 1186 (equal? 1187 (call-varargs-dfii 1188 (foreign-callable 1189 (__varargs_after 2) 1190 (lambda (x y z) (+ x y z)) 1191 (double-float int int) double-float) 1192 10.25 20 300) 1193 620.25) 1194 1195 (equal? 1196 (call-varargs-dfidf 1197 (foreign-callable 1198 (__varargs_after 2) 1199 (lambda (x y z) (+ x y z)) 1200 (double-float int double-float) double-float) 1201 10.25 20 300.25) 1202 330.75) 1203 1204 (equal? 1205 (call-varargs-dfsfi 1206 (foreign-callable 1207 (__varargs_after 2) 1208 (lambda (x y z) (+ x y z)) 1209 (double-float single-float int) double-float) 1210 10.25 20.0 300) 1211 620.5) 1212 1213 ;(define call-varargs-dfsfi (foreign-procedure #;__varargs #;2 "call_varargs_dfsfi" (ptr double-float single-float int) double-float)) 1214 1215 (error? 1216 (call-i8 1217 (foreign-callable 1218 (lambda (x) '(- x 7)) 1219 (integer-8) integer-8) 1220 73 0 0)) 1221 (error? 1222 (call-u8 1223 (foreign-callable 1224 (lambda (x) '(- x 7)) 1225 (unsigned-8) unsigned-8) 1226 73 0 0)) 1227 (error? 1228 (call-i16 1229 (foreign-callable 1230 (lambda (x) '(- x 7)) 1231 (integer-16) integer-16) 1232 73 0 0)) 1233 (error? 1234 (call-u16 1235 (foreign-callable 1236 (lambda (x) '(- x 7)) 1237 (unsigned-16) unsigned-16) 1238 73 0 0)) 1239 (error? 1240 (call-i32 1241 (foreign-callable 1242 (lambda (x) '(- x 7)) 1243 (integer-32) integer-32) 1244 73 0 0)) 1245 (error? 1246 (call-u32 1247 (foreign-callable 1248 (lambda (x) '(- x 7)) 1249 (unsigned-32) unsigned-32) 1250 73 0 0)) 1251 (error? 1252 (call-i64 1253 (foreign-callable 1254 (lambda (x) '(- x 7)) 1255 (integer-64) integer-64) 1256 73 0 0)) 1257 (error? 1258 (call-u64 1259 (foreign-callable 1260 (lambda (x) '(- x 7)) 1261 (unsigned-64) unsigned-64) 1262 73 0 0)) 1263 (error? 1264 (call-sf 1265 (foreign-callable 1266 (lambda (x) '(- x 7)) 1267 (single-float) single-float) 1268 73.25 0 0)) 1269 (error? 1270 (call-df 1271 (foreign-callable 1272 (lambda (x) '(- x 7)) 1273 (double-float) double-float) 1274 73.25 0 0)) 1275 (error? 1276 (call-varargs-df 1277 (foreign-callable 1278 __varargs 1279 (lambda (x y) '(- x 7)) 1280 (double-float double-float) double-float) 1281 73.25 0 0)) 1282 1283 (begin 1284 (define u32xu32->u64 1285 (foreign-procedure "u32xu32_to_u64" (unsigned-32 unsigned-32) 1286 unsigned-64)) 1287 (define i32xu32->i64 1288 (foreign-procedure "i32xu32_to_i64" (integer-32 unsigned-32) 1289 integer-64)) 1290 (define call-i32xu32->i64 1291 (foreign-procedure "call_i32xu32_to_i64" 1292 (ptr integer-32 unsigned-32 int) 1293 integer-64)) 1294 (define fc-i32xu32->i64 1295 (foreign-callable i32xu32->i64 1296 (integer-32 unsigned-32) 1297 integer-64)) 1298 #t) 1299 1300 (eqv? (u32xu32->u64 #xFFFFFFFF #xFFFFFFFF) #xFFFFFFFFFFFFFFFF) 1301 (eqv? (u32xu32->u64 #xFF3FFFFF #xFFFFF0FF) #xFF3FFFFFFFFFF0FF) 1302 (eqv? (u32xu32->u64 #xFFFFFFFF #xF0000000) #xFFFFFFFFF0000000) 1303 1304 (eqv? (i32xu32->i64 #x0 #x5) #x5) 1305 (eqv? (i32xu32->i64 #x7 #x5) #x700000005) 1306 (eqv? (i32xu32->i64 #xFFFFFFFF #xFFFFFFFF) #x-1) 1307 (eqv? (fixnum? (i32xu32->i64 #xFFFFFFFF #xFFFFFFFF)) #t) 1308 (eqv? (i32xu32->i64 #xFFFFFFFF #xFFFFFFFE) #x-2) 1309 (eqv? (i32xu32->i64 #xFFFFFFFF #x00000000) #x-100000000) 1310 (eqv? (i32xu32->i64 #xFFFFFFFE #x00000000) #x-200000000) 1311 (eqv? (i32xu32->i64 #xFFFFFFFF #x00000001) #x-FFFFFFFF) 1312 (eqv? (i32xu32->i64 #x0 #xFFFFFFFF) #xFFFFFFFF) 1313 (eqv? (i32xu32->i64 #x7FFFFFFF #xFFFFFFFF) #x7FFFFFFFFFFFFFFF) 1314 (eqv? (i32xu32->i64 #x80000000 #x00000000) #x-8000000000000000) 1315 1316 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x0 #x5 #x13) #x18) 1317 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x7 #x5 7) #x70000000C) 1318 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #xFFFFFFFF -3) #x-4) 1319 (eqv? (fixnum? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #xFFFFFFFF 0)) #t) 1320 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #xFFFFFFFE -1) #x-3) 1321 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #x00000000 0) #x-100000000) 1322 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFE #x00000000 0) #x-200000000) 1323 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #xFFFFFFFF #x00000001 0) #x-FFFFFFFF) 1324 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x0 #xFFFFFFFF 0) #xFFFFFFFF) 1325 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x7FFFFFFF #xFFFFFFFF 0) #x7FFFFFFFFFFFFFFF) 1326 (eqv? (call-i32xu32->i64 fc-i32xu32->i64 #x80000000 #x00000000 0) #x-8000000000000000) 1327 1328 ; check for 64-bit alignment issues 1329 (begin 1330 (define ufoo64a 1331 (foreign-procedure "ufoo64a" (unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64) 1332 unsigned-64)) 1333 (define ufoo64b 1334 (foreign-procedure "ufoo64b" (integer-32 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64 unsigned-64) 1335 unsigned-64)) 1336 (define test-ufoo 1337 (lambda (foo x a b c d e f g) 1338 (eqv? (foo x a b c d e f g) 1339 (mod (+ x (- a b) (- c d) (- e f) g) (expt 2 64))))) 1340 #t) 1341 (test-ufoo (lambda (x a b c d e f g) (+ x (ufoo64a a b c d e f g))) 1342 #x0000000010000000 1343 #x0000000120000000 1344 #x0000002003000000 1345 #x0000030000400000 1346 #x0000400000050000 1347 #x0005000000006000 1348 #x0060000000000700 1349 #x0700000000000080) 1350 (test-ufoo ufoo64b 1351 #x0000000010000000 1352 #x0000000120000000 1353 #x0000002003000000 1354 #x0000030000400000 1355 #x0000400000050000 1356 #x0005000000006000 1357 #x0060000000000700 1358 #x0700000000000080) 1359 (test-ufoo (lambda (x a b c d e f g) (+ x (ufoo64a a b c d e f g))) 1360 #x0000000010000000 1361 #x0000000120000000 1362 #x0000002003000000 1363 #x0000030000400000 1364 #x0000400000050000 1365 #x0005000000006000 1366 #x0060000000000700 1367 #xC700000000000080) 1368 (test-ufoo ufoo64b 1369 #x0000000010000000 1370 #x0000000120000000 1371 #x0000002003000000 1372 #x0000030000400000 1373 #x0000400000050000 1374 #x0005000000006000 1375 #x0060000000000700 1376 #xC700000000000080) 1377 (do ([i 1000 (fx- i 1)]) 1378 ((fx= i 0) #t) 1379 (let ([ls (cons (random (expt 2 32)) 1380 (map random (make-list 7 (expt 2 64))))]) 1381 (unless (apply test-ufoo 1382 (lambda (x a b c d e f g) 1383 (+ x (ufoo64a a b c d e f g))) 1384 ls) 1385 (pretty-print ls) 1386 (errorf #f "failed for ufoo64a on ~s" ls)) 1387 (unless (apply test-ufoo ufoo64b ls) 1388 (pretty-print ls) 1389 (errorf #f "failed for ufoo64b on ~s" ls)))) 1390 (begin 1391 (define ifoo64a 1392 (foreign-procedure "ifoo64a" (integer-64 integer-64 integer-64 integer-64 integer-64 integer-64 integer-64) 1393 integer-64)) 1394 (define ifoo64b 1395 (foreign-procedure "ifoo64b" (integer-32 integer-64 integer-64 integer-64 integer-64 integer-64 integer-64 integer-64) 1396 integer-64)) 1397 (define test-ifoo 1398 (lambda (foo x a b c d e f g) 1399 (eqv? (foo x a b c d e f g) 1400 (mod0 (+ x (- a b) (- c d) (- e f) g) (expt 2 64))))) 1401 #t) 1402 (test-ifoo (lambda (x a b c d e f g) (+ x (ifoo64a a b c d e f g))) 1403 #x0000000010000000 1404 #x0000000120000000 1405 #x0000002003000000 1406 #x0000030000400000 1407 #x0000400000050000 1408 #x0005000000006000 1409 #x0060000000000700 1410 #x0700000000000080) 1411 (test-ifoo ifoo64b 1412 #x0000000010000000 1413 #x0000000120000000 1414 #x0000002003000000 1415 #x0000030000400000 1416 #x0000400000050000 1417 #x0005000000006000 1418 #x0060000000000700 1419 #x0700000000000080) 1420 (test-ifoo (lambda (x a b c d e f g) (+ x (ifoo64a a b c d e f g))) 1421 #x0000000010000000 1422 #x0000000120000000 1423 #x0000002003000000 1424 #x0000030000400000 1425 #x0000400000050000 1426 #x0005000000006000 1427 #x0060000000000700 1428 #xC700000000000080) 1429 (test-ifoo ifoo64b 1430 #x0000000010000000 1431 #x0000000120000000 1432 #x0000002003000000 1433 #x0000030000400000 1434 #x0000400000050000 1435 #x0005000000006000 1436 #x0060000000000700 1437 #xC700000000000080) 1438 (do ([i 1000 (fx- i 1)]) 1439 ((fx= i 0) #t) 1440 (let ([ls (cons (- (random (expt 2 32)) (expt 2 31)) 1441 (map (lambda (n) (- (random n) (expt 2 31))) (make-list 7 (expt 2 64))))]) 1442 (unless (apply test-ifoo 1443 (lambda (x a b c d e f g) 1444 (+ x (ifoo64a a b c d e f g))) 1445 ls) 1446 (pretty-print ls) 1447 (errorf #f "failed for ifoo64a on ~s" ls)) 1448 (unless (apply test-ifoo ifoo64b ls) 1449 (pretty-print ls) 1450 (errorf #f "failed for ifoo64b on ~s" ls)))) 1451) 1452 1453(mat foreign-C-types 1454 ; test void*, int, unsigned, float, etc. 1455 (begin 1456 (define int-to-int (foreign-procedure "int_to_int" (int int) int)) 1457 (define unsigned-to-unsigned (foreign-procedure "unsigned_to_unsigned" (unsigned int) unsigned)) 1458 (define unsigned-int-to-unsigned-int (foreign-procedure "unsigned_to_unsigned" (unsigned-int int) unsigned-int)) 1459 (define char-to-char (foreign-procedure "char_to_char" (char) char)) 1460 (define wchar-to-wchar (foreign-procedure "wchar_to_wchar" (wchar) wchar)) 1461 (define short-to-short (foreign-procedure "short_to_short" (short int) short)) 1462 (define unsigned-short-to-unsigned-short (foreign-procedure "unsigned_short_to_unsigned_short" (unsigned-short int) unsigned-short)) 1463 (define long-to-long (foreign-procedure "long_to_long" (long int) long)) 1464 (define unsigned-long-to-unsigned-long (foreign-procedure "unsigned_long_to_unsigned_long" (unsigned-long int) unsigned-long)) 1465 (define long-long-to-long-long (foreign-procedure "long_long_to_long_long" (long-long int) long-long)) 1466 (define unsigned-long-long-to-unsigned-long-long (foreign-procedure "unsigned_long_long_to_unsigned_long_long" (unsigned-long-long int) unsigned-long-long)) 1467 (define float-to-float (foreign-procedure "float_to_float" (float) float)) 1468 (define double-to-double (foreign-procedure "double_to_double" (double) double)) 1469 (define iptr-to-iptr (foreign-procedure "iptr_to_iptr" (iptr int) iptr)) 1470 (define uptr-to-uptr (foreign-procedure "uptr_to_uptr" (uptr int) uptr)) 1471 (define void*-to-void* (foreign-procedure "uptr_to_uptr" (void* int) void*)) 1472 #t) 1473 ($test-int-to-int int-to-int (foreign-sizeof 'int) #t) 1474 ($test-int-to-int unsigned-to-unsigned (foreign-sizeof 'unsigned) #f) 1475 ($test-int-to-int unsigned-int-to-unsigned-int (foreign-sizeof 'unsigned-int) #f) 1476 ($test-int-to-int short-to-short (foreign-sizeof 'short) #t) 1477 ($test-int-to-int unsigned-short-to-unsigned-short (foreign-sizeof 'unsigned-short) #f) 1478 ($test-int-to-int long-to-long (foreign-sizeof 'long) #t) 1479 ($test-int-to-int unsigned-long-to-unsigned-long (foreign-sizeof 'unsigned-long) #f) 1480 ($test-int-to-int long-long-to-long-long (foreign-sizeof 'long-long) #t) 1481 ($test-int-to-int unsigned-long-long-to-unsigned-long-long (foreign-sizeof 'unsigned-long-long) #f) 1482 ($test-int-to-int iptr-to-iptr (foreign-sizeof 'iptr) #t) 1483 ($test-int-to-int uptr-to-uptr (foreign-sizeof 'uptr) #f) 1484 ($test-int-to-int void*-to-void* (foreign-sizeof 'void*) #f) 1485 1486 (eqv? (char-to-char #\a) #\A) 1487 (eqv? (wchar-to-wchar #\x3bb) #\x39b) 1488 (eqv? (float-to-float 73.5) 74.5) 1489 (eqv? (double-to-double 73.5) 74.5) 1490 1491 (error? (int-to-int 'qqq 0)) 1492 (error? (unsigned-to-unsigned 'qqq 0)) 1493 (error? (unsigned-int-to-unsigned-int 'qqq 0)) 1494 (error? (unsigned-short-to-unsigned-short 'qqq 0)) 1495 (error? (short-to-short 'qqq 0)) 1496 (error? (long-to-long 'qqq 0)) 1497 (error? (unsigned-long-to-unsigned-long 'qqq 0)) 1498 (error? (long-long-to-long-long 'qqq 0)) 1499 (error? (unsigned-long-long-to-unsigned-long-long 'qqq 0)) 1500 (error? (iptr-to-iptr 'qqq 0)) 1501 (error? (uptr-to-uptr 'qqq 0)) 1502 (error? (void*-to-void* 'qqq 0)) 1503 (error? (int-to-int 0 "oops")) 1504 (error? (unsigned-to-unsigned 0 "oops")) 1505 (error? (unsigned-int-to-unsigned-int 0 "oops")) 1506 (error? (unsigned-short-to-unsigned-short 0 "oops")) 1507 (error? (short-to-short 0 "oops")) 1508 (error? (long-to-long 0 "oops")) 1509 (error? (unsigned-long-to-unsigned-long 0 "oops")) 1510 (error? (long-long-to-long-long 0 "oops")) 1511 (error? (unsigned-long-long-to-unsigned-long-long 0 "oops")) 1512 (error? (iptr-to-iptr 0 "oops")) 1513 (error? (uptr-to-uptr 0 "oops")) 1514 (error? (void*-to-void* 0 "oops")) 1515 1516 (error? (char-to-char 73)) 1517 (error? (char-to-char #\x100)) 1518 (error? (wchar-to-wchar 73)) 1519 (or (= (optimize-level) 3) 1520 (if (eq? (foreign-sizeof 'wchar) 16) 1521 (guard? (c [#t]) (wchar-to-char #\x10000) #f) 1522 #t)) 1523 (error? (float-to-float 'qqq.5)) 1524 (error? (double-to-double 'qqq.5)) 1525 1526 (begin 1527 (define call-int (foreign-procedure "call_int" (ptr int int int) int)) 1528 (define call-unsigned (foreign-procedure "call_unsigned" (ptr unsigned int int) unsigned)) 1529 (define call-unsigned-int (foreign-procedure "call_unsigned" (ptr unsigned-int int int) unsigned-int)) 1530 (define call-char (foreign-procedure "call_char" (ptr char int int) char)) 1531 (define call-wchar (foreign-procedure "call_wchar" (ptr wchar int int) wchar)) 1532 (define call-short (foreign-procedure "call_short" (ptr short int int) short)) 1533 (define call-unsigned-short (foreign-procedure "call_unsigned_short" (ptr unsigned-short int int) unsigned-short)) 1534 (define call-long (foreign-procedure "call_long" (ptr long int int) long)) 1535 (define call-unsigned-long (foreign-procedure "call_unsigned_long" (ptr unsigned-long int int) unsigned-long)) 1536 (define call-long-long (foreign-procedure "call_long_long" (ptr long-long int int) long-long)) 1537 (define call-unsigned-long-long (foreign-procedure "call_unsigned_long_long" (ptr unsigned-long-long int int) unsigned-long-long)) 1538 (define call-float (foreign-procedure "call_float" (ptr float int int) float)) 1539 (define call-double (foreign-procedure "call_double" (ptr double int int) double)) 1540 (define call-iptr (foreign-procedure "call_iptr" (ptr iptr int int) iptr)) 1541 (define call-uptr (foreign-procedure "call_uptr" (ptr uptr int int) uptr)) 1542 (define call-void* (foreign-procedure "call_uptr" (ptr void* int int) void*)) 1543 #t) 1544 ($test-call-int #t (foreign-sizeof 'int) call-int 1545 (lambda (p) (foreign-callable p (int) int))) 1546 ($test-call-int #f (foreign-sizeof 'unsigned) call-unsigned 1547 (lambda (p) (foreign-callable p (unsigned) unsigned))) 1548 ($test-call-int #f (foreign-sizeof 'unsigned-int) call-unsigned-int 1549 (lambda (p) (foreign-callable p (unsigned-int) unsigned-int))) 1550 ($test-call-int #t (foreign-sizeof 'short) call-short 1551 (lambda (p) (foreign-callable p (short) short))) 1552 ($test-call-int #f (foreign-sizeof 'unsigned-short) call-unsigned-short 1553 (lambda (p) (foreign-callable p (unsigned-short) unsigned-short))) 1554 ($test-call-int #t (foreign-sizeof 'long) call-long 1555 (lambda (p) (foreign-callable p (long) long))) 1556 ($test-call-int #f (foreign-sizeof 'unsigned-long) call-unsigned-long 1557 (lambda (p) (foreign-callable p (unsigned-long) unsigned-long))) 1558 ($test-call-int #t (foreign-sizeof 'long-long) call-long-long 1559 (lambda (p) (foreign-callable p (long-long) long-long))) 1560 ($test-call-int #f (foreign-sizeof 'unsigned-long-long) call-unsigned-long-long 1561 (lambda (p) (foreign-callable p (unsigned-long-long) unsigned-long-long))) 1562 ($test-call-int #t (foreign-sizeof 'iptr) call-iptr 1563 (lambda (p) (foreign-callable p (iptr) iptr))) 1564 ($test-call-int #f (foreign-sizeof 'uptr) call-uptr 1565 (lambda (p) (foreign-callable p (uptr) uptr))) 1566 ($test-call-int #f (foreign-sizeof 'void*) call-void* 1567 (lambda (p) (foreign-callable p (void*) void*))) 1568 (equal? 1569 (call-char 1570 (foreign-callable 1571 (lambda (x) (integer->char (+ (char->integer x) 5))) 1572 (char) char) 1573 #\a 7 11) 1574 #\x) 1575 (equal? 1576 (call-wchar 1577 (foreign-callable 1578 (lambda (x) (integer->char (+ (char->integer x) 5))) 1579 (wchar) wchar) 1580 #\x3bb 7 11) 1581 #\x3d2) 1582 (equal? 1583 (call-float 1584 (foreign-callable 1585 (lambda (x) (+ x 5)) 1586 (float) single-float) 1587 73.25 7 23) 1588 108.25) 1589 (equal? 1590 (call-double 1591 (foreign-callable 1592 (lambda (x) (+ x 5)) 1593 (double) double-float) 1594 73.25 7 23) 1595 108.25) 1596 1597 (error? 1598 (call-int 1599 (foreign-callable 1600 (lambda (x) (list x (+ x 1))) 1601 (int) int) 1602 73 0 0)) 1603 (error? 1604 (call-unsigned 1605 (foreign-callable 1606 (lambda (x) (list x (+ x 1))) 1607 (unsigned) unsigned) 1608 73 0 0)) 1609 (error? 1610 (call-unsigned-int 1611 (foreign-callable 1612 (lambda (x) (list x (+ x 1))) 1613 (unsigned-int) unsigned-int) 1614 73 0 0)) 1615 (error? 1616 (call-char 1617 (foreign-callable 1618 (lambda (x) (list x)) 1619 (char) char) 1620 #\a 0 0)) 1621 (error? 1622 (call-wchar 1623 (foreign-callable 1624 (lambda (x) (list x)) 1625 (wchar) wchar) 1626 #\a 0 0)) 1627 (error? 1628 (call-short 1629 (foreign-callable 1630 (lambda (x) (list x (+ x 1))) 1631 (short) short) 1632 73 0 0)) 1633 (error? 1634 (call-unsigned-short 1635 (foreign-callable 1636 (lambda (x) (list x (+ x 1))) 1637 (unsigned-short) unsigned-short) 1638 73 0 0)) 1639 (error? 1640 (call-long 1641 (foreign-callable 1642 (lambda (x) (list x (+ x 1))) 1643 (long) long) 1644 73 0 0)) 1645 (error? 1646 (call-unsigned-long 1647 (foreign-callable 1648 (lambda (x) (list x (+ x 1))) 1649 (unsigned-long) unsigned-long) 1650 73 0 0)) 1651 (error? 1652 (call-long-long 1653 (foreign-callable 1654 (lambda (x) (list x (+ x 1))) 1655 (long-long) long-long) 1656 73 0 0)) 1657 (error? 1658 (call-unsigned-long-long 1659 (foreign-callable 1660 (lambda (x) (list x (+ x 1))) 1661 (unsigned-long-long) unsigned-long-long) 1662 73 0 0)) 1663 (error? 1664 (call-float 1665 (foreign-callable 1666 (lambda (x) (list x (+ x 1))) 1667 (float) float) 1668 73.25 0 0)) 1669 (error? 1670 (call-double 1671 (foreign-callable 1672 (lambda (x) (list x (+ x 1))) 1673 (double) double) 1674 73.25 0 0)) 1675 (error? 1676 (call-iptr 1677 (foreign-callable 1678 (lambda (x) (list x (+ x 1))) 1679 (iptr) iptr) 1680 73 0 0)) 1681 (error? 1682 (call-uptr 1683 (foreign-callable 1684 (lambda (x) (list x (+ x 1))) 1685 (uptr) uptr) 1686 73 0 0)) 1687 (error? 1688 (call-void* 1689 (foreign-callable 1690 (lambda (x) (list x (+ x 1))) 1691 (void*) void*) 1692 73 0 0)) 1693) 1694 1695(mat foreign-ftype 1696 (begin 1697 (define-ftype A (struct [x double] [y wchar])) 1698 (define-ftype B (struct [x (array 10 A)] [y A])) 1699 (define B->*int (foreign-procedure "uptr_to_uptr" ((* B) int) (* int))) 1700 (define B->A (foreign-procedure "uptr_to_uptr" ((* B) int) (* A))) 1701 (define B->uptr (foreign-procedure "uptr_to_uptr" ((* B) int) uptr)) 1702 (define uptr->A (foreign-procedure "uptr_to_uptr" (uptr int) (* A))) 1703 (define b ((foreign-procedure (if (windows?) "windows_malloc" "malloc") (ssize_t) (* B)) (ftype-sizeof B))) 1704 #t) 1705 (eqv? 1706 (ftype-pointer-address (uptr->A (ftype-pointer-address (ftype-&ref B (y) b)) 0)) 1707 (ftype-pointer-address (ftype-&ref B (y) b))) 1708 (eqv? 1709 (ftype-pointer-address (uptr->A (ftype-pointer-address b) (* 10 (ftype-sizeof A)))) 1710 (ftype-pointer-address (ftype-&ref B (y) b))) 1711 (eqv? 1712 (B->uptr b (* 10 (ftype-sizeof A))) 1713 (ftype-pointer-address (ftype-&ref B (y) b))) 1714 (eqv? 1715 (ftype-pointer-address (B->A b (* 10 (ftype-sizeof A)))) 1716 (ftype-pointer-address (ftype-&ref B (y) b))) 1717 (begin 1718 (define uptr->uptr (foreign-callable values (uptr) uptr)) 1719 (define uptr->A (foreign-callable (lambda (a) (make-ftype-pointer A a)) (uptr) (* A))) 1720 (define B->uptr (foreign-callable ftype-pointer-address ((* B)) uptr)) 1721 (define B->A (foreign-callable (lambda (b) (ftype-&ref B (y) b)) ((* B)) (* A))) 1722 (define call-B->A (foreign-procedure "call_uptr" (ptr (* B) int int) (* A))) 1723 #t) 1724 (eqv? 1725 (ftype-pointer-address (call-B->A uptr->uptr b (* 5 (ftype-sizeof A)) (* 5 (ftype-sizeof A)))) 1726 (ftype-pointer-address (ftype-&ref B (y) b))) 1727 (eqv? 1728 (ftype-pointer-address (call-B->A uptr->A b (* 5 (ftype-sizeof A)) (* 5 (ftype-sizeof A)))) 1729 (ftype-pointer-address (ftype-&ref B (y) b))) 1730 (eqv? 1731 (ftype-pointer-address (call-B->A B->uptr b (* 5 (ftype-sizeof A)) (* 5 (ftype-sizeof A)))) 1732 (ftype-pointer-address (ftype-&ref B (y) b))) 1733 (eqv? 1734 (ftype-pointer-address (call-B->A B->A b 0 0)) 1735 (ftype-pointer-address (ftype-&ref B (y) b))) 1736 (begin 1737 ((foreign-procedure (if (windows?) "windows_free" "free") ((* B)) void) b) 1738 (set! b #f) 1739 #t) 1740 (error? ; unrecognized foreign-procedure argument ftype name 1741 (foreign-procedure "foo" ((* broken)) void)) 1742 (error? ; invalid foreign-procedure argument type specifier 1743 (foreign-procedure "foo" ((+ * -)) void)) 1744 (error? ; invalid foreign-procedure argument type specifier 1745 (foreign-procedure "foo" ((* * *)) void)) 1746 (error? ; invalid foreign-procedure argument type specifier 1747 (foreign-procedure "foo" ((struct [a int])) void)) 1748 (error? ; invalid foreign-procedure argument type specifier 1749 (foreign-procedure "foo" (hag) void)) 1750 (error? ; unrecognized foreign-procedure return ftype name 1751 (foreign-procedure "foo" () (* broken))) 1752 (error? ; invalid foreign-procedure return type specifier 1753 (foreign-procedure "foo" () (+ * -))) 1754 (error? ; invalid foreign-procedure return type specifier 1755 (foreign-procedure "foo" () (* * *))) 1756 (error? ; invalid foreign-procedure argument type specifier 1757 (foreign-procedure "foo" () ((struct [a int])))) 1758 (error? ; invalid foreign-procedure return type specifier 1759 (foreign-procedure "foo" () hag)) 1760 (error? ; invalid (non-base) ... ftype 1761 (foreign-procedure "foo" (A) void)) 1762 (error? ; invalid (non-base) ... ftype 1763 (foreign-procedure "foo" () A)) 1764 (begin 1765 (meta-cond 1766 [(eq? (native-endianness) 'little) 1767 (define-ftype swap-fixnum (endian big fixnum))] 1768 [(eq? (native-endianness) 'big) 1769 (define-ftype swap-fixnum (endian little fixnum))]) 1770 #t) 1771 (error? ; invalid (swapped) ... ftype 1772 (foreign-procedure "foo" (swap-fixnum) void)) 1773 (error? ; invalid (swapped) ... ftype 1774 (foreign-procedure "foo" () swap-fixnum)) 1775 (error? ; invalid syntax 1776 (define-ftype foo (function "wtf" () void) +)) 1777 (error? ; invalid convention 1778 (define-ftype foo (function "wtf" () void))) 1779 (error? ; invalid argument type void 1780 (define-ftype foo (function (void) int))) 1781 (equal? 1782 (let () 1783 (define-ftype foo (function (int) void)) 1784 (list (ftype-pointer? (make-ftype-pointer foo 0)) 1785 (ftype-pointer? foo (make-ftype-pointer double 0)) 1786 (ftype-pointer? foo (make-ftype-pointer foo 0)))) 1787 '(#t #f #t)) 1788 (error? ; non-function ftype with "memcpy" address 1789 (define $fp-bvcopy (make-ftype-pointer double "memcpy"))) 1790 (error? ; unrecognized ftype 1791 (define $fp-bvcopy (make-ftype-pointer spam "memcpy"))) 1792 (error? ; invalid syntax 1793 (define $fp-bvcopy (make-ftype-pointer (struct [x int]) "memcpy"))) 1794 (error? ; invalid function-ftype result type specifier u8 1795 (let () 1796 (define-ftype foo (function (u8* u8* size_t) u8)) 1797 (define $fp-bvcopy (make-ftype-pointer foo "memcpy")))) 1798 (error? ; invalid function-ftype argument type specifier u8 1799 (let () 1800 (define-ftype foo (function (u8* u8 size_t) u8*)) 1801 (define $fp-bvcopy (make-ftype-pointer foo "memcpy")))) 1802 (begin 1803 (define-ftype memcpy_t (function (u8* u8* size_t) u8*)) 1804 (define $fp-bvcopy (ftype-ref memcpy_t () (make-ftype-pointer memcpy_t "memcpy"))) 1805 #t) 1806 (let ([bv1 (string->utf8 "hello")] [bv2 (make-bytevector 5)]) 1807 ($fp-bvcopy bv2 bv1 5) 1808 (and (bytevector=? bv1 bv2) (bytevector=? bv1 (string->utf8 "hello")))) 1809 (begin 1810 (define-ftype bvcopy-t (function (u8* u8* size_t) u8*)) 1811 (define $fp-bvcopy (ftype-ref bvcopy-t () (make-ftype-pointer bvcopy-t "memcpy"))) 1812 #t) 1813 (let ([bv1 (string->utf8 "hello")] [bv2 (make-bytevector 5)]) 1814 ($fp-bvcopy bv2 bv1 5) 1815 (and (bytevector=? bv1 bv2) (bytevector=? bv1 (string->utf8 "hello")))) 1816 ;; No longer an error since make-ftype-pointer also serves to make foriegn-pointers 1817 #;(error? ; "memcpy" is not a procedure 1818 (make-ftype-pointer memcpy_t "memcpy")) 1819 (error? ; unrecognized ftype 1820 (make-ftype-pointer spam +)) 1821 (error? ; non-function ftype 1822 (make-ftype-pointer double +)) 1823 (error? ; invalid syntax 1824 (make-ftype-pointer (struct [x int]) +)) 1825 (eqv? 1826 (let () 1827 (define-ftype foo (function (int int) double)) 1828 (define code 1829 (make-ftype-pointer foo 1830 (lambda (x y) (inexact (+ x y))))) 1831 (let ([code-object (foreign-callable-code-object (ftype-pointer-address code))]) 1832 (dynamic-wind 1833 (lambda () (lock-object code-object)) 1834 (lambda () 1835 (define f (ftype-ref foo () code)) 1836 (f 3 4)) 1837 (lambda () (unlock-object code-object))))) 1838 7.0) 1839 (eqv? 1840 (let () 1841 (define-ftype foo (function (int int) double)) 1842 (define code 1843 (make-ftype-pointer foo 1844 (lambda (x y) (inexact (+ x y))))) 1845 (define f (ftype-ref foo () code)) 1846 (let ([x (f 8 4)]) 1847 (unlock-object (foreign-callable-code-object (ftype-pointer-address code))) 1848 x)) 1849 12.0) 1850 (eqv? 1851 (let () 1852 (define-ftype foo (function (void* void*) ptrdiff_t)) 1853 (define code (make-ftype-pointer foo -)) 1854 (let ([code-object (foreign-callable-code-object (ftype-pointer-address code))]) 1855 (dynamic-wind 1856 (lambda () (lock-object code-object)) 1857 (lambda () ((ftype-ref foo () code) 17 (* (most-positive-fixnum) 2))) 1858 (lambda () (unlock-object code-object))))) 1859 (- 17 (* (most-positive-fixnum) 2))) 1860 (eqv? 1861 (let () 1862 (define-ftype foo (function (void* void*) ptrdiff_t)) 1863 (define code (make-ftype-pointer foo -)) 1864 (let ([x ((ftype-ref foo () code) 19 (* (most-positive-fixnum) 2))]) 1865 (unlock-object (foreign-callable-code-object (ftype-pointer-address code))) 1866 x)) 1867 (- 19 (* (most-positive-fixnum) 2))) 1868 (eqv? 1869 (let () 1870 (define-ftype foo (function (int int) size_t)) 1871 (define code (make-ftype-pointer foo -)) 1872 (let ([code-object (foreign-callable-code-object (ftype-pointer-address code))]) 1873 (dynamic-wind 1874 (lambda () (lock-object code)) 1875 (lambda () ((ftype-ref foo () code) 17 32)) 1876 (lambda () (unlock-object code))))) 1877 (- (expt 2 (* (ftype-sizeof size_t) 8)) 15)) 1878 (eqv? 1879 (let () 1880 (define-ftype foo (function (int int) size_t)) 1881 (define code (make-ftype-pointer foo -)) 1882 (let ([x ((ftype-ref foo () code) 17 32)]) 1883 (unlock-object (foreign-callable-code-object (ftype-pointer-address code))) 1884 x)) 1885 (- (expt 2 (* (ftype-sizeof size_t) 8)) 15)) 1886 1887 (error? ; not a string 1888 (foreign-entry #e1e6)) 1889 1890 (error? ; no entry for "i am not defined" 1891 (foreign-entry "i am not defined")) 1892 1893 (begin 1894 (define-ftype F (function (size_t) int)) 1895 (define malloc-fptr1 (make-ftype-pointer F (if (windows?) "windows_malloc" "malloc"))) 1896 (define malloc-fptr2 (make-ftype-pointer F (foreign-entry (if (windows?) "windows_malloc" "malloc")))) 1897 #t) 1898 1899 (equal? 1900 (foreign-address-name (ftype-pointer-address malloc-fptr1)) 1901 (if (windows?) "windows_malloc" "malloc")) 1902 1903 (equal? 1904 (foreign-address-name (ftype-pointer-address malloc-fptr2)) 1905 (if (windows?) "windows_malloc" "malloc")) 1906 1907 (eqv? 1908 (ftype-pointer-address malloc-fptr1) 1909 (ftype-pointer-address malloc-fptr2)) 1910 1911 (procedure? 1912 (ftype-ref F () malloc-fptr1)) 1913 1914 (begin 1915 (define-ftype SF (struct [i int] [f (* F)])) 1916 (define sf (make-ftype-pointer SF (foreign-alloc (ftype-sizeof SF)))) 1917 (ftype-set! SF (i) sf 10) 1918 (ftype-set! SF (f) sf malloc-fptr2) 1919 #t) 1920 1921 (ftype-pointer? F (ftype-ref SF (f) sf)) 1922 1923 (procedure? (ftype-ref SF (f *) sf)) 1924 1925 (error? 1926 (begin 1927 (define-ftype A (struct [x double] [y wchar])) 1928 (define-ftype B (struct [x (array 10 A)] [y A])) 1929 ; see if defns above mess up defn below 1930 (define-ftype 1931 [A (function ((* B)) (* B))] 1932 [B (struct [x A])]))) 1933 1934 (begin 1935 (define-ftype A (struct [x double] [y wchar])) 1936 (define-ftype B (struct [x (array 10 A)] [y A])) 1937 ; see if defns above mess up defn below 1938 (define-ftype 1939 [A (function ((* B)) (* B))] 1940 [B (struct [x (* A)])]) 1941 (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B)))) 1942 (define a (ftype-ref A () (make-ftype-pointer A "idiptr"))) 1943 #t) 1944 (eqv? (ftype-pointer-address (a b)) (ftype-pointer-address b)) 1945 1946 (begin 1947 (define-ftype 1948 [A (function ((* B)) (* B))] 1949 [B (struct [x (* A)])]) 1950 (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B)))) 1951 (define a (ftype-ref A () (make-ftype-pointer A "idiptr"))) 1952 #t) 1953 (eqv? (ftype-pointer-address (a b)) (ftype-pointer-address b)) 1954 1955 (begin 1956 (define-ftype 1957 [B (struct [x (* A)])] 1958 [A (function ((* B)) (* B))]) 1959 (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B)))) 1960 (define a (ftype-ref A () (make-ftype-pointer A "idiptr"))) 1961 #t) 1962 (eqv? (ftype-pointer-address (a b)) (ftype-pointer-address b)) 1963 1964 (begin 1965 (define-ftype A (function ((* A)) (* A))) 1966 (define a (make-ftype-pointer A "idiptr")) 1967 #t) 1968 (eqv? (ftype-pointer-address ((ftype-ref A () a) a)) (ftype-pointer-address a)) 1969 1970 (begin 1971 (define-ftype A (struct [x uptr] [y uptr])) 1972 (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))) 1973 (define ff-init-lock (foreign-procedure "init_lock" ((* uptr)) void)) 1974 (define ff-spinlock (foreign-procedure "spinlock" ((* uptr)) void)) 1975 (define ff-unlock (foreign-procedure "unlock" ((* uptr)) void)) 1976 (define ff-locked-incr (foreign-procedure "locked_incr" ((* uptr)) boolean)) 1977 (define ff-locked-decr (foreign-procedure "locked_decr" ((* uptr)) boolean)) 1978 #t) 1979 (eq? (ff-init-lock (ftype-&ref A (x) a)) (void)) 1980 (ftype-lock! A (x) a) 1981 (not (ftype-lock! A (x) a)) 1982 (eq? (ftype-unlock! A (x) a) (void)) 1983 (eq? (ff-spinlock (ftype-&ref A (x) a)) (void)) 1984 (not (ftype-lock! A (x) a)) 1985 (eq? (ff-unlock (ftype-&ref A (x) a)) (void)) 1986 (ftype-lock! A (x) a) 1987 (eq? (ff-unlock (ftype-&ref A (x) a)) (void)) 1988 (eq? (ff-spinlock (ftype-&ref A (x) a)) (void)) 1989 (not (ftype-lock! A (x) a)) 1990 (eq? (ff-unlock (ftype-&ref A (x) a)) (void)) 1991 (eq? (ftype-set! A (y) a 1) (void)) 1992 (not (ff-locked-incr (ftype-&ref A (y) a))) 1993 (eqv? (ftype-ref A (y) a) 2) 1994 (not (ff-locked-decr (ftype-&ref A (y) a))) 1995 (ff-locked-decr (ftype-&ref A (y) a)) 1996 (eqv? (ftype-ref A (y) a) 0) 1997 (not (ff-locked-decr (ftype-&ref A (y) a))) 1998 (ff-locked-incr (ftype-&ref A (y) a)) 1999) 2000 2001(mat foreign-anonymous 2002 (eqv? 2003 (let ([addr ((foreign-procedure "idiptr_addr" () iptr))]) 2004 (define idiptr (foreign-procedure addr (scheme-object) scheme-object)) 2005 (idiptr 'friggle)) 2006 'friggle) 2007) 2008 2009(machine-case 2010 [(i3nt ti3nt) 2011 (mat i3nt-stdcall 2012 (let () 2013 (define (win32:number-32-ptr->number n32ptr) 2014 (+ (fx+ (char->integer (string-ref n32ptr 0)) 2015 (fxsll (char->integer (string-ref n32ptr 1)) 8) 2016 (fxsll (char->integer (string-ref n32ptr 2)) 16)) 2017 (* (char->integer (string-ref n32ptr 3)) #x1000000))) 2018 (define (win32:GetVolumeSerialNumber root) 2019 (define f-proc 2020 (foreign-procedure __stdcall "GetVolumeInformationA" 2021 (string string unsigned-32 string string string string unsigned-32) 2022 boolean)) 2023 (let ([vol-sid (make-string 4)] 2024 [max-filename-len (make-string 4)] 2025 [sys-flags (make-string 4)]) 2026 (and (f-proc root #f 0 vol-sid max-filename-len sys-flags #f 0) 2027 (win32:number-32-ptr->number vol-sid)))) 2028 (number? (win32:GetVolumeSerialNumber "C:\\"))))]) 2029 2030(mat single-float 2031 (= (let ((x (foreign-procedure "sxstos" (single-float single-float) 2032 single-float))) 2033 (x 3.0 5.0)) 2034 15) 2035 (let ((args '(1.25 2.25 3.25 4.25 5.25 6.25 7.25 8.25 9.25 10.25 11.25 12.25))) 2036 (= (apply + args) 2037 (apply 2038 (foreign-procedure "singlesum12" 2039 (single-float single-float single-float single-float 2040 single-float single-float single-float single-float 2041 single-float single-float single-float single-float) 2042 single-float) 2043 args))) 2044 ) 2045 2046(mat auto-mat-icks 2047 (auto-mat-ick "d1d2") 2048 (auto-mat-ick "s1s2") 2049 (auto-mat-ick "s1d1") 2050 (auto-mat-ick "d1s1") 2051 (auto-mat-ick "n1n2n3n4") 2052 (auto-mat-ick "d1n1d2") 2053 (auto-mat-ick "d1n1n2") 2054 (auto-mat-ick "s1n1n2") 2055 (auto-mat-ick "n1n2n3d1") 2056 (auto-mat-ick "n1n2n3s1") 2057 (auto-mat-ick "n1n2d1") 2058 (auto-mat-ick "n1d1") 2059 (auto-mat-ick "s1s2s3s4") 2060 (auto-mat-ick "s1n1s2n2") 2061 (auto-mat-ick "d1s1s2") 2062 (auto-mat-ick "s1s2d1") 2063 (auto-mat-ick "n1s1n2s2") 2064 (auto-mat-ick "n1s1n2n3") 2065 (auto-mat-ick "n1n2s1n3") 2066 (auto-mat-ick "d1d2s1s2") 2067 (auto-mat-ick "d1d2n1n2") 2068 (auto-mat-ick "s1d1s2s3") 2069 ) 2070 2071(mat foreign-callable 2072 (begin 2073 ;; We don't have to use `lock-object` on the result of a `foreign-callable`, 2074 ;; because it is immobile. We have to keep it live, though. 2075 (define-syntax with-object-kept-live 2076 (lambda (x) 2077 (syntax-case x () 2078 [(_ id expr) 2079 (identifier? #'id) 2080 #'(let ([v expr]) 2081 (keep-live id) 2082 v)]))) 2083 #t) 2084 2085 (error? ; spam is not a procedure 2086 (foreign-callable 'spam () void)) 2087 (error? ; spam is not a procedure 2088 (begin (foreign-callable 'spam () void) 'q)) 2089 (error? ; spam is not a procedure 2090 (if (foreign-callable 'spam () void) 'q 'p)) 2091 (equal? 2092 (let () 2093 (define Sinvoke2 2094 (foreign-procedure "Sinvoke2" 2095 (scheme-object scheme-object iptr) 2096 scheme-object)) 2097 (define Fcons 2098 (foreign-callable 2099 (lambda (x y) 2100 (collect) 2101 (let ([ls (map (lambda (x) (make-vector 200 x)) (make-list 100))]) 2102 (collect) 2103 (collect) 2104 (collect) 2105 (collect) 2106 (collect) 2107 (cons (length ls) (cons x y)))) 2108 (scheme-object iptr) 2109 scheme-object)) 2110 (define (go) (Sinvoke2 Fcons 4 5)) 2111 (define initial-result (go)) 2112 (let loop ([i 100]) 2113 (if (zero? i) 2114 initial-result 2115 (and (equal? initial-result (go)) 2116 (loop (sub1 i)))))) 2117 '(100 4 . 5)) 2118 (eqv? 2119 (let () 2120 (define Sinvoke2 2121 (foreign-procedure "Sinvoke2" 2122 (scheme-object scheme-object iptr) 2123 scheme-object)) 2124 (define fxFsum 2125 (foreign-callable 2126 (lambda (x y) 2127 (if (fx= x 0) 2128 y 2129 (fx+ x (Sinvoke2 fxFsum (fx- x 1) y)))) 2130 (scheme-object iptr) 2131 scheme-object)) 2132 (define (fxgosum n) (Sinvoke2 fxFsum n 0)) 2133 (fxgosum 20)) 2134 210) 2135 (eqv? 2136 (let () 2137 (define Sinvoke2 2138 (foreign-procedure "Sinvoke2" 2139 (scheme-object scheme-object iptr) 2140 scheme-object)) 2141 (define Fsum 2142 (foreign-callable 2143 (lambda (x y) 2144 (if (= x 0) 2145 y 2146 (+ x (Sinvoke2 Fsum (- x 1) y)))) 2147 (scheme-object iptr) 2148 scheme-object)) 2149 (define (gosum n) (Sinvoke2 Fsum n (most-positive-fixnum))) 2150 (gosum 20)) 2151 (+ (most-positive-fixnum) 210)) 2152 (let () 2153 (define Fargtest 2154 (foreign-callable 2155 (lambda (bool char fixnum double single string) 2156 (list string single double fixnum char bool)) 2157 (boolean char fixnum double-float single-float string) 2158 scheme-object)) 2159 (define Sargtest 2160 (foreign-procedure "Sargtest" 2161 (iptr boolean char fixnum double-float single-float string) 2162 scheme-object)) 2163 (define args1 (list #t #\Q 12345 3.1415 2.0 "hit me")) 2164 (define args2 (list #f #\newline -51293 3.1415 2.5 "")) 2165 (define args3 (list #f #\newline -51293 3.1415 2.5 #f)) 2166 (let () 2167 (define addr 2168 (foreign-callable-entry-point Fargtest)) 2169 (let () 2170 (collect (collect-maximum-generation)) 2171 (collect (collect-maximum-generation)) 2172 (with-object-kept-live 2173 Fargtest 2174 (and 2175 (equal? (apply Sargtest addr args1) (reverse args1)) 2176 (equal? (apply Sargtest addr args2) (reverse args2)) 2177 (equal? (apply Sargtest addr args3) (reverse args3))))))) 2178 (let () 2179 (define Fargtest2 2180 (foreign-callable 2181 (lambda (x1 x2 x3 x4 x5 x6) 2182 (list x6 x5 x4 x3 x2 x1)) 2183 (short int char double short char) 2184 scheme-object)) 2185 (define Sargtest2 2186 (foreign-procedure "Sargtest2" 2187 (iptr short int char double short char) 2188 scheme-object)) 2189 (define args1 (list 32123 #xc7c7c7 #\% 3.1415 -32768 #\!)) 2190 (define args2 (list 17 #x-987654 #\P -521.125 -1955 #\Q)) 2191 (define args3 (list -7500 #x987654 #\? +inf.0 3210 #\7)) 2192 (let () 2193 (define addr 2194 (foreign-callable-entry-point Fargtest2)) 2195 (let () 2196 (collect (collect-maximum-generation)) 2197 (collect (collect-maximum-generation)) 2198 (with-object-kept-live 2199 Fargtest2 2200 (and 2201 (equal? (apply Sargtest2 addr args1) (reverse args1)) 2202 (equal? (apply Sargtest2 addr args2) (reverse args2)) 2203 (equal? (apply Sargtest2 addr args3) (reverse args3))))))) 2204 (let () 2205 (define Frvtest_int32 2206 (foreign-callable 2207 (lambda (x) (* x x)) 2208 (scheme-object) 2209 integer-32)) 2210 (define Srvtest_int32 2211 (foreign-procedure "Srvtest_int32" 2212 (scheme-object scheme-object) 2213 integer-32)) 2214 (and 2215 (eqv? (Srvtest_int32 Frvtest_int32 16) 256) 2216 (eqv? (Srvtest_int32 Frvtest_int32 #x8000) #x40000000))) 2217 (let () 2218 (define Frvtest_uns32 2219 (foreign-callable 2220 (lambda (x) (- (* x x) 1)) 2221 (scheme-object) 2222 unsigned-32)) 2223 (define Srvtest_uns32 2224 (foreign-procedure "Srvtest_uns32" 2225 (scheme-object scheme-object) 2226 unsigned-32)) 2227 (and 2228 (eqv? (Srvtest_uns32 Frvtest_uns32 16) 255) 2229 (eqv? (Srvtest_uns32 Frvtest_uns32 #x10000) #xffffffff))) 2230 (let () 2231 (define Frvtest_single 2232 (foreign-callable 2233 (lambda (x) (* x x)) 2234 (scheme-object) 2235 single-float)) 2236 (define Srvtest_single 2237 (foreign-procedure "Srvtest_single" 2238 (scheme-object scheme-object) 2239 single-float)) 2240 (eqv? (Srvtest_single Frvtest_single 16.0) 256.0)) 2241 (let () 2242 (define Frvtest_double 2243 (foreign-callable 2244 (lambda (x) (* x x)) 2245 (scheme-object) 2246 double-float)) 2247 (define Srvtest_double 2248 (foreign-procedure "Srvtest_double" 2249 (scheme-object scheme-object) 2250 double-float)) 2251 (eqv? (Srvtest_double Frvtest_double 16.0) 256.0)) 2252 (let () 2253 (define Frvtest_char 2254 (foreign-callable 2255 (lambda (x) (string-ref x 3)) 2256 (scheme-object) 2257 char)) 2258 (define Srvtest_char 2259 (foreign-procedure "Srvtest_char" 2260 (scheme-object scheme-object) 2261 char)) 2262 (eqv? (Srvtest_char Frvtest_char "abcdefg") #\d)) 2263 (let () 2264 (define Frvtest_boolean 2265 (foreign-callable 2266 (lambda (x) (equal? x "abcdefg")) 2267 (scheme-object) 2268 boolean)) 2269 (define Srvtest_boolean 2270 (foreign-procedure "Srvtest_int32" 2271 (scheme-object scheme-object) 2272 boolean)) 2273 (and 2274 (eqv? (Srvtest_boolean Frvtest_boolean "abcdefg") #t) 2275 (eqv? (Srvtest_boolean Frvtest_boolean "gfedcba") #f))) 2276 (let () 2277 (define Frvtest_fixnum 2278 (foreign-callable 2279 (lambda (x) (* x x)) 2280 (scheme-object) 2281 fixnum)) 2282 (define Srvtest_fixnum 2283 (foreign-procedure "Srvtest_int32" 2284 (scheme-object scheme-object) 2285 fixnum)) 2286 (eqv? (Srvtest_fixnum Frvtest_fixnum 16) 256)) 2287 (let () 2288 (define Frvtest_fixnum 2289 (foreign-callable 2290 (lambda (x) (* x x)) 2291 (scheme-object) 2292 void)) 2293 (define Srvtest_fixnum 2294 (foreign-procedure "Srvtest_int32" 2295 (scheme-object scheme-object) 2296 void)) 2297 (eqv? (Srvtest_fixnum Frvtest_fixnum 16) (void))) 2298 #;(error? (foreign-callable values (scheme-object) foreign-pointer)) 2299 #;(error? (foreign-callable values (scheme-object) (foreign-object 16 4))) 2300 #;(error? (foreign-callable values (foreign-pointer) void)) 2301 #;(error? (foreign-callable values ((foreign-object 16 4)) void)) 2302 (equal? 2303 (let ([x 5]) 2304 (define call-twice (foreign-procedure "call_twice" (void* int int) void)) 2305 (let ([co (foreign-callable (lambda (y) (set! x (+ x y))) (int) void)]) 2306 (with-object-kept-live 2307 co 2308 (call-twice (foreign-callable-entry-point co) 7 31))) 2309 x) 2310 43) 2311 (equal? 2312 (let () 2313 ; foreign_callable example adapted from foreign.stex 2314 (define cb-init 2315 (foreign-procedure "cb_init" () void)) 2316 (define register-callback 2317 (foreign-procedure "register_callback" (char iptr) void)) 2318 (define event-loop 2319 (foreign-procedure "event_loop" (string) void)) 2320 2321 (define callback 2322 (lambda (p) 2323 (let ([code (foreign-callable p (char) void)]) 2324 (foreign-callable-entry-point code)))) 2325 (let () 2326 (define ouch 2327 (callback 2328 (lambda (c) 2329 (printf "Ouch! Hit by '~c'~%" c)))) 2330 (define rats 2331 (callback 2332 (lambda (c) 2333 (printf "Rats! Received '~c'~%" c)))) 2334 2335 (cb-init) 2336 (register-callback #\a ouch) 2337 (register-callback #\c rats) 2338 (register-callback #\e ouch) 2339 2340 (parameterize ([current-output-port (open-output-string)]) 2341 (event-loop "abcde") 2342 (get-output-string (current-output-port))))) 2343 (format "Ouch! Hit by 'a'~%Rats! Received 'c'~%Ouch! Hit by 'e'~%")) 2344 ; make sure foreign-procedure's code-object is properly locked when 2345 ; calling back into Scheme 2346 (begin 2347 (define call-collect (lambda () (collect) (collect (collect-maximum-generation)))) 2348 (define code (foreign-callable call-collect () void)) 2349 (collect) 2350 #t) 2351 ; this form needs to be after the preceding form and not part of it, so that when 2352 ; we lock code we don't also lock the code object created by foreign-procedure 2353 (begin 2354 (with-object-kept-live 2355 code 2356 ((foreign-procedure (foreign-callable-entry-point code) () scheme-object))) 2357 #t) 2358 2359 (not (locked-object? 2360 (let () 2361 (define cb (foreign-callable (lambda (i) i) (int) int)) 2362 (define unlock-callback (foreign-procedure "unlock_callback" (void*) void)) 2363 (lock-object cb) 2364 (unlock-callback (foreign-callable-entry-point cb)) 2365 cb))) 2366 (not (locked-object? 2367 (let () 2368 (define cb (foreign-callable (lambda (i) i) (int) int)) 2369 (define unlock-callback (foreign-procedure "unlock_callback" (void*) void)) 2370 (lock-object cb) 2371 (collect) 2372 (unlock-callback (foreign-callable-entry-point cb)) 2373 cb))) 2374 (equal? 2375 (let () 2376 (define cb (foreign-callable (lambda (i) (+ i 10)) (int) int)) 2377 (define call-and-unlock (foreign-procedure "call_and_unlock" (void* int) int)) 2378 (lock-object cb) 2379 (let ([ans (call-and-unlock (foreign-callable-entry-point cb) 5)]) 2380 (list (locked-object? cb) ans))) 2381 '(#f 15)) 2382 (equal? 2383 (let () 2384 (define cb (foreign-callable (lambda (i) (+ i 10)) (int) int)) 2385 (define call-and-unlock (foreign-procedure "call_and_unlock" (void* int) int)) 2386 (lock-object cb) 2387 (collect) 2388 (let ([ans (call-and-unlock (foreign-callable-entry-point cb) 3)]) 2389 (list (locked-object? cb) ans))) 2390 '(#f 13)) 2391 (begin 2392 (define $stack-depth 8000) 2393 (define $base-value 37) 2394 #t) 2395 (eqv? ; make sure foreign-callable does it's overflow checks 2396 (let () 2397 (define-ftype foo (function (fixnum fixnum) fixnum)) 2398 (define f (lambda (n m) (if (fx= n 0) m (g (fx- n 1) (fx+ m 1))))) 2399 (define fptr (make-ftype-pointer foo f)) 2400 (define g (ftype-ref foo () fptr)) 2401 (let ([v (f $stack-depth $base-value)]) 2402 (unlock-object 2403 (foreign-callable-code-object 2404 (ftype-pointer-address fptr))) 2405 v)) 2406 (+ $stack-depth $base-value)) 2407 (begin 2408 (define $with-exit-proc 2409 ; if you change this, consider changing the definition of with-exit-proc 2410 ; in foreign.stex 2411 (lambda (p) 2412 (define th (lambda () (call/cc p))) 2413 (define-ftype ->ptr (function () ptr)) 2414 (let ([fptr (make-ftype-pointer ->ptr th)]) 2415 (let ([v ((ftype-ref ->ptr () fptr))]) 2416 (unlock-object 2417 (foreign-callable-code-object 2418 (ftype-pointer-address fptr))) 2419 v)))) 2420 #t) 2421 (eqv? ; make sure we can jump out of a deep nest of C/Scheme calls 2422 (let () 2423 (define *k*) 2424 (define-ftype foo (function (fixnum fixnum) fixnum)) 2425 (define f (lambda (n m) (if (fx= n 0) (*k* m) (g (fx- n 1) (fx+ m 1))))) 2426 (define fptr (make-ftype-pointer foo f)) 2427 (define g (ftype-ref foo () fptr)) 2428 (let ([v ($with-exit-proc 2429 (lambda (k) 2430 (set! *k* k) 2431 (f $stack-depth $base-value)))]) 2432 (unlock-object 2433 (foreign-callable-code-object 2434 (ftype-pointer-address fptr))) 2435 v)) 2436 (+ $stack-depth $base-value)) 2437 (eqv? ; make sure we can jump out a few frames at a time 2438 (let () 2439 (define-ftype foo (function (fixnum fixnum ptr) fixnum)) 2440 (define f 2441 (lambda (n m k) 2442 (if (fx= n 0) 2443 (k m) 2444 (if (fx= (fxmodulo n 10) 0) 2445 (k (call/cc 2446 (lambda (k) 2447 (g (fx- n 1) (fx+ m 1) k)))) 2448 (g (fx- n 1) (fx+ m 1) k))))) 2449 (define fptr (make-ftype-pointer foo f)) 2450 (define g (ftype-ref foo () fptr)) 2451 (let ([v ($with-exit-proc 2452 (lambda (k) 2453 (f $stack-depth $base-value k)))]) 2454 (unlock-object 2455 (foreign-callable-code-object 2456 (ftype-pointer-address fptr))) 2457 v)) 2458 (+ $stack-depth $base-value)) 2459 (or (= (optimize-level) 3) 2460 ; make sure we can jump out a few frames at a time, returning from 2461 ; each with an invalid number of values, just for fun 2462 (eqv? 2463 ($with-exit-proc 2464 (lambda (ignore) 2465 (define *m*) 2466 (define *k*) 2467 (define-ftype foo (function (fixnum fixnum) fixnum)) 2468 (define f 2469 (lambda (n m) 2470 (if (fx= n 0) 2471 (begin (set! *m* m) (values)) 2472 (if (fx= (fxmodulo n 10) 0) 2473 (begin 2474 (set! *m* 2475 (call/cc 2476 (lambda (k) 2477 (fluid-let ([*k* k]) 2478 (g (fx- n 1) (fx+ m 1)))))) 2479 (values)) 2480 (g (fx- n 1) (fx+ m 1)))))) 2481 (define fptr (make-ftype-pointer foo f)) 2482 (define g (ftype-ref foo () fptr)) 2483 (with-exception-handler 2484 (lambda (c) (*k* *m*)) 2485 (lambda () 2486 (call/cc 2487 (lambda (k) 2488 (fluid-let ([*k* k]) (f $stack-depth $base-value)))))) 2489 (unlock-object 2490 (foreign-callable-code-object 2491 (ftype-pointer-address fptr))) 2492 *m*)) 2493 (+ $stack-depth $base-value))) 2494 (or (= (optimize-level) 3) 2495 ; similarly, but with a ptr return value so the values error is signaled 2496 ; by S_call_help wrather than the foreign-procedure wrapper 2497 (eqv? 2498 ($with-exit-proc 2499 (lambda (ignore) 2500 (define *m*) 2501 (define *k*) 2502 (define-ftype foo (function (fixnum fixnum) ptr)) 2503 (define f 2504 (lambda (n m) 2505 (if (fx= n 0) 2506 (begin (set! *m* m) (values)) 2507 (if (fx= (fxmodulo n 10) 0) 2508 (begin 2509 (set! *m* 2510 (call/cc 2511 (lambda (k) 2512 (fluid-let ([*k* k]) 2513 (g (fx- n 1) (fx+ m 1)))))) 2514 (values)) 2515 (g (fx- n 1) (fx+ m 1)))))) 2516 (define fptr (make-ftype-pointer foo f)) 2517 (define g (ftype-ref foo () fptr)) 2518 (with-exception-handler 2519 (lambda (c) (*k* *m*)) 2520 (lambda () 2521 (call/cc 2522 (lambda (k) 2523 (fluid-let ([*k* k]) (f $stack-depth $base-value)))))) 2524 (unlock-object 2525 (foreign-callable-code-object 2526 (ftype-pointer-address fptr))) 2527 *m*)) 2528 (+ $stack-depth $base-value))) 2529 (or (= (optimize-level) 3) 2530 ; make sure we can jump out a few frames at a time, returning from 2531 ; each with an fasl-reading error, just for fun 2532 (eqv? 2533 (let () 2534 (define *m*) 2535 (define *k*) 2536 (define ip (open-file-input-port (format "~a/mat.ss" *mats-dir*))) 2537 (define-ftype foo (function (fixnum fixnum) fixnum)) 2538 (define f 2539 (lambda (n m) 2540 (if (fx= n 0) 2541 (begin (set! *m* m) (fasl-read ip)) 2542 (if (fx= (fxmodulo n 10) 0) 2543 (begin 2544 (set! *m* 2545 (call/cc 2546 (lambda (k) 2547 (fluid-let ([*k* k]) 2548 (g (fx- n 1) (fx+ m 1)))))) 2549 (fasl-read ip)) 2550 (g (fx- n 1) (fx+ m 1)))))) 2551 (define fptr (make-ftype-pointer foo f)) 2552 (define g (ftype-ref foo () fptr)) 2553 ; position "fasl" file at eof to make sure fasl-read isn't tripped up 2554 ; by something that appears almost valid 2555 (get-bytevector-all ip) 2556 (with-exception-handler 2557 (lambda (c) (*k* *m*)) 2558 (lambda () 2559 ($with-exit-proc 2560 (lambda (k) 2561 (fluid-let ([*k* k]) (f $stack-depth $base-value)))))) 2562 (unlock-object 2563 (foreign-callable-code-object 2564 (ftype-pointer-address fptr))) 2565 *m*) 2566 (+ $stack-depth $base-value))) 2567 ;; A callable isn't locked, but it's immobile 2568 (equal? 2569 (let () 2570 (define Sinvoke2 2571 (foreign-procedure "Sinvoke2" 2572 (scheme-object scheme-object iptr) 2573 scheme-object)) 2574 (define Fcons 2575 (foreign-callable 2576 (lambda (k y) 2577 (collect) ; might crash if `Fcons` were mobile 2578 (k (locked-object? Fcons))) 2579 (scheme-object iptr) 2580 scheme-object)) 2581 (list 2582 ;; Call and normal callable return: 2583 (let ([v (Sinvoke2 Fcons (lambda (x) x) 5)]) 2584 (list v (locked-object? Fcons))) 2585 ;; Escape from callable: 2586 (let ([v ($with-exit-proc (lambda (k) (Sinvoke2 Fcons k 5)))]) 2587 (list v (locked-object? Fcons))))) 2588 '((#f #f) (#f #f))) 2589 2590 ;; Make sure the code pointer for a call into a 2591 ;; foreign procedure is correctly saved for locking 2592 ;; when entering a callback as a callable: 2593 (equal? 2594 (let () 2595 (define v 0) 2596 (define call_many_times (foreign-procedure "call_many_times" (void*) void)) 2597 (define work 2598 (lambda (n) 2599 ;; This loop needs to be non-allocating, but 2600 ;; causes varying numbers of ticks 2601 ;; to be used up. 2602 (let loop ([n (bitwise-and n #xFFFF)]) 2603 (unless (zero? n) 2604 (set! v (add1 v)) 2605 (loop (bitwise-arithmetic-shift-right n 1)))))) 2606 (define handler (foreign-callable work (long) void)) 2607 (with-object-kept-live 2608 handler 2609 (call_many_times (foreign-callable-entry-point handler))) 2610 (unlock-object handler) 2611 v) 2612 14995143) 2613 2614 (equal? 2615 (let () 2616 (define v 0) 2617 (define call_many_times_bv (foreign-procedure "call_many_times_bv" (void*) void)) 2618 (define work 2619 (lambda (bv) 2620 (set! v (+ v (bytevector-u8-ref bv 0))) 2621 ;; Varying work, as above: 2622 (let loop ([n (bitwise-and (bytevector-u8-ref bv 1) #xFFFF)]) 2623 (unless (zero? n) 2624 (set! v (add1 v)) 2625 (loop (bitwise-arithmetic-shift-right n 1)))))) 2626 (define handlers (list (foreign-callable work (u8*) void) 2627 (foreign-callable work (u16*) void) 2628 (foreign-callable work (u32*) void))) 2629 (map lock-object handlers) 2630 (for-each (lambda (handler) 2631 (call_many_times_bv (foreign-callable-entry-point handler))) 2632 handlers) 2633 (map unlock-object handlers) 2634 v) 2635 103500000) 2636 2637 ;; regression test related to saving registers that hold allocated 2638 ;; callable argument 2639 (let* ([call-with-many-args (foreign-procedure "call_with_many_args" (void*) boolean)] 2640 [result #f] 2641 [cb (foreign-callable 2642 (lambda (i s1 s2 s3 s4 i2 s6 s7 i3) 2643 (set! result 2644 (and (eqv? i 0) 2645 (equal? (string->utf8 "this") s1) 2646 (equal? (string->utf8 "is") s2) 2647 (equal? (string->utf8 "working") s3) 2648 (equal? (string->utf8 "just") s4) 2649 (eqv? i2 1) 2650 (equal? (string->utf8 "fine") s6) 2651 (equal? (string->utf8 "or does it?") s7) 2652 (eqv? i3 2)))) 2653 (int u8* u8* u8* u8* int u8* u8* int) 2654 void)]) 2655 (with-object-kept-live 2656 cb 2657 (call-with-many-args (foreign-callable-entry-point cb))) 2658 result) 2659 2660) 2661 2662(machine-case 2663 [(i3nt ti3nt) 2664 (mat i3nt-stdcall-foreign-callable 2665 (equal? 2666 (let () 2667 (define Sinvoke2 2668 (foreign-procedure "Sinvoke2_stdcall" 2669 (scheme-object scheme-object iptr) 2670 scheme-object)) 2671 (define Fcons 2672 (foreign-callable __stdcall 2673 (lambda (x y) 2674 (collect) 2675 (let ([ls (make-list 20000 #\z)]) 2676 (collect) 2677 (collect) 2678 (collect) 2679 (collect) 2680 (collect) 2681 (cons (length ls) (cons x y)))) 2682 (scheme-object iptr) 2683 scheme-object)) 2684 (define (go) (Sinvoke2 Fcons 4 5)) 2685 (go)) 2686 '(20000 4 . 5)) 2687 (eqv? 2688 (let () 2689 (define Sinvoke2 2690 (foreign-procedure "Sinvoke2_stdcall" 2691 (scheme-object scheme-object iptr) 2692 scheme-object)) 2693 (define fxFsum 2694 (foreign-callable __stdcall 2695 (lambda (x y) 2696 (if (fx= x 0) 2697 y 2698 (fx+ x (Sinvoke2 fxFsum (fx- x 1) y)))) 2699 (scheme-object iptr) 2700 scheme-object)) 2701 (define (fxgosum n) (Sinvoke2 fxFsum n 0)) 2702 (fxgosum 20)) 2703 210) 2704 (eqv? 2705 (let () 2706 (define Sinvoke2 2707 (foreign-procedure "Sinvoke2_stdcall" 2708 (scheme-object scheme-object iptr) 2709 scheme-object)) 2710 (define Fsum 2711 (foreign-callable __stdcall 2712 (lambda (x y) 2713 (if (= x 0) 2714 y 2715 (+ x (Sinvoke2 Fsum (- x 1) y)))) 2716 (scheme-object iptr) 2717 scheme-object)) 2718 (define (gosum n) (Sinvoke2 Fsum n (most-positive-fixnum))) 2719 (gosum 20)) 2720 536871121)) 2721 (mat i3nt-com 2722 (eqv? 2723 (let () 2724 (define com-instance ((foreign-procedure "get_com_instance" () iptr))) 2725 ((foreign-procedure __com 0 (iptr int) int) com-instance 3) 2726 ((foreign-procedure __com 4 (iptr int) int) com-instance 17)) 2727 37))]) 2728 2729(mat die-gracefully-without-stderr 2730 (let-values ([(to-stdin from-stdout from-stderr pid) 2731 (open-process-ports (format "~a -q" (patch-exec-path *scheme*)) 2732 (buffer-mode block) 2733 (native-transcoder))]) 2734 (fprintf to-stdin "(error #f \"oops 1\")\n") 2735 (flush-output-port to-stdin) 2736 (let ([s1 (get-line from-stderr)]) 2737 (close-port from-stderr) 2738 (fprintf to-stdin "(error #f \"oops 2\")\n") ; this message should disappear 2739 (flush-output-port to-stdin) 2740 (fprintf to-stdin "(+ 17 44)\n") 2741 (flush-output-port to-stdin) 2742 (let ([s2 (get-line from-stdout)]) 2743 (fprintf to-stdin "(reset-handler abort)\n") 2744 (fprintf to-stdin "(reset-handler)\n") 2745 (flush-output-port to-stdin) 2746 (let ([s3 (get-line from-stdout)]) 2747 (close-port from-stdout) 2748 (fprintf to-stdin "'hello\n") ; should cause exception, then abort (via reset) 2749 (flush-output-port to-stdin) 2750 (let ([pid^ (machine-case 2751 [(i3nt ti3nt a6nt ta6nt) pid] 2752 [else ((foreign-procedure "waitpid" (int (* int) int) int) pid (make-ftype-pointer int 0) 0)])]) 2753 (and 2754 (equal? s1 "Exception: oops 1") 2755 (equal? s2 "61") 2756 (equal? s3 "#<procedure abort>") 2757 (eqv? pid^ pid))))))) 2758) 2759 2760(mat varargs 2761 (begin 2762 (define load-libc 2763 (machine-case 2764 [(i3ob ti3ob a6ob ta6ob a6s2 ta6s2 i3s2 ti3s2 i3qnx ti3qnx i3nb ti3nb a6nb ta6nb) 2765 '(load-shared-object "libc.so")] 2766 [(i3le ti3le a6le ta6le arm32le tarm32le arm64le tarm64le ppc32le tppc32le) 2767 '(load-shared-object "libc.so.6")] 2768 [(i3fb ti3fb a6fb ta6fb) 2769 '(load-shared-object "libc.so.7")] 2770 [(i3nt ti3nt a6nt ta6nt) 2771 '(load-shared-object "msvcrt.dll")] 2772 [(i3osx ti3osx a6osx ta6osx ppc32osx tppc32osx arm64osx tarm64osx) 2773 '(load-shared-object "libc.dylib")] 2774 [else (error 'load-libc "unrecognized machine type ~s" (machine-type))])) 2775 (define varargs_df (foreign-procedure (__varargs_after 1) "varargs_df" (double int int) double)) 2776 (define varargs_dfii (foreign-procedure (__varargs_after 2) "varargs_dfii" (double int int) double)) 2777 (define varargs_dfidf (foreign-procedure (__varargs_after 2) "varargs_dfidf" (double int double) double)) 2778 (define varargs_sfdfi (foreign-procedure (__varargs_after 2) "varargs_sfdfi" (float double int) double)) 2779 (define varargs_i7df (foreign-procedure (__varargs_after 1) "varargs_i7df" (int double double double double double double double) 2780 double)) 2781 #t) 2782 (equal? 2783 (with-input-from-string 2784 (separate-eval 2785 `(begin 2786 ,load-libc 2787 (define f (foreign-procedure __varargs "printf" (string double) int)) 2788 (f "(%g)" 3.5) 2789 (void))) 2790 read) 2791 '(3.5)) 2792 (equal? 2793 (with-input-from-string 2794 (separate-eval 2795 `(begin 2796 ,load-libc 2797 (define f (foreign-procedure __varargs "printf" (string double double double double double double) int)) 2798 (f "(%g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5) 2799 (void))) 2800 read) 2801 '(3.5 2.5 -1.5 6.75 8.25 -9.5)) 2802 (equal? 2803 (with-input-from-string 2804 (separate-eval 2805 `(begin 2806 ,load-libc 2807 (define f (foreign-procedure __varargs "printf" (string double double double double double double double double) int)) 2808 (f "(%g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5) 2809 (void))) 2810 read) 2811 '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5)) 2812 (equal? 2813 (with-input-from-string 2814 (separate-eval 2815 `(begin 2816 ,load-libc 2817 (define f (foreign-procedure __varargs "printf" (string double double double double double double double double double double) int)) 2818 (f "(%g %g %g %g %g %g %g %g %g %g)" 3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5) 2819 (void))) 2820 read) 2821 '(3.5 2.5 -1.5 6.75 8.25 -9.5 1e32 -4.5 7.25 -0.5)) 2822 2823 (equal? (let ([cb (foreign-callable __varargs 2824 (lambda (x y) (+ x y 5)) 2825 (double-float double-float) double-float)]) 2826 (with-object-kept-live 2827 cb 2828 ((foreign-procedure __varargs (foreign-callable-entry-point cb) 2829 (double-float double-float) double-float) 2830 3.4 5.5))) 2831 13.9) 2832 (equal? (let ([cb (foreign-callable __varargs 2833 (lambda (x y) (+ x y 5)) 2834 (double-float double-float) single-float)]) 2835 (with-object-kept-live 2836 cb 2837 ((foreign-procedure __varargs (foreign-callable-entry-point cb) 2838 (double-float double-float) single-float) 2839 3.5 -5.25))) 2840 3.25) 2841 2842 (equal? 2843 (varargs_df 13.5 7 10) 2844 30.5) 2845 (equal? 2846 (varargs_dfii 13.5 -7 -10) 2847 -3.5) 2848 (equal? 2849 (varargs_dfidf 13.5 10 7.5) 2850 31.0) 2851 (equal? 2852 (varargs_sfdfi 10.5 3.25 8) 2853 21.75) 2854 (equal? 2855 (varargs_i7df 1 2.0 3.0 4.0 5.0 6.0 7.0 8.0) 2856 36.0) 2857) 2858 2859(mat structs 2860 (begin 2861 (define-ftype i8 integer-8) 2862 (define-ftype u8 unsigned-8) 2863 (define-ftype u16 unsigned-16) 2864 (define-ftype i64 integer-64) 2865 (define-syntax check* 2866 (syntax-rules () 2867 [(_ (conv ...) T s [vi ...] [T-ref ...] [T-set! ...]) 2868 (let () 2869 (define-ftype callback (function conv ... ((& T)) double)) 2870 (define-ftype callback-two (function conv ... ((& T) (& T)) double)) 2871 (define-ftype pre-int-callback (function conv ... (int (& T)) double)) 2872 (define-ftype pre-double-callback (function conv ... (double (& T)) double)) 2873 (define-ftype callback-r (function conv ... () (& T))) 2874 (define get (foreign-procedure conv ... (format "f4_get~a" s) 2875 () (& T))) 2876 (define sum (foreign-procedure conv ... (format "f4_sum~a" s) 2877 ((& T)) double)) 2878 (define sum_two (foreign-procedure conv ... (format "f4_sum_two~a" s) 2879 ((& T) (& T)) double)) 2880 (define sum_pre_int (foreign-procedure conv ... (format "f4_sum_pre_int~a" s) 2881 (int (& T)) double)) 2882 (define sum_pre_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int~a" s) 2883 (int int (& T)) double)) 2884 (define sum_pre_int_int_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int_int_int~a" s) 2885 (int int int int (& T)) double)) 2886 (define sum_pre_int_int_int_int_int_int (foreign-procedure conv ... (format "f4_sum_pre_int_int_int_int_int_int~a" s) 2887 (int int int int int int (& T)) double)) 2888 (define sum_post_int (foreign-procedure conv ... (format "f4_sum~a_post_int" s) 2889 ((& T) int) double)) 2890 (define sum_pre_double (foreign-procedure conv ... (format "f4_sum_pre_double~a" s) 2891 (double (& T)) double)) 2892 (define sum_pre_double_double (foreign-procedure conv ... (format "f4_sum_pre_double_double~a" s) 2893 (double double (& T)) double)) 2894 (define sum_pre_double_double_double_double (foreign-procedure conv ... (format "f4_sum_pre_double_double_double_double~a" s) 2895 (double double double double (& T)) double)) 2896 (define sum_pre_double_double_double_double_double_double_double_double 2897 (foreign-procedure conv ... (format "f4_sum_pre_double_double_double_double_double_double_double_double~a" s) 2898 (double double double double double double double double (& T)) double)) 2899 (define sum_post_double (foreign-procedure conv ... (format "f4_sum~a_post_double" s) 2900 ((& T) double) double)) 2901 (define cb_send (foreign-procedure conv ... (format "f4_cb_send~a" s) 2902 ((* callback)) double)) 2903 (define cb_send_two (foreign-procedure conv ... (format "f4_cb_send_two~a" s) 2904 ((* callback-two)) double)) 2905 (define cb_send_pre_int (foreign-procedure conv ... (format "f4_cb_send_pre_int~a" s) 2906 ((* pre-int-callback)) double)) 2907 (define cb_send_pre_double (foreign-procedure conv ... (format "f4_cb_send_pre_double~a" s) 2908 ((* pre-double-callback)) double)) 2909 (define sum_cb (foreign-procedure conv ... (format "f4_sum_cb~a" s) 2910 ((* callback-r)) double)) 2911 (define-syntax with-callback 2912 (syntax-rules () 2913 [(_ ([id rhs]) 2914 body) 2915 (let ([id rhs]) 2916 (let ([v body]) 2917 (unlock-object 2918 (foreign-callable-code-object 2919 (ftype-pointer-address id))) 2920 v))])) 2921 (and (let ([v (make-ftype-pointer T (malloc_at_boundary (ftype-sizeof T)))]) 2922 (get v) 2923 (and (= (T-ref v) vi) 2924 ... 2925 (begin 2926 (free_at_boundary (ftype-pointer-address v)) 2927 #t))) 2928 (let ([a (make-ftype-pointer T (malloc_at_boundary (ftype-sizeof T)))]) 2929 (T-set! a) ... 2930 (and (= (+ vi ...) (sum a)) 2931 (= (+ vi ... vi ...) (sum_two a a)) 2932 (= (+ 8 vi ...) (sum_pre_int 8 a)) 2933 (= (+ 8 9 vi ...) (sum_pre_int_int 8 9 a)) 2934 (= (+ 8 9 10 11 vi ...) (sum_pre_int_int_int_int 8 9 10 11 a)) 2935 (= (+ 8 9 10 11 12 13 vi ...) (sum_pre_int_int_int_int_int_int 8 9 10 11 12 13 a)) 2936 (= (+ 8 vi ...) (sum_post_int a 8)) 2937 (= (+ 8.25 vi ...) (sum_pre_double 8.25 a)) 2938 (= (+ 8.25 9.25 vi ...) (sum_pre_double_double 8.25 9.25 a)) 2939 (= (+ 8.25 9.25 10.25 11.25 vi ...) (sum_pre_double_double_double_double 8.25 9.25 10.25 11.25 a)) 2940 (= (+ 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 vi ...) 2941 (sum_pre_double_double_double_double_double_double_double_double 2942 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 a)) 2943 (= (+ 8.25 vi ...) (sum_post_double a 8.25)) 2944 (= (+ 1.0 vi ...) (with-callback ([cb (make-ftype-pointer 2945 callback 2946 (lambda (r) 2947 (exact->inexact (+ (T-ref r) ...))))]) 2948 (cb_send cb))) 2949 (= (+ 1.0 vi ... vi ...) (with-callback ([cb (make-ftype-pointer 2950 callback-two 2951 (lambda (r1 r2) 2952 (exact->inexact (+ (T-ref r1) ... 2953 (T-ref r2) ...))))]) 2954 (cb_send_two cb))) 2955 (= (+ 1.0 8 vi ...) (with-callback ([cb (make-ftype-pointer 2956 pre-int-callback 2957 (lambda (v r) 2958 (exact->inexact (+ v (T-ref r) ...))))]) 2959 (cb_send_pre_int cb))) 2960 (= (+ 1.0 8.25 vi ...) (with-callback ([cb (make-ftype-pointer 2961 pre-double-callback 2962 (lambda (v r) 2963 (exact->inexact (+ v (T-ref r) ...))))]) 2964 (cb_send_pre_double cb))) 2965 (= (+ vi ...) (with-callback ([cb (make-ftype-pointer 2966 callback-r 2967 (lambda (r) 2968 (T-set! r) ...))]) 2969 (sum_cb cb))) 2970 (begin 2971 (free_at_boundary (ftype-pointer-address a)) 2972 #t)))))])) 2973 (define-syntax check*t 2974 (syntax-rules () 2975 [(_ arg ...) 2976 (and (check* () arg ...) 2977 (check* (__collect_safe) arg ...))])) 2978 (define-syntax check-n 2979 (syntax-rules () 2980 [(_ [ni ti vi] ...) 2981 (let () 2982 (define-ftype T (struct [ni ti] ...)) 2983 (define s (apply string-append 2984 "_struct" 2985 (let loop ([l '(ti ...)]) 2986 (cond 2987 [(null? l) '()] 2988 [else (cons (format "_~a" (car l)) 2989 (loop (cdr l)))])))) 2990 (check*t T s 2991 [vi ...] 2992 [(lambda (a) (ftype-ref T (ni) a)) ...] 2993 [(lambda (a) (ftype-set! T (ni) a vi)) ...]))])) 2994 (define-syntax check 2995 (syntax-rules () 2996 [(_ t1 v1) 2997 (check*t t1 (format "_~a" 't1) 2998 [v1] 2999 [(lambda (a) (ftype-ref t1 () a))] 3000 [(lambda (a) (ftype-set! t1 () a v1))])])) 3001 (define-syntax check-union 3002 (syntax-rules () 3003 [(_ [n0 t0 v0] [ni ti vi] ...) 3004 (let () 3005 (define-ftype T (union [n0 t0] [ni ti] ...)) 3006 (define s (apply string-append 3007 "_union" 3008 (let loop ([l '(t0 ti ...)]) 3009 (cond 3010 [(null? l) '()] 3011 [else (cons (format "_~a" (car l)) 3012 (loop (cdr l)))])))) 3013 (check*t T s 3014 [v0] 3015 [(lambda (a) (ftype-ref T (n0) a))] 3016 [(lambda (a) (ftype-set! T (n0) a v0))]))])) 3017 (define-syntax check-1 3018 (syntax-rules () 3019 [(_ t1 v1) 3020 (check-n [x t1 v1])])) 3021 (define-syntax check-2 3022 (syntax-rules () 3023 [(_ t1 t2 v1 v2) 3024 (check-n [x t1 v1] [y t2 v2])])) 3025 (define-syntax check-2-set 3026 (syntax-rules () 3027 [(_ t x) 3028 (and 3029 (check-2 t i8 (+ 1 x) 10) 3030 (check-2 t short (+ 2 x) 20) 3031 (check-2 t long (+ 3 x) 30) 3032 (check-2 t i64 (+ 5 x) 50) 3033 (check-2 short t 6 (+ 60 x)) 3034 (check-2 long t 7 (+ 70 x)) 3035 (check-2 i64 t 9 (+ 90 x)) 3036 (check-2 i8 t 10 (+ 100 x)))])) 3037 (define-syntax check-3 3038 (syntax-rules () 3039 [(_ t1 t2 t3 v1 v2 v3) 3040 (check-n [x t1 v1] [y t2 v2] [z t3 v3])])) 3041 (define-syntax check-3-set 3042 (syntax-rules () 3043 [(_ t x) 3044 (and 3045 (check-3 t i8 int (+ 1 x) 10 100) 3046 (check-3 t short int (+ 2 x) 20 200) 3047 (check-3 t long int (+ 3 x) 30 300) 3048 (check-3 t i64 int (+ 5 x) 50 500) 3049 (check-3 short t int 6 (+ 60 x) 600) 3050 (check-3 long t int 7 (+ 70 x) 700) 3051 (check-3 i64 t int 9 (+ 90 x) 900) 3052 (check-3 i8 t int 10 (+ 100 x) 1000))])) 3053 (define malloc_at_boundary (foreign-procedure "malloc_at_boundary" 3054 (int) uptr)) 3055 (define free_at_boundary (foreign-procedure "free_at_boundary" 3056 (uptr) void)) 3057 #t) 3058 (check i8 -11) 3059 (check u8 129) 3060 (check short -22) 3061 (check u16 33022) 3062 (check long 33) 3063 (check int 44) 3064 (check i64 49) 3065 (check float 55.0) 3066 (check double 66.0) 3067 (check-1 i8 -12) 3068 (check-1 u8 212) 3069 (check-1 short -23) 3070 (check-1 u16 33023) 3071 (check-1 long 34) 3072 (check-1 int 45) 3073 (check-1 i64 48) 3074 (check-1 float 56.0) 3075 (check-1 double 67.0) 3076 (check-2-set int 0) 3077 (check-2-set float 0.5) 3078 (check-2-set double 0.25) 3079 (check-2 int int 4 40) 3080 (check-2 float float 4.5 40.5) 3081 (check-2 double double 4.25 40.25) 3082 (check-3-set int 0) 3083 (check-3-set float 0.5) 3084 (check-3-set double 0.25) 3085 (check-3 i8 i8 i8 4 38 127) 3086 (check-3 short short short 4 39 399) 3087 (check-3 int int int 4 40 400) 3088 (check-3 float float float 4.5 40.5 400.5) 3089 (check-3 double double double 4.25 40.25 400.25) 3090 (check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5]) 3091 (check-n [x i8 1] [y i8 2] [z i8 3] [w i8 4] [q i8 5] [r i8 6] [s i8 7]) 3092 (check-union [x i8 -17]) 3093 (check-union [x u8 217]) 3094 (check-union [x short -27]) 3095 (check-union [x u16 33027]) 3096 (check-union [x long 37]) 3097 (check-union [x int 47]) 3098 (check-union [x i64 49]) 3099 (check-union [x float 57.0]) 3100 (check-union [x double 77.0]) 3101 (check-union [x i8 18] [y int 0]) 3102 (check-union [x short 28] [y int 0]) 3103 (check-union [x long 38] [y int 0]) 3104 (check-union [x int 48] [y int 0]) 3105 (check-union [x i64 43] [y int 0]) 3106 (check-union [x float 58.0] [y int 0]) 3107 (check-union [x double 68.0] [y int 0]) 3108 3109 ;; Check that `__collect_safe` saves argument and result floating-point registers 3110 ;; while activating and deactivating a thread 3111 (let () 3112 (define-ftype T (struct [d double] [i integer-8] [n int])) 3113 (define sum_pre_double_double_double_double_double_double_double_double 3114 (foreign-procedure __collect_safe 3115 "f4_sum_pre_double_double_double_double_double_double_double_double_struct_double_i8_int" 3116 (double double double double double double double double (& T)) 3117 double)) 3118 (let* ([p (foreign-alloc (ftype-sizeof T))] 3119 [a (make-ftype-pointer T p)]) 3120 (ftype-set! T (d) a 1.25) 3121 (ftype-set! T (i) a 10) 3122 (ftype-set! T (n) a 100) 3123 (let loop ([i 1000000]) 3124 (cond 3125 [(zero? i) (foreign-free p) #t] 3126 [else 3127 (let ([v (sum_pre_double_double_double_double_double_double_double_double 8.25 9.25 10.25 11.25 12.25 13.25 14.25 15.25 a)]) 3128 (and (= 205.25 v) 3129 (loop (sub1 i))))])))) 3130 (let () 3131 (define-ftype T (struct [d double] [i integer-8] [n int])) 3132 (define-ftype callback (function __collect_safe ((& T)) double)) 3133 (define cb_send (foreign-procedure __collect_safe 3134 "f4_cb_send_struct_double_i8_int" 3135 ((* callback)) double)) 3136 (let ([cb (make-ftype-pointer 3137 callback 3138 (lambda (r) 3139 (+ (ftype-ref T (d) r) 3140 (ftype-ref T (i) r) 3141 (ftype-ref T (n) r))))]) 3142 (let loop ([i 1000000]) 3143 (cond 3144 [(zero? i) 3145 (unlock-object 3146 (foreign-callable-code-object 3147 (ftype-pointer-address cb))) 3148 #t] 3149 [else 3150 (let ([v (cb_send cb)]) 3151 (and (= v 112.25) 3152 (loop (sub1 i))))])))) 3153 ) 3154 3155(mat collect-safe 3156 (error? (foreign-procedure __collect_safe "unknown" (utf-8) void)) 3157 (error? (foreign-procedure __collect_safe "unknown" (utf-16be) void)) 3158 (error? (foreign-procedure __collect_safe "unknown" (utf-16le) void)) 3159 (error? (foreign-procedure __collect_safe "unknown" (utf-32be) void)) 3160 (error? (foreign-procedure __collect_safe "unknown" (utf-32le) void)) 3161 (error? (foreign-procedure __collect_safe "unknown" (string) void)) 3162 (error? (foreign-procedure __collect_safe "unknown" (wstring) void)) 3163 (error? (foreign-callable __collect_safe (lambda () #f) () utf-8)) 3164 (error? (foreign-callable __collect_safe (lambda () #f) () utf-16le)) 3165 (error? (foreign-callable __collect_safe (lambda () #f) () utf-16be)) 3166 (error? (foreign-callable __collect_safe (lambda () #f) () utf-32le)) 3167 (error? (foreign-callable __collect_safe (lambda () #f) () utf-32be)) 3168 (error? (foreign-callable __collect_safe (lambda () #f) () string)) 3169 (error? (foreign-callable __collect_safe (lambda () #f) () wstring)) 3170 (begin 3171 (define-ftype thread-callback-T (function __collect_safe (double) double)) 3172 (define (call-with-thread-callback cb-proc proc) 3173 (let ([callback (make-ftype-pointer thread-callback-T cb-proc)]) 3174 (let ([r (proc callback)]) 3175 (unlock-object 3176 (foreign-callable-code-object 3177 (ftype-pointer-address callback))) 3178 r))) 3179 (define (call-in-unknown-thread-1 proc arg n-times) 3180 ;; Baseline implementation that uses the current thread 3181 (let loop ([i 0] [arg arg]) 3182 (cond 3183 [(= i n-times) arg] 3184 [else (loop (fx+ i 1) (proc arg))]))) 3185 (define call-in-unknown-thread-2 3186 ;; Call in the current thread, but through the foreign procedure 3187 (if (and (threaded?) 3188 (foreign-entry? "call_in_unknown_thread")) 3189 (let ([call (foreign-procedure "call_in_unknown_thread" 3190 ((* thread-callback-T) double int boolean boolean) 3191 double)]) 3192 (lambda (proc arg n-times) 3193 (call-with-thread-callback 3194 proc 3195 (lambda (callback) (call callback arg n-times #f #t))))) 3196 call-in-unknown-thread-1)) 3197 (define call-in-unknown-thread-3 3198 ;; Call in a truly unknown thread: 3199 (if (and (threaded?) 3200 (foreign-entry? "call_in_unknown_thread")) 3201 (let ([call (foreign-procedure "call_in_unknown_thread" 3202 ((* thread-callback-T) double int boolean boolean) 3203 double)]) 3204 (lambda (proc arg n-times) 3205 (call-with-thread-callback 3206 proc 3207 (lambda (callback) (call callback arg n-times #t #t))))) 3208 call-in-unknown-thread-1)) 3209 (define call-in-unknown-thread-4 3210 ;; In an truly unknown thread, but also using `__collect_safe` to 3211 ;; deactivate the current thread instead of using `Sdeactivate_thread` 3212 ;; within the foreign function: 3213 (if (and (threaded?) 3214 (foreign-entry? "call_in_unknown_thread")) 3215 (let ([call (foreign-procedure __collect_safe "call_in_unknown_thread" 3216 ((* thread-callback-T) double int boolean boolean) 3217 double)]) 3218 (lambda (proc arg n-times) 3219 (call-with-thread-callback 3220 proc 3221 (lambda (callback) (call callback arg n-times #t #f))))) 3222 call-in-unknown-thread-1)) 3223 #t) 3224 ;; These tests will pass only if `collect` can run, where `collect` 3225 ;; can run only if a single thread is active 3226 (equal? (call-in-unknown-thread-1 (lambda (n) (collect 0) (+ n 1.0)) 3.5 1) 3227 4.5) 3228 (equal? (call-in-unknown-thread-2 (lambda (n) (collect 0) (+ n 1.0)) 3.5 2) 3229 5.5) 3230 (equal? (call-in-unknown-thread-3 (lambda (n) (collect 0) (+ n 1.0)) 3.5 3) 3231 6.5) 3232 (equal? (call-in-unknown-thread-4 (lambda (n) (collect 0) (+ n 1.0)) 3.5 4) 3233 7.5) 3234 (equal? (let loop ([n 10.0]) 3235 (call-in-unknown-thread-4 3236 (lambda (n) 3237 (cond 3238 [(zero? n) (collect) 0.5] 3239 [else (+ 1.0 (loop (- n 1.0)))])) 3240 n 3241 1)) 3242 10.5) 3243 ;; Try to crash a `__collect_safe` foreign-procedure call by moving the 3244 ;; return address out from under the foreign procedure. This attempt 3245 ;; should fail, because deactivating a thread first locks the 3246 ;; current code object. 3247 (or (not (threaded?)) 3248 (let ([m (make-mutex)] 3249 [done? #f] 3250 [ok? #t]) 3251 (fork-thread (lambda () 3252 (let loop ([i 10]) 3253 (unless (zero? i) 3254 (let ([spin (eval '(foreign-procedure __collect_safe "spin_a_while" (int unsigned unsigned) unsigned))]) 3255 (spin 1000000 0 1)) 3256 (loop (sub1 i)))) 3257 (mutex-acquire m) 3258 (set! done? #t) 3259 (mutex-release m))) 3260 (let loop () 3261 (mutex-acquire m) 3262 (let ([done? done?]) 3263 (mutex-release m) 3264 (unless done? 3265 (let loop ([i 10]) 3266 (unless (zero? i) 3267 (eval '(foreign-procedure "spin_a_while" () void)) 3268 (loop (sub1 i)))) 3269 (loop)))) 3270 ok?)) 3271) 3272 3273(machine-case 3274 [(i3nt ti3nt) 3275 (mat i3nt-stdcall-collect-safe 3276 (equal? 3277 (let () 3278 (define sum (foreign-procedure __collect_safe __stdcall "_sum_stdcall@8" (int int) int)) 3279 (sum 3 7)) 3280 10) 3281 (equal? 3282 (let () 3283 (define Sinvoke2 3284 (foreign-procedure __collect_safe "Sinvoke2_stdcall" 3285 (scheme-object scheme-object iptr) 3286 scheme-object)) 3287 (define Fcons 3288 (foreign-callable __collect_safe __stdcall 3289 (lambda (x y) (cons x y)) 3290 (scheme-object iptr) 3291 scheme-object)) 3292 (Sinvoke2 Fcons 41 51)) 3293 '(41 . 51))) 3294 (mat i3nt-com-thread 3295 (eqv? 3296 (let () 3297 (define com-instance ((foreign-procedure "get_com_instance" () iptr))) 3298 ((foreign-procedure __collect_safe __com 0 (iptr int) int) com-instance 3) 3299 ((foreign-procedure __collect_safe __com 4 (iptr int) int) com-instance 17)) 3300 37))]) 3301 3302]) 3303 3304(mat reference-bytevector 3305 (error? (make-reference-bytevector -1)) 3306 (error? (bytevector-reference-ref #vu8(1 2 3) 0)) 3307 (error? (bytevector-reference-ref (make-reference-bytevector 8) -8)) 3308 (error? (bytevector-reference-ref (make-reference-bytevector 8) 'oops)) 3309 (error? (bytevector-reference*-ref (make-reference-bytevector 8) -8)) 3310 (error? (bytevector-reference*-ref (make-reference-bytevector 8) 'oops)) 3311 (error? (reference-address->object #f)) 3312 (error? (reference*-address->object #f)) 3313 3314 (not (reference-bytevector? #vu8(1 2 3))) 3315 (not (reference-bytevector? 7)) 3316 (begin 3317 (define $reftest-bv (make-reference-bytevector (* 2 (foreign-sizeof 'ptr)))) 3318 (reference-bytevector? $reftest-bv)) 3319 (eqv? (* 2 (foreign-sizeof 'ptr)) (bytevector-length $reftest-bv)) 3320 (eq? #f (bytevector-reference-ref $reftest-bv 0)) 3321 (begin 3322 (define $reftest-bv2 (bytevector 1 2 3 4 5 6)) 3323 (bytevector-reference-set! $reftest-bv 0 $reftest-bv2) 3324 (collect) 3325 (eq? $reftest-bv2 (bytevector-reference-ref $reftest-bv 0))) 3326 (with-interrupts-disabled 3327 (eqv? (if (= (foreign-sizeof 'ptr) 8) 3328 (bytevector-u64-native-ref $reftest-bv 0) 3329 (bytevector-u32-native-ref $reftest-bv 0)) 3330 (object->reference-address $reftest-bv2))) 3331 (with-interrupts-disabled 3332 (and (eq? $reftest-bv2 3333 (reference-address->object (object->reference-address $reftest-bv2))) 3334 (eq? $reftest-bv2 3335 (reference*-address->object (object->reference-address $reftest-bv2))))) 3336 (begin 3337 (define $reftest-bv3 (bytevector 5 6 7 8)) 3338 (bytevector-reference-set! $reftest-bv (foreign-sizeof 'ptr) $reftest-bv3) 3339 (collect) 3340 (eq? $reftest-bv2 (bytevector-reference-ref $reftest-bv 0))) 3341 (eq? $reftest-bv3 (bytevector-reference-ref $reftest-bv (foreign-sizeof 'ptr))) 3342 (eq? $reftest-bv3 (bytevector-reference*-ref $reftest-bv (foreign-sizeof 'ptr))) 3343 3344 (let () 3345 (lock-object $reftest-bv3) 3346 (let ([p (if (= (foreign-sizeof 'ptr) 8) 3347 (bytevector-u64-native-ref $reftest-bv 8) 3348 (bytevector-u32-native-ref $reftest-bv 4))]) 3349 (foreign-set! 'unsigned-8 p 1 77) 3350 (equal? $reftest-bv3 #vu8(5 77 7 8)))) 3351 3352 (begin 3353 (unlock-object $reftest-bv3) 3354 (define $reftest-mem4 (foreign-alloc 20)) 3355 (if (= (foreign-sizeof 'ptr) 8) 3356 (bytevector-u64-native-set! $reftest-bv 8 $reftest-mem4) 3357 (bytevector-u32-native-set! $reftest-bv 4 $reftest-mem4)) 3358 (eqv? $reftest-mem4 (bytevector-reference*-ref $reftest-bv (foreign-sizeof 'ptr)))) 3359 3360 (begin 3361 (foreign-free $reftest-mem4) 3362 (define $reftest-flv (flvector 3.0 6.0 7.0)) 3363 (bytevector-reference-set! $reftest-bv 0 $reftest-flv) 3364 (collect) 3365 (eq? $reftest-flv (bytevector-reference-ref $reftest-bv 0))) 3366 (with-interrupts-disabled 3367 (eqv? (if (= (foreign-sizeof 'ptr) 8) 3368 (bytevector-u64-native-ref $reftest-bv 0) 3369 (bytevector-u32-native-ref $reftest-bv 0)) 3370 (object->reference-address $reftest-flv))) 3371 (with-interrupts-disabled 3372 (eq? $reftest-flv 3373 (reference-address->object (object->reference-address $reftest-flv)))) 3374 3375 (let () 3376 (lock-object $reftest-flv) 3377 (let ([p (if (= (foreign-sizeof 'ptr) 8) 3378 (bytevector-u64-native-ref $reftest-bv 0) 3379 (bytevector-u32-native-ref $reftest-bv 0))]) 3380 (foreign-set! 'double p 8 77.0) 3381 (equal? $reftest-flv #vfl(3.0 77.0 7.0)))) 3382 3383 (let ([b (box 45)]) 3384 (bytevector-reference-set! $reftest-bv 0 b) 3385 (collect) 3386 (eq? b (bytevector-reference-ref $reftest-bv 0))) 3387 3388 (reference-bytevector? (make-immobile-reference-bytevector 16)) 3389 (let* ([i (make-immobile-reference-bytevector 16)] 3390 [p (#%$object-address i 0)] 3391 [cp (object->reference-address i)]) 3392 (collect) 3393 (and (eqv? p (#%$object-address i 0)) 3394 (eqv? cp (object->reference-address i)))) 3395 (let ([i (make-immobile-reference-bytevector 16)]) 3396 (bytevector-reference-set! i 0 '#(hello)) 3397 (collect) 3398 (equal? '#(hello) (bytevector-reference-ref i 0))) 3399 3400 (begin 3401 (bytevector-reference-set! $reftest-bv 0 #f) 3402 (eq? #f (bytevector-reference-ref $reftest-bv 0))) 3403) 3404 3405