ctype->layout in scheme/foreign; prototype Objective-C binding in ffi collection

svn: r12890

collects/ffi/objc.ss

@@ -0,0 +1,546 @@
+#lang scheme/base
+(require scheme/foreign (only-in '#%foreign ffi-call)
+         scheme/stxparam
+         (for-syntax scheme/base))
+(unsafe!)
+
+(define objc-lib (ffi-lib "libobjc"))
+
+(define-syntax define-objc/private
+  (syntax-rules ()
+    [(_ id type)
+     (define-objc/private id id type)]
+    [(_ id c-id type)
+     (define id (get-ffi-obj 'c-id objc-lib type))]))
+
+(define-syntax-rule (define-objc id type)
+  (begin
+    (provide id)
+    (define-objc/private id id type)))
+
+;; ----------------------------------------
+
+(provide _id _BOOL _SEL)
+
+(define _id (_cpointer/null 'id))
+
+(define _SEL (_cpointer/null 'SEL))
+(define _Ivar (_cpointer/null 'Ivar))
+(define _Class (make-ctype _id
+                           (lambda (v) v)
+                           (lambda (p)
+                             (when p (cpointer-push-tag! p 'Class))
+                             p)))
+(define _BOOL (make-ctype _byte
+                          (lambda (v) (if v 1 0))
+                          (lambda (v) (not (eq? v 0)))))
+(define _IMP (_fun _id _id -> _id))
+
+(define-cstruct _objc_super ([receiver _id][class _Class]))
+
+(provide YES NO)
+(define YES #t)
+(define NO #f)
+
+;; ----------------------------------------
+
+(define-objc objc_lookUpClass (_fun _string -> _Class))
+
+(define-objc sel_registerName (_fun _string -> _SEL))
+
+(define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class))
+(define-objc objc_registerClassPair (_fun _Class -> _void))
+
+(define-objc object_getClass (_fun _id -> _Class))
+
+(provide class_addMethod)
+(define (class_addMethod cls sel imp ty enc)
+  ((get-ffi-obj 'class_addMethod objc-lib (_fun _Class _SEL ty _string -> _BOOL))
+   cls sel imp enc))
+
+(define-objc class_addIvar (_fun _Class _string _long _uint8 _string -> _BOOL))
+(define-objc object_getInstanceVariable (_fun _id _string [p : (_ptr o _pointer)]
+                                              -> [ivar : _Ivar] 
+                                              -> (values ivar p)))
+(define-objc object_setInstanceVariable (_fun _id _string _pointer -> _Ivar))
+
+(define-objc/private objc_msgSend _fpointer)
+(define-objc/private objc_msgSend_fpret _fpointer)
+(define-objc/private objc_msgSendSuper _fpointer)
+(define objc_msgSendSuper_fpret objc_msgSendSuper) ; why no fpret variant?
+
+(define (lookup-send types msgSends msgSend msgSend_fpret first-arg-type)
+  ;; First type in `types' vector is the result type
+  (or (hash-ref msgSends types #f)
+      (let ([m (ffi-call (if (memq (ctype->layout (vector-ref types 0))
+                                   '(float double double*))
+                             msgSend_fpret
+                             msgSend)
+                         (list* first-arg-type _SEL (cdr (vector->list types)))
+                         (vector-ref types 0))])
+        (hash-set! msgSends types m)
+        m)))
+
+(define msgSends (make-hash))
+(define (objc_msgSend/typed types)
+  (lookup-send types msgSends objc_msgSend objc_msgSend_fpret _id))
+(provide objc_msgSend/typed)
+
+(define msgSendSupers (make-hash))
+(define (objc_msgSendSuper/typed types)
+  (lookup-send types msgSendSupers objc_msgSendSuper objc_msgSendSuper_fpret _pointer))
+(provide objc_msgSendSuper/typed)
+
+;; ----------------------------------------
+
+(provide import-class)
+(define-syntax (import-class stx)
+  (syntax-case stx ()
+    [(_ id)
+     (quasisyntax/loc stx
+       (define id (objc_lookUpClass #,(symbol->string (syntax-e #'id)))))]
+    [(_ id ...)
+     (syntax/loc stx (begin (import-class id) ...))]))
+
+;; ----------------------------------------
+;; iget-value and iset-value work only with fields that contain Scheme values
+
+(provide iget-value iset-value)
+
+(define-for-syntax (check-ivar ivar stx)
+  (unless (identifier? ivar)
+    (raise-type-error #f
+                      "expected an identifier for an instance-variable name"
+                      stx
+                      ivar)))
+
+(define-syntax (iget-value stx)
+  (syntax-case stx ()
+    [(_ obj ivar)
+     (begin
+       (check-ivar #'ivar stx)
+       (quasisyntax/loc stx
+         (get-ivar-value obj #,(symbol->string (syntax-e #'ivar)))))]))
+
+(define (get-ivar-value obj name)
+  (let-values ([(ivar p) (object_getInstanceVariable obj name)])
+    (and p (ptr-ref p _scheme))))
+      
+
+(define-syntax (iset-value stx)
+  (syntax-case stx ()
+    [(_ obj ivar val)
+     (begin
+       (check-ivar #'ivar stx)
+       (quasisyntax/loc stx
+         (set-ivar-value obj #,(symbol->string (syntax-e #'ivar)) val)))]))
+
+(define (set-ivar-value obj name val)
+  (let-values ([(ivar p) (object_getInstanceVariable obj name)])
+    (if p
+        (ptr-set! p _scheme val)
+        (let ([p (malloc-immobile-cell val)])
+          (void (object_setInstanceVariable obj name p))))))
+
+(define (free-fields obj names)
+  (for-each (lambda (name)
+              (let-values ([(ivar p) (object_getInstanceVariable obj name)])
+                (when p (free-immobile-cell p))))
+            names))
+
+;; ----------------------------------------
+
+(define-for-syntax method-sels (make-hash))
+
+(define-for-syntax (register-selector sym)
+  (or (hash-ref method-sels (cons (syntax-local-lift-context) sym) #f)
+      (let ([id (syntax-local-lift-expression
+                 #`(sel_registerName #,(symbol->string sym)))])
+        (hash-set! method-sels sym id)
+        id)))
+
+(provide selector)
+(define-syntax (selector stx)
+  (syntax-case stx ()
+    [(_ id)
+     (begin
+       (unless (identifier? #'id)
+         (raise-syntax-error #f
+                             "expected an identifier"
+                             stx
+                             #'id))
+       (register-selector (syntax-e #'id)))]))
+
+;; ----------------------------------------
+
+(define-for-syntax (combine stxes)
+  (string->symbol
+   (apply
+    string-append
+    (map (lambda (e) (symbol->string (syntax-e e)))
+         (syntax->list stxes)))))
+
+(define-for-syntax (check-method-name m stx)
+  (unless (identifier? m)
+    (raise-syntax-error #f
+                        "expected an identifier for the method name"
+                        stx
+                        m)))
+
+(define-for-syntax (check-id-colon id stx)
+  (unless (regexp-match #rx":$" (symbol->string (syntax-e id)))
+    (raise-syntax-error #f
+                        "expected an identifier that ends in `:' to tag an argument"
+                        stx
+                        id)))
+
+(define-for-syntax (parse-arg-list l stx formals?)
+  (define (is-typed? l)
+    (if formals?
+        (and (pair? (cdr l))
+             (let ([l (syntax->list (cadr l))])
+               (and (list? l)
+                    (= 2 (length l)))))
+        (and (pair? (cdr l))
+             (eq? '#:type (syntax-e (cadr l))))))
+  (let loop ([l l])
+    (if (null? l)
+        null
+        (begin
+          (unless (identifier? (car l))
+            (raise-syntax-error #f
+                                "expected an identifier to tag an argument"
+                                stx
+                                (car l)))
+          (check-id-colon (car l) stx)
+          (let ([tag (car l)]
+                [type (if (is-typed? l)
+                          (if formals?
+                              (car (syntax-e (cadr l)))
+                              (if (pair? (cddr l))
+                                  (caddr l)
+                                  (raise-syntax-error #f
+                                                      "missing type expression after tag with #:type"
+                                                      stx
+                                                      (car l))))
+                          #'_id)]
+                [rest (if formals?
+                          (cdr l)
+                          (if (is-typed? l)
+                              (cdddr l)
+                              (cdr l)))])
+            (unless (pair? rest)
+              (raise-syntax-error #f
+                                  (format "missing an argument~a after tag"
+                                          (if formals? " identifier" " expression"))
+                                  stx
+                                  tag))
+            (cons
+             (list tag type (let ([arg (car rest)])
+                              (if formals?
+                                  (if (identifier? arg)
+                                      arg
+                                      (let ([l (syntax->list arg)])
+                                        (unless (and (list? l)
+                                                     (= 2 (length l))
+                                                     (identifier? (cadr l)))
+                                          (raise-syntax-error #f
+                                                              (string-append
+                                                               "exepected an identifier for an argument name"
+                                                               " or a parenthesized type--identifier sequence")
+                                                              stx
+                                                              arg))
+                                        (cadr l)))
+                                  arg)))
+             (loop (cdr rest))))))))
+
+(provide tell)
+(define-for-syntax (build-send stx result-type send/typed send-args l-stx)
+  (let ([l (syntax->list  l-stx)])
+    (with-syntax ([((tag type arg) ...) (parse-arg-list l stx #f)]
+                  [send send/typed]
+                  [(send-arg ...) send-args])
+      (quasisyntax/loc stx
+        ((send (type-vector #,result-type type ...))
+         send-arg ... #,(register-selector (combine #'(tag ...)))
+         arg ...)))))
+
+(define-syntax (tell stx)
+  (syntax-case stx ()
+    [(_ target)
+     (raise-syntax-error #f
+                         "method identifier missing"
+                         stx)]
+    [(_ #:type t)
+     (raise-syntax-error #f
+                         "method target object missing"
+                         stx)]
+    [(_ #:type t target)
+     (raise-syntax-error #f
+                         "method identifier missing"
+                         stx)]
+    [(_ #:type t target method)
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSend/typed (type-vector t)) target #,(register-selector (syntax-e m)))))]
+    [(_ target method)
+     (not (keyword? (syntax-e #'target)))
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSend/typed (type-vector _id)) target #,(register-selector (syntax-e m)))))]
+    [(_ #:type result-type target method/arg ...)
+     (build-send stx #'result-type 
+                 #'objc_msgSend/typed #'(target)
+                 #'(method/arg ...))]
+    [(_ target method/arg ...)
+     (build-send stx #'_id 
+                 #'objc_msgSend/typed #'(target)
+                 #'(method/arg ...))]))
+
+(define-for-syntax liftable-type?
+  (let ([prims 
+         (syntax->list #'(_id _Class _SEL _void _int _long _float _double _double* _BOOL))])
+    (lambda (t)
+      (and (identifier? t)
+           (ormap (lambda (p) (free-identifier=? t p))
+                  prims)))))
+
+(define-syntax (type-vector stx)
+  (let ([types (cdr (syntax->list stx))])
+    ((if (andmap liftable-type? (cdr (syntax->list stx)))
+         (lambda (e)
+           (syntax-local-lift-expression #`(intern-type-vector #,e)))
+         values)
+     (quasisyntax/loc stx (vector . #,types)))))
+
+(define type-vectors (make-hash))
+(define (intern-type-vector v)
+  (or (hash-ref type-vectors v #f)
+      (begin
+        (hash-set! type-vectors v v)
+        v)))
+
+;; ----------------------------------------
+
+(provide define-objc-class self super-tell)
+
+(define-syntax (define-objc-class stx)
+  (syntax-case stx ()
+    [(_ id superclass (ivar ...) method ...)
+     (begin
+       (unless (identifier? #'id)
+         (raise-syntax-error #f
+                             "expected an identifier for class definition"
+                             stx
+                             #'id))
+       (for-each (lambda (ivar)
+                   (unless (identifier? ivar)
+                     (raise-syntax-error #f
+                                         "expected an identifier for an instance variable"
+                                         stx
+                                         ivar)))
+                 (syntax->list #'(ivar ...)))
+       (let ([ivars (syntax->list #'(ivar ...))]
+             [methods (syntax->list #'(method ...))])
+         (with-syntax ([id-str (symbol->string (syntax-e #'id))]
+                       [whole-stx stx]
+                       [(dealloc-method ...)
+                        (if (null? ivars)
+                            ;; no need to override dealloc:
+                            #'()
+                            ;; add dealloc if it's not here:
+                            (if (ormap (lambda (m)
+                                         (syntax-case m ()
+                                           [(+/- result-type (id . _) . _)
+                                            (eq? (syntax-e #'id) 'dealloc)]))
+                                       methods)
+                                ;; Given a dealloc extension:
+                                #'()
+                                ;; Need to add one explicitly:
+                                #'((- _void (dealloc) (void)))))])
+           (syntax/loc stx
+             (begin
+               (define superclass-id superclass)
+               (define id (objc_allocateClassPair superclass-id id-str 0))
+               (add-ivar id 'ivar) ...
+               (let-syntax ([ivar (make-ivar-form 'ivar)] ...)
+                 (add-method whole-stx id superclass-id method) ...
+                 (add-method whole-stx id superclass-id dealloc-method) ...
+                 (void))
+               (objc_registerClassPair id))))))]))
+
+(define-for-syntax (make-ivar-form sym)
+  (with-syntax ([sym sym])
+    (make-set!-transformer
+     (lambda (stx)
+       (syntax-case stx (set!)
+         [(set! _ val)
+          (syntax/loc stx (iset-value self sym val))]
+         [(_ arg ...)
+          (quasisyntax/loc stx (#,(quasisyntax/loc #'sym #'(iget-value self sym)) 
+                                arg ...))]
+         [_ (quasisyntax/loc #'sym (iget-value self sym))])))))
+
+(define (layout->string l)
+  (case l
+    [(uint8) "C"]
+    [(int8) "c"]
+    [(float) "f"]
+    [(double) "d"]
+    [(bool) "B"]
+    [(void) "v"]
+    [(bytes) "*"]
+    [(pointer fpointer string/ucs-4 string/utf-16) "?"]
+    [else
+     (cond
+      [(list? l)
+       (apply string-append 
+              (for ([l (in-list l)]
+                    [i (in-naturals)])
+                (format "f~a=~a" i (layout->string l))))]
+      [(eq? l (ctype->layout _int)) "i"]
+      [(eq? l (ctype->layout _uint)) "I"]
+      [(eq? l (ctype->layout _short)) "s"]
+      [(eq? l (ctype->layout _ushort)) "S"]
+      [(eq? l (ctype->layout _long)) "l"]
+      [(eq? l (ctype->layout _ulong)) "L"]
+      [else (error 'generate-layout "unknown layout: ~e" l)])]))
+
+(define (generate-layout rt arg-types)
+  (let ([rl (ctype->layout rt)]
+        [al (map ctype->layout arg-types)])
+    (apply
+     string-append
+     (layout->string rl)
+     "@:"
+     (map layout->string al))))
+
+(define-syntax-parameter self
+  (lambda (stx)
+    (raise-syntax-error #f
+                        "valid only within a `define-objc-class' method"
+                        stx)))
+
+(define-syntax-parameter super-class
+  (lambda (stx) #f))
+
+(define-syntax-parameter super-tell
+  (lambda (stx)
+    (raise-syntax-error #f
+                        "valid only within a `define-objc-class' method"
+                        stx)))
+
+(define-for-syntax (make-id-stx orig-id)
+  (make-set!-transformer
+   (lambda (stx)
+     (syntax-case stx (set!)
+       [(set! id v) (raise-syntax-error #f
+                                        "assignment to self identifier disallowed"
+                                        stx)]
+       [(id arg ...) (quasisyntax/loc stx (#,orig-id arg ...))]
+       [id (datum->syntax orig-id (syntax-e orig-id) stx orig-id orig-id)]))))
+
+(define-syntax (add-method stx)
+  (syntax-case stx ()
+    [(_ whole-stx cls superclass-id m)
+     (let ([stx #'whole-stx])
+       (syntax-case #'m ()
+         [(kind result-type (id arg ...) body0 body ...)
+          (or (free-identifier=? #'kind #'+)
+              (free-identifier=? #'kind #'-))
+          (let ([id #'id]
+                [args (syntax->list #'(arg ...))]
+                [in-class? (free-identifier=? #'kind #'+)])
+            (when (null? args)
+              (unless (identifier? id)
+                (raise-syntax-error #f
+                                    "expected an identifier for method name"
+                                    stx
+                                    id)))
+            (with-syntax ([((arg-tag arg-type arg-id) ...)
+                           (if (null? args)
+                               null
+                               (parse-arg-list (cons id args) stx #t))])
+              (with-syntax ([id-str (if (null? args)
+                                        (symbol->string (syntax-e id))
+                                        (symbol->string (combine #'(arg-tag ...))))]
+                            [(dealloc-body ...)
+                             (if (eq? (syntax-e id) 'dealloc)
+                                 (syntax-case stx ()
+                                   [(_ _ _ [ivar ...] . _)
+                                    (with-syntax ([(ivar-str ...)
+                                                   (map (lambda (ivar)
+                                                          (symbol->string (syntax-e ivar)))
+                                                        (syntax->list #'(ivar ...)))])
+                                      #'((free-fields self '(ivar-str ...))
+                                         (super-tell #:type _void dealloc)))]
+                                   [_ (error "oops")])
+                                 '())]
+                            [in-cls (if in-class?
+                                        #'(object_getClass cls)
+                                        #'cls)])
+                (syntax/loc stx
+                  (let ([rt result-type]
+                        [arg-id arg-type] ...)
+                    (void (class_addMethod in-cls
+                                           (sel_registerName id-str)
+                                           (save-method!
+                                            (lambda (self-id cmd arg-id ...)
+                                              (syntax-parameterize ([self (make-id-stx #'self-id)]
+                                                                    [super-class (make-id-stx #'superclass-id)]
+                                                                    [super-tell do-super-tell])
+                                                body0 body ...
+                                                dealloc-body ...)))
+                                           (_fun _id _id arg-type ... -> rt)
+                                           (generate-layout rt (list arg-id ...)))))))))]
+         [else (raise-syntax-error #f
+                                   "bad method form"
+                                   stx
+                                   #'m)]))]))
+
+(define methods (make-hasheq))
+(define (save-method! m)
+  ;; Methods are never GCed, since classes are never unregistered
+  (hash-set! methods m #t)
+  m)
+
+(define (add-ivar cls name)
+  (void (class_addIvar cls
+                       (symbol->string name)
+                       (ctype-sizeof _pointer)
+                       (sub1 (integer-length (ctype-alignof _pointer)))
+                       (layout->string (ctype->layout _pointer)))))
+
+(define-for-syntax (do-super-tell stx)
+  (syntax-case stx ()
+    [(_ #:type t)
+     (raise-syntax-error #f
+                         "method name missing"
+                         stx)]
+    [(_ #:type t method)
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSendSuper/typed (type-vector t))
+          (make-objc_super self super-class) 
+          #,(register-selector (syntax-e m)))))]
+    [(_ method)
+     (not (keyword? (syntax-e #'method)))
+     (let ([m #'method])
+       (check-method-name m stx)
+       (quasisyntax/loc stx
+         ((objc_msgSendSuper/typed (type-vector _id)) 
+          (make-objc_super self super-class)
+          #,(register-selector (syntax-e m)))))]
+    [(_ #:type result-type method/arg ...)
+     (build-send stx #'result-type 
+                 #'objc_msgSendSuper/typed
+                 #'((make-objc_super self super-class))
+                 #'(method/arg ...))]
+    [(_ method/arg ...)
+     (build-send stx #'_id
+                 #'objc_msgSendSuper/typed
+                 #'((make-objc_super self super-class))
+                 #'(method/arg ...))]))

collects/mzlib/foreign.ss

@@ -58,7 +58,7 @@
           (unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
           cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
           ptr-offset ptr-add! offset-ptr? set-ptr-offset!
-          ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string)
+          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
           _float _double _double*
@@ -1494,6 +1494,26 @@
                     (if v (apply values v) (msg/fail-thunk))))]
             [else (msg/fail-thunk)]))))
 
+;; ----------------------------------------------------------------------------
+;;
+
+(define prim-synonyms
+  #hasheq((double* . double)
+          (fixint . long)
+          (ufixint . ulong)
+          (fixnum . long)
+          (ufixnum . ulong)
+          (path . bytes)
+          (symbol . bytes)
+          (scheme . pointer)))
+
+(define (ctype->layout c)
+  (let ([b (ctype-basetype c)])
+    (cond
+     [(ctype? b) (ctype->layout b)]
+     [(list? b) (map ctype->layout b)]
+     [else (hash-ref prim-synonyms b b)])))
+
 ;; ----------------------------------------------------------------------------
 ;; Misc utilities
 

collects/scribblings/foreign/types.scrbl

@@ -35,12 +35,29 @@ otherwise.}
 
 
 @defproc*[([(ctype-sizeof [type ctype?]) exact-nonnegative-integer?]
-           [(ctype-alignof [ctype ctype?]) exact-nonnegative-integer?])]{
+           [(ctype-alignof [type ctype?]) exact-nonnegative-integer?])]{
 
 Returns the size or alignment of a given @scheme[type] for the current
 platform.}
 
 
+@defproc[(ctype->layout [type ctype?]) (flat-rec-contract rep
+                                         symbol?
+                                         (listof rep))]{
+
+Returns a value to describe the eventual C representation of the
+type. It can be any of the following symbols:
+
+@schemeblock[
+  'int8 'uint8 'int16 'uint16 'int32 'uint32 'int64 'uint64
+  'float 'double 'bool 'void 'pointer 'fpointer 
+  'bytes 'string/ucs-4 'string/utf-16
+]
+
+The result can also be a list, which describes a C struct whose
+element representations are provided in order within the list.}
+
+
 @defproc[(compiler-sizeof [sym symbol?]) exact-nonnegative-integer?]{
 
 Possible values for @scheme[symbol] are @scheme['int], @scheme['char],

src/foreign/foreign.c

@@ -1222,13 +1222,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
  * is used for both the function definition and calls, but the actual code in
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
-#ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
-#else
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset)
-#endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
  * NULL, then any pointer value (any pointer or a struct) is returned, and the
@@ -1257,7 +1250,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
          scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val);
   } else switch (CTYPE_PRIMLABEL(type)) {
     case FOREIGN_void:
-      scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      break;
     case FOREIGN_int8:
 #ifdef SCHEME_BIG_ENDIAN
       if (sizeof(Tsint8)<sizeof(int) && ret_loc) {
@@ -1600,7 +1594,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
         return NULL; /* hush the compiler */
       }
     case FOREIGN_fpointer:
-      scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      if (!ret_loc) scheme_wrong_type("Scheme->C","non-void-C-type",0,1,&(type));
+      break;
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);

src/foreign/foreign.ssc

@@ -1016,13 +1016,6 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src,
  * is used for both the function definition and calls, but the actual code in
  * the function is different: in the relevant cases zero an int and offset the
  * ptr */
-#ifdef SCHEME_BIG_ENDIAN
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset,retloc)
-#else
-#define SCHEME2C(typ,dst,delta,val,basep,_offset,retloc) \
-          scheme_to_c(typ,dst,delta,val,basep,_offset)
-#endif
 
 /* Usually writes the C object to dst and returns NULL.  When basetype_p is not
  * NULL, then any pointer value (any pointer or a struct) is returned, and the
@@ -1099,7 +1092,8 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
                 (error 'scheme->c "unhandled pointer type: ~s" ctype)
                 (~ "  if (!("(pred "val" x)")) "(wrong-type "val" stype) \\
                    "  return NULL;"))))
-          (~ "  "(wrong-type "type" "non-void-C-type")))):}
+          (~ "  if (!ret_loc) "(wrong-type "type" "non-void-C-type")
+             ~ "  break;"))):}
     case FOREIGN_struct:
       if (!SCHEME_FFIANYPTRP(val))
         scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val);