diff --git a/collects/meta/props b/collects/meta/props index c9601768da..e3769f77c5 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1830,6 +1830,7 @@ path/s is either such a string or a list of them. "collects/tests/racket/place-chan-rand-help.rkt" responsible (tewk) "collects/tests/racket/place-chan-rand.rkt" responsible (tewk) drdr:random #t "collects/tests/racket/place-channel.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) drdr:timeout 300 +"collects/tests/racket/place-channel-ffi.rkt" responsible (tewk) drdr:command-line (racket "-tm" *) "collects/tests/racket/place.rktl" responsible (tewk) drdr:command-line (racket "-f" *) "collects/tests/racket/port.rktl" drdr:command-line #f "collects/tests/racket/portlib.rktl" drdr:command-line #f diff --git a/collects/tests/racket/place-channel-ffi.rkt b/collects/tests/racket/place-channel-ffi.rkt new file mode 100644 index 0000000000..c503d32a6f --- /dev/null +++ b/collects/tests/racket/place-channel-ffi.rkt @@ -0,0 +1,42 @@ +#lang racket/base + +(require racket/place + ffi/unsafe + racket/runtime-path + (for-syntax racket/base)) + +(provide main) + +(define-runtime-path libcrypto-so + (case (system-type) + [(windows) '(so "libeay32")] + [else '(so "libcrypto")])) + +(define libcrypto + (with-handlers ([exn:fail? (lambda (exn) + (log-warning (format "warning: couldn't load OpenSSL library: ~a" + (if (exn? exn) + (exn-message exn) + exn))) + #f)]) + (ffi-lib libcrypto-so '("" "0.9.8b" "0.9.8" "0.9.7")))) + +(define-syntax-rule (define-crypto-func name func-signature) + (begin + (define name (and libcrypto (get-ffi-obj (quote name) libcrypto func-signature (lambda () #f)))) + (provide name))) + + +(define-cstruct _BN ([j1 _long] [top _int] [dmax _int] [neg _int] [flags _int])) +(define-crypto-func BN_new (_fun -> _BN-pointer)) + +(define (main) + (define bn (BN_new)) + (set-BN-j1! bn 1334) + (printf "BN-j1 ~a ~v\n" (BN-j1 bn) (cpointer-tag bn)) + (printf "BN tag ~v\n" BN-tag) + (define p (place ch + (define b (place-channel-get ch)) + (printf "Got it ~a\n" (BN-j1 b)))) + (place-channel-put p bn) + (place-wait p)) diff --git a/src/racket/src/place.c b/src/racket/src/place.c index 81503685e4..5a1d453057 100644 --- a/src/racket/src/place.c +++ b/src/racket/src/place.c @@ -997,6 +997,32 @@ static Scheme_Object *shallow_types_copy(Scheme_Object *so, Scheme_Hash_Table *h new_so = (Scheme_Object *) vec; } break; + case scheme_cpointer_type: + if (SCHEME_CPTR_FLAGS(so) & 0x1) { + if (copy) { + Scheme_Object *o; + Scheme_Object *o2; + if (SCHEME_CPTR_FLAGS(so) & 0x2) { + o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Offset_Cptr)); + SCHEME_CPTR_FLAGS(o) |= 0x2; + ((Scheme_Offset_Cptr *)o)->offset = ((Scheme_Offset_Cptr *)so)->offset; + } + else + o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Cptr)); + + o->type = scheme_cpointer_type; + SCHEME_CPTR_FLAGS(o) |= 0x1; + SCHEME_CPTR_VAL(o) = SCHEME_CPTR_VAL(so); + o2 = shallow_types_copy(SCHEME_CPTR_TYPE(so), NULL, copy, can_raise_exn); + SCHEME_CPTR_TYPE(o) = o2; + + return o; + } + } + else + bad_place_message(so); + break; + default: new_so = NULL; break; @@ -1803,6 +1829,7 @@ static void places_deserialize_worker(Scheme_Object **pso, Scheme_Hash_Table **h case scheme_windows_path_type: case scheme_flvector_type: case scheme_fxvector_type: + case scheme_cpointer_type: break; case scheme_symbol_type: break;