From 87f05fed9597a6355b33bcaeeb1ace67987cdb1a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 14 Dec 2009 23:52:23 +0000 Subject: [PATCH] add #:save-errno option for foreign-function types svn: r17299 --- collects/mzlib/os.ss | 29 ++++-- collects/scheme/foreign.ss | 23 +++-- collects/scribblings/foreign/derived.scrbl | 4 +- collects/scribblings/foreign/misc.scrbl | 28 +++++- collects/scribblings/foreign/types.scrbl | 19 +++- doc/release-notes/mzscheme/HISTORY.txt | 3 + src/foreign/foreign.c | 101 ++++++++++++++++++++- src/foreign/foreign.ssc | 94 +++++++++++++++++-- src/mzscheme/include/scheme.h | 2 + src/mzscheme/src/schvers.h | 4 +- 10 files changed, 272 insertions(+), 35 deletions(-) diff --git a/collects/mzlib/os.ss b/collects/mzlib/os.ss index 06bdb543d9..0d76602cb2 100644 --- a/collects/mzlib/os.ss +++ b/collects/mzlib/os.ss @@ -80,21 +80,27 @@ ;; open : string int -> int (define open - (delay-ffi-obj (winize "open") #f (_fun _string _int -> _int))) + (delay-ffi-obj (winize "open") #f (_fun #:save-errno 'posix _string _int -> _int))) ;; close : int -> int (define close - (delay-ffi-obj (winize "close") #f (_fun _int -> _int))) + (delay-ffi-obj (winize "close") #f (_fun #:save-errno 'posix _int -> _int))) ;; ftruncate : int int -> int (define ftruncate (if (eq? 'windows (system-type)) - (delay-ffi-obj "_chsize" #f (_fun _int _llong -> _int)) - (delay-ffi-obj "ftruncate" #f (_fun _int _llong -> _int)))) + (delay-ffi-obj "_chsize" #f (_fun #:save-errno 'posix _int _llong -> _int)) + (delay-ffi-obj "ftruncate" #f (_fun #:save-errno 'posix _int _llong -> _int)))) ;; on-c-fail : int (-> X) int or X -(define (on-c-fail val fail-k) - (if (> val -1) val (fail-k))) +(define (on-c-fail thunk fail-k) + (let ([val (thunk)]) + (cond + [(> val -1) val] + [(= (saved-errno) (lookup-errno 'EINTR)) + ;; interrupted by a signal; retry + (on-c-fail thunk fail-k)] + [else (fail-k)]))) (define scheme_security_check_file (delay-ffi-obj "scheme_security_check_file" #f @@ -115,15 +121,20 @@ (if (path? file) (path->string file) file) SCHEME_GUARD_FILE_WRITE) (let ([fd (on-c-fail - ((force open) file O_WRONLY) + (lambda () + ((force open) file O_WRONLY)) (lambda () (error 'truncate-file "could not open file")))]) (on-c-fail - ((force ftruncate) fd size) + (lambda () + ((force ftruncate) fd size)) (lambda () ((force close) fd) (error 'truncate-file "could not truncate file"))) - ((force close) fd) + (on-c-fail + (lambda () + ((force close) fd)) + void) (void)))) (provide truncate-file) diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index 7045d05b36..97507ffad4 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -64,6 +64,7 @@ (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) (unsafe cast) ptr-offset ptr-add! offset-ptr? set-ptr-offset! + vector->cpointer flvector->cpointer saved-errno lookup-errno ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _fixint _ufixint _fixnum _ufixnum @@ -481,12 +482,13 @@ #:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f] - #:atomic? [atomic? #f]) - (_cprocedure* itypes otype abi wrapper keep atomic?)) + #:atomic? [atomic? #f] + #:save-errno [errno #f]) + (_cprocedure* itypes otype abi wrapper keep atomic? errno)) ;; for internal use (define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic?) +(define (_cprocedure* itypes otype abi wrapper keep atomic? errno) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) @@ -499,7 +501,7 @@ (if (or (null? x) (pair? x)) (cons cb x) cb)))] [(procedure? keep) (keep cb)]) cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) + (lambda (x) (and x (wrap (ffi-call x itypes otype abi errno)))))) (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: @@ -528,6 +530,7 @@ (define abi #f) (define keep #f) (define atomic? #f) + (define errno #f) (define inputs #f) (define output #f) (define bind '()) @@ -592,10 +595,11 @@ (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] ... [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) + (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?] [#:save-errno errno])))) (unless abi (set! abi #'#f)) (unless keep (set! keep #'#t)) (unless atomic? (set! atomic? #'#f)) + (unless errno (set! errno #'#f)) ;; parse known punctuation (set! xs (map (lambda (x) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) @@ -686,9 +690,9 @@ (string->symbol (string-append "ffi-wrapper:" n))) body))]) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,keep #,atomic?)) + #,abi (lambda (ffi) #,body) #,keep #,atomic? #,errno)) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,keep #,atomic?))) + #,abi #f #,keep #,atomic? #,errno))) (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) @@ -1079,6 +1083,7 @@ [TAG->list (id "" "->list")] [TAG-ref (id "" "-ref")] [TAG-set! (id "" "-set!")] + [TAG->cpointer (id "" "->cpointer")] [_TAG (id "_" "")] [_TAG* (id "_" "*")] [TAGname name] @@ -1125,6 +1130,10 @@ (raise-type-error 'TAG->list TAGname v))) (define* (list->TAG l) (make-TAG (list->cblock l type) (length l))) + (define* (TAG->cpointer v) + (if (TAG? v) + (TAG-ptr v) + (raise-type-error 'TAG->cpointer TAGname v))) ;; same as the _cvector implementation (provide _TAG) (define _TAG* diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index dcc6ba33f7..a6d22d1923 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -208,6 +208,7 @@ just aliases for byte-string bindings: @scheme[make-u8vector], [! (mk #'id "vector-set!")] [list-> (mk "list->" #'id "vector")] [->list (mk #'id "vector->list")] + [->cpointer (mk #'id "vector->cpointer")] [_vec (mk "_" #'id "vector")]) #`(begin (defproc* ([(make [len exact-nonnegative-integer?]) ?] @@ -217,7 +218,8 @@ just aliases for byte-string bindings: @scheme[make-u8vector], [(ref [vec ?][k exact-nonnegative-integer?]) number?] [(! [vec ?][k exact-nonnegative-integer?][val number?]) void?] [(list-> [lst (listof number?)]) ?] - [(->list [vec ?]) (listof number?)]) + [(->list [vec ?]) (listof number?)] + [(->cpointer [vec ?]) cpointer?]) . desc) ;; Big pain: make up relatively-correct source locations ;; for pieces in the _vec definition: diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index f8126ebf5a..f7f3226c0d 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -38,7 +38,7 @@ bindings such as @scheme[foo-bar] for foreign names like ]} -@defproc[(list->cblock [lst list>][type ctype?]) any]{ +@defproc[(list->cblock [lst list?][type ctype?]) any]{ Allocates a memory block of an appropriate size, and initializes it using values from @scheme[lst] and the given @scheme[type]. The @@ -46,10 +46,34 @@ using values from @scheme[lst] and the given @scheme[type]. The according to the given @scheme[type].} -@defproc[(vector->cblock [vector any/c][type type?]) any]{ +@defproc[(vector->cblock [vec vector?][type type?]) any]{ Like @scheme[list->cblock], but for Scheme vectors.} + +@defproc[(vector->cpointer [vec vector?]) cpointer?]{ + +Returns a pointer to an array of @scheme[_scheme] values, which is the +internal representation of @scheme[vec].} + +@defproc[(flvector->cpointer [flvec flvector?]) cpointer?]{ + +Returns a pointer to an array of @scheme[_double] values, which is the +internal representation of @scheme[flvec].} + +@defproc[(saved-errno) exact-integer?]{ + +Returns the value most recently saved (in the current thread) after a +foreign call with a non-@scheme[#f] @scheme[#:save-errno] option (see +@scheme[_fun] and @scheme[_cprocedure]).} + +@defproc[(lookup-errno [sym (or/c 'EINTR 'EEXIST 'EAGAIN)]) + exact-integer?]{ + +Returns a platform-specific value corresponding to a Posix @tt{errno} +symbol. The set of supported symbols is likely to expand in the +future.} + @; ---------------------------------------------------------------------- @section{Unsafe Miscellaneous Operations} diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 654c61aea2..46ff3a26ab 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -342,6 +342,7 @@ the later case, the result is the @scheme[ctype]).} [output-type ctype?] [#:abi abi (or/c symbol/c #f) #f] [#:atomic? atomic? any/c #f] + [#:save-errno save-errno (or/c #f 'posix 'windows) #f] [#:wrapper wrapper (or/c #f (procedure? . -> . procedure?)) #f] [#:keep keep (or/c boolean? box? (any/c . -> . any/c)) @@ -385,6 +386,19 @@ continuation jumps, and its non-tail recursion must be minimal to avoid C-level stack overflow; otherwise, the process may crash or misbehave. +If @scheme[save-errno] is @scheme['posix], then the value of +@as-index{@tt{errno}} is saved (specific to the current thread) +immediately after a foreign function returns. The saved value is +accessible through @scheme[saved-errno]. If @scheme[save-errno] is +@scheme['window], then the value of +@as-index{@tt{GetLastError}}@tt{()} is saved for later use via +@scheme[saved-errno]; the @scheme['windows] option is available only +under Windows. If @scheme[save-errno] is @scheme[#f], no error value +is saved automatically. The error-recording support provided by +@scheme[save-errno] is needed because the PLT Scheme runtime system +may otherwise preempt the current Scheme thread and itself call +functions that set error values. + The optional @scheme[wrapper], if provided, is expected to be a function that can change a callout procedure: when a callout is generated, the wrapper is applied on the newly created primitive @@ -398,7 +412,7 @@ the foreign code before they reach the Scheme procedure, and possibly changes the result values too. Sending Scheme functions as callbacks to foreign code is achieved by -translating them to a foreign ``closure'', which foreign code can call +translating them to a foreign ``closure,'' which foreign code can call as plain C functions. Additional care must be taken in case the foreign code might hold on to the callback function. In these cases you must arrange for the callback value to not be garbage-collected, @@ -450,7 +464,8 @@ values: @itemize[ @defform/subs[#:literals (-> :: :) (_fun fun-option ... maybe-args type-spec ... -> type-spec maybe-wrapper) - ([fun-option (code:line #:abi abi-expr) + ([fun-option (code:line #:abi abi-expr) + (code:line #:save-errno save-errno-expr) (code:line #:keep keep-expr) (code:line #:atomic? atomic?-expr)] [maybe-args code:blank diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index ae7d173969..89ca80bdd2 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,6 @@ +Version 4.2.3.5 +Added #:save-errno option for foreign-function types + Version 4.2.3.4 Added flvectors diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 8e3f16a838..aef77a345e 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -7,6 +7,7 @@ ********************************************/ #include "schpriv.h" +#include #ifndef WINDOWS_DYNAMIC_LOAD @@ -78,6 +79,8 @@ /* same as the macro in file.c */ #define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x)) +static void save_errno_values(int kind); + /*****************************************************************************/ /* Defining EnumProcessModules for openning `self' as an ffi-lib */ @@ -1103,7 +1106,7 @@ typedef struct ffi_callback_struct { Scheme_Object* proc; Scheme_Object* itypes; Scheme_Object* otype; - int call_in_scheduler; + char call_in_scheduler; } ffi_callback_struct; #define SCHEME_FFICALLBACKP(x) (SCHEME_TYPE(x)==ffi_callback_tag) #define MYNAME "ffi-callback?" @@ -2167,6 +2170,24 @@ static Scheme_Object *do_memop(const char *who, int mode, return scheme_void; } +#define MYNAME "vector->cpointer" +static Scheme_Object *foreign_vector_to_cpointer(int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_VECTORP(argv[0])) + scheme_wrong_type(MYNAME, "vector", 0, argc, argv); + return scheme_make_offset_cptr(argv[0], (long)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL); +} +#undef MYNAME + +#define MYNAME "flvector->cpointer" +static Scheme_Object *foreign_flvector_to_cpointer(int argc, Scheme_Object *argv[]) +{ + if (!SCHEME_FLVECTORP(argv[0])) + scheme_wrong_type(MYNAME, "flvector", 0, argc, argv); + return scheme_make_offset_cptr(argv[0], (long)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL); +} +#undef MYNAME + #define MYNAME "memset" static Scheme_Object *foreign_memset(int argc, Scheme_Object *argv[]) { @@ -2396,6 +2417,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); int nargs = cif->nargs; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we @@ -2472,6 +2494,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } /* Finally, call the function */ ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); + if (save_errno != 0) save_errno_values(save_errno); if (ivals != stack_ivals) free(ivals); ivals = NULL; /* no need now to hold on to this */ for (i=0; i (in-types -> out-value) */ +/* (ffi-call ffi-obj in-types out-type [abi save-errno?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ #define MYNAME "ffi-call" static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) @@ -2513,7 +2536,7 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) long ooff; GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; - int i, nargs; + int i, nargs, save_errno; MZ_REGISTER_STATIC(ffi_name_prefix); if (!ffi_name_prefix) ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); @@ -2530,6 +2553,22 @@ static Scheme_Object *foreign_ffi_call(int argc, Scheme_Object *argv[]) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); + if (argc > 4) { + save_errno = -1; + if (SCHEME_FALSEP(argv[4])) + save_errno = 0; + else if (SCHEME_SYMBOLP(argv[4]) + && !SCHEME_SYM_WEIRDP(argv[4])) { + if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + save_errno = 1; + else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + save_errno = 2; + } + if (save_errno == -1) { + scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv); + } + } else + save_errno = 0; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; isaved_errno = v; + return; + } + + p->saved_errno = errno; +} + +#define MYNAME "saved-errno" +static Scheme_Object *foreign_saved_errno(int argc, Scheme_Object *argv[]) +{ + Scheme_Thread *p = scheme_current_thread; + return scheme_make_integer_value(p->saved_errno); +} +#undef MYNAME + +#define MYNAME "lookup-errno" +static Scheme_Object *foreign_lookup_errno(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *v = argv[0]; + if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) { + if (!strcmp("EINTR", SCHEME_SYM_VAL(v))) + return scheme_make_integer(EINTR); + if (!strcmp("EEXIST", SCHEME_SYM_VAL(v))) + return scheme_make_integer(EEXIST); + if (!strcmp("EAGAIN", SCHEME_SYM_VAL(v))) + return scheme_make_integer(EAGAIN); + } + scheme_wrong_type(MYNAME, "'EINTR, 'EEXIST, or 'EAGAIN",0, argc, argv); + return NULL; +} +#undef MYNAME + +/*****************************************************************************/ + void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp) { char *str; @@ -2853,6 +2936,10 @@ void scheme_init_foreign(Scheme_Env *env) scheme_make_prim_w_arity(foreign_ptr_offset, "ptr-offset", 1, 1), menv); scheme_add_global("set-ptr-offset!", scheme_make_prim_w_arity(foreign_set_ptr_offset_bang, "set-ptr-offset!", 2, 3), menv); + scheme_add_global("vector->cpointer", + scheme_make_prim_w_arity(foreign_vector_to_cpointer, "vector->cpointer", 1, 1), menv); + scheme_add_global("flvector->cpointer", + scheme_make_prim_w_arity(foreign_flvector_to_cpointer, "flvector->cpointer", 1, 1), menv); scheme_add_global("memset", scheme_make_prim_w_arity(foreign_memset, "memset", 3, 5), menv); scheme_add_global("memmove", @@ -2868,9 +2955,13 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("make-sized-byte-string", scheme_make_prim_w_arity(foreign_make_sized_byte_string, "make-sized-byte-string", 2, 2), menv); scheme_add_global("ffi-call", - scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 4), menv); + scheme_make_prim_w_arity(foreign_ffi_call, "ffi-call", 3, 5), menv); scheme_add_global("ffi-callback", scheme_make_prim_w_arity(foreign_ffi_callback, "ffi-callback", 3, 5), menv); + scheme_add_global("saved-errno", + scheme_make_prim_w_arity(foreign_saved_errno, "saved-errno", 0, 0), menv); + scheme_add_global("lookup-errno", + scheme_make_prim_w_arity(foreign_lookup_errno, "lookup-errno", 1, 1), menv); s = scheme_intern_symbol("void"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 295a0f0606..54c0041589 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -5,11 +5,13 @@ exec mzscheme "$0" > `echo "$0" | sed 's/ssc$/c/'` "$0" #lang scribble/text -@(require "ssc-utils.ss") +@(require "ssc-utils.ss" + scheme/string) @header{foreign.ssc} #include "schpriv.h" +#include @@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{ @@ -81,6 +83,8 @@ exec mzscheme "$0" > `echo "$0" | sed 's/ssc$/c/'` "$0" /* same as the macro in file.c */ #define TO_PATH(x) (SCHEME_PATHP(x) ? (x) : scheme_char_string_to_path(x)) +static void save_errno_values(int kind); + /*****************************************************************************/ /* Defining EnumProcessModules for openning `self' as an ffi-lib */ @@ -933,7 +937,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) [proc "Scheme_Object*"] [itypes "Scheme_Object*"] [otype "Scheme_Object*"] - [call_in_scheduler "int"]] + [call_in_scheduler "char"]] /*****************************************************************************/ /* Pointer objects */ @@ -1569,6 +1573,18 @@ static Scheme_Object *do_memop(const char *who, int mode, return scheme_void; } +@cdefine[vector->cpointer 1]{ + if (!SCHEME_VECTORP(argv[0])) + scheme_wrong_type(MYNAME, "vector", 0, argc, argv); + return scheme_make_offset_cptr(argv[0], (long)SCHEME_VEC_ELS((Scheme_Object *)0x0), NULL); +} + +@cdefine[flvector->cpointer 1]{ + if (!SCHEME_FLVECTORP(argv[0])) + scheme_wrong_type(MYNAME, "flvector", 0, argc, argv); + return scheme_make_offset_cptr(argv[0], (long)SCHEME_FLVEC_ELS((Scheme_Object *)0x0), NULL); +} + @cdefine[memset 3 5]{return do_memop(MYNAME, 0, argc, argv);} @cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);} @cdefine[memcpy 3 6]{return do_memop(MYNAME, 2, argc, argv);} @@ -1772,6 +1788,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) Scheme_Object *base; ffi_cif *cif = (ffi_cif*)(SCHEME_VEC_ELS(data)[4]); long cfoff = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[5]); + int save_errno = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[6]); int nargs = cif->nargs; /* When the foreign function is called, we need an array (ivals) of nargs * ForeignAny objects to store the actual C values that are created, and we @@ -1848,6 +1865,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } /* Finally, call the function */ ffi_call(cif, (VoidFun)W_OFFSET(c_func, cfoff), p, avalues); + if (save_errno != 0) save_errno_values(save_errno); if (ivals != stack_ivals) free(ivals); ivals = NULL; /* no need now to hold on to this */ for (i=0; i (in-types -> out-value) */ +/* (ffi-call ffi-obj in-types out-type [abi save-errno?]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ -@cdefine[ffi-call 3 4]{ +@cdefine[ffi-call 3 5]{ static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; @@ -1887,7 +1905,7 @@ void free_fficall_data(void *ignored, void *p) long ooff; GC_CAN_IGNORE ffi_type *rtype, **atypes; GC_CAN_IGNORE ffi_cif *cif; - int i, nargs; + int i, nargs, save_errno; MZ_REGISTER_STATIC(ffi_name_prefix); if (!ffi_name_prefix) ffi_name_prefix = scheme_make_byte_string_without_copying("ffi:"); @@ -1904,6 +1922,22 @@ void free_fficall_data(void *ignored, void *p) scheme_wrong_type(MYNAME, "C-type", 2, argc, argv); rtype = CTYPE_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); + if (argc > 4) { + save_errno = -1; + if (SCHEME_FALSEP(argv[4])) + save_errno = 0; + else if (SCHEME_SYMBOLP(argv[4]) + && !SCHEME_SYM_WEIRDP(argv[4])) { + if (!strcmp(SCHEME_SYM_VAL(argv[4]), "posix")) + save_errno = 1; + else if (!strcmp(SCHEME_SYM_VAL(argv[4]), "windows")) + save_errno = 2; + } + if (save_errno == -1) { + scheme_wrong_type(MYNAME, "'posix, 'windows, or #f", 4, argc, argv); + } + } else + save_errno = 0; atypes = malloc(nargs * sizeof(ffi_type*)); for (i=0, p=itypes; i 4) && SCHEME_TRUEP(argv[4]))"] @@@IFDEF{MZ_PRECISE_GC}{ { @@ -2082,6 +2117,51 @@ void free_cl_cif_args(void *ignored, void *p) /*****************************************************************************/ +static void save_errno_values(int kind) +{ + Scheme_Thread *p = scheme_current_thread; + + if (kind == 2) { + long v = 0; +@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ + v = GetLastError(); + } + p->saved_errno = v; + return; + } + + p->saved_errno = errno; +} + +@cdefine[saved-errno 0]{ + Scheme_Thread *p = scheme_current_thread; + return scheme_make_integer_value(p->saved_errno); +} + +@cdefine[lookup-errno 1]{ + Scheme_Object *v = argv[0]; + @(let* ([errnos '(EINTR EEXIST EAGAIN)] + [syms (let loop ([errnos errnos]) + (if (null? (cdr errnos)) + (format "or '~a" (car errnos)) + (format "'~a, ~a" (car errnos) (loop (cdr errnos)))))]) + @string-append{ + if (SCHEME_SYMBOLP(v) && !SCHEME_SYM_WEIRDP(v)) { + @(string-join + (for/list ([e errnos]) + @string-append{ + if (!strcmp("@symbol->string[e]", SCHEME_SYM_VAL(v))) + return scheme_make_integer(@symbol->string[e]); + }) + "\n") + } + scheme_wrong_type(MYNAME, "@syms",0, argc, argv); + return NULL; + }) +} + +/*****************************************************************************/ + void ctype_printer(Scheme_Object *ctype, int dis, Scheme_Print_Params *pp) { char *str; diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 32dfbaf403..2345aa50c7 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1108,6 +1108,8 @@ typedef struct Scheme_Thread { Scheme_Object *mbox_last; Scheme_Object *mbox_sema; + long saved_errno; + #ifdef MZ_PRECISE_GC struct GC_Thread_Info *gc_info; /* managed by the GC */ #endif diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index febb42eae0..b2f2ba4d54 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.3.4" +#define MZSCHEME_VERSION "4.2.3.5" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 3 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)