1;;; foreign.ss 2;;; Copyright (c) 1997 R. Kent Dybvig 3 4;;; Permission is hereby granted, free of charge, to any person obtaining a 5;;; copy of this software and associated documentation files (the "Software"), 6;;; to deal in the Software without restriction, including without limitation 7;;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 8;;; and/or sell copies of the Software, and to permit persons to whom the 9;;; Software is furnished to do so, subject to the following conditions: 10;;; 11;;; The above copyright notice and this permission notice shall be included in 12;;; all copies or substantial portions of the Software. 13;;; 14;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 19;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 20;;; DEALINGS IN THE SOFTWARE. 21 22;;; Prototype code for converting ``foreign-callable'' declarations into 23;;; C interface routines to support C calls to Scheme procedures with 24;;; automatic datatype conversion analogous to that provided for Scheme 25;;; calls to C procedures via foreign-procedure. 26 27;;; Todo 28;;; - support for foreign-pointer and foreign-object 29;;; - similar support for foreign-procedure declarations 30 31(define spec->decl 32 (lambda (spec) 33 (case spec 34 [(integer-32 boolean) "int"] 35 [(unsigned-32) "unsigned int"] 36 [(char) "char"] 37 [(string) "char *"] 38 [(fixnum) "int"] 39 [(double-float) "double"] 40 [(single-float) "float"] 41 [(void) "void"] 42 [(scheme-object) "ptr"] 43 [else 44 (record-case spec 45 [(foreign-pointer foreign-object) () 46 (error 'spec->decl "unsupported specifier ~s" spec)] 47 [else (error 'spec->decl "unexpected specifier ~s" spec)])]))) 48 49(define C->Scheme 50 (lambda (spec id) 51 (case spec 52 [(boolean) (format "Sboolean(~a)" id)] 53 [(char) (format "Schar(~a)" id)] 54 [(fixnum) (format "Sfixnum(~a)" id)] 55 [(integer-32) (format "Sinteger(~a)" id)] 56 [(unsigned-32) (format "Sunsigned(~a)" id)] 57 [(single-float) (format "Sflonum((double)~a)" id)] 58 [(double-float) (format "Sflonum(~a)" id)] 59 [(scheme-object) id] 60 [(string) (format "Sstring(~a)" id)] 61 [else 62 (record-case spec 63 [(foreign-pointer foreign-object) () 64 (error 'C->Scheme "unsupported specifier ~s" spec)] 65 [else (error 'C->Scheme "unexpected specifier ~s" spec)])]))) 66 67(define Scheme->C 68 (lambda (op spec src) 69 (case spec 70 [(boolean) (fprintf op "Sboolean_value(~a)" src)] 71 [(char) (fprintf op "Schar_value(~a)" src)] 72 [(fixnum) (fprintf op "Sfixnum_value(~a)" src)] 73 [(integer-32) (fprintf op "Sinteger_value(~a)" src)] 74 [(unsigned-32) (fprintf op "Sunsigned_value(~a)" src)] 75 [(single-float) (fprintf op "(float)Sflonum_value(~a)" src)] 76 [(double-float) (fprintf op "Sflonum_value(~a)" src)] 77 [(scheme-object) (display src op)] 78 [(string) (fprintf op "Sstring_value(~a)" src)] 79 [else 80 (record-case spec 81 [(foreign-pointer foreign-object) () 82 (error 'Scheme->C "unsupported specifier ~s" spec)] 83 [else (error 'Scheme->C "unexpected specifier ~s" spec)])]))) 84 85(define gen-fcallable 86 (case-lambda 87 [(cname arg-specs res-spec) 88 (gen-fcallable (current-output-port) cname arg-specs res-spec)] 89 [(op cname arg-specs res-spec) 90 (let ((names (let loop ((ls arg-specs) (i 1)) 91 (if (null? ls) 92 '() 93 (cons (format "x~d" i) (loop (cdr ls) (+ i 1)))))) 94 (count (length arg-specs))) 95 (newline op) 96 (fprintf op "~a ~a(ptr proc" (spec->decl res-spec) cname) ;) 97 (let loop ((arg-specs arg-specs) (names names)) 98 (unless (null? arg-specs) 99 (fprintf op ", ~a ~a" (spec->decl (car arg-specs)) (car names)) 100 (loop (cdr arg-specs) (cdr names)))) ;( 101 (fprintf op ") {~%") 102 (if (<= 0 count 3) 103 (begin 104 (display " return " op) 105 (Scheme->C op res-spec 106 (let ((op (open-output-string))) 107 (fprintf op "Scall~d(proc" count) ;) 108 (let loop ((arg-specs arg-specs) (names names)) 109 (unless (null? arg-specs) 110 (display ", " op) 111 (display (C->Scheme (car arg-specs) (car names)) op) 112 (loop (cdr arg-specs) (cdr names)))) ;( 113 (fprintf op ")") 114 (get-output-string op)))) 115 (begin 116 (fprintf op " Sinitframe(~d);~%" count) 117 (let loop ([arg-specs arg-specs] [names names] [num 1]) 118 (unless (null? arg-specs) 119 (fprintf op " Sput_arg(~d, ~a);~%" 120 num (C->Scheme (car arg-specs) (car names))) 121 (loop (cdr arg-specs) (cdr names) (+ num 1)))) 122 (fprintf op " return ") 123 (Scheme->C op res-spec 124 (format "Scall(proc, ~d)" count)))) 125 (fprintf op ";~%}~%"))])) 126 127(define-syntax foreign-callable 128 (syntax-rules () 129 ((_ n args res) 130 (gen-fcallable n 'args 'res)))) 131 132(define gen-file 133 (lambda (fnroot) 134 (let ((ifn (format "~a.ss" fnroot)) 135 (ofn (format "~a.xx" fnroot))) 136 (with-output-to-file ofn 137 (lambda () (load ifn)) 138 'replace)))) 139 140#!eof ; cut off the input here so we can give examples w/o comment chars 141 142Example input file: 143 144------------------------------------------------------------------------ 145(foreign-callable "foo" 146 (boolean single-float double-float) 147 scheme-object) 148 149(foreign-callable "bar" 150 (boolean char integer-32 unsigned-32 single-float 151 double-float scheme-object) 152 string) 153 154(foreign-callable "baz" () fixnum) 155------------------------------------------------------------------------ 156 157Generated output file: 158 159------------------------------------------------------------------------ 160ptr foo(ptr proc, int x1, float x2, double x3) { 161 return Scall3(proc, Sboolean(x1), Sflonum((double)x2), Sflonum(x3)); 162} 163 164char * bar(ptr proc, int x1, char x2, int x3, unsigned int x4, float x5, double x6, ptr x7) { 165 Sinitframe(7); 166 Sput_arg(1, Sboolean(x1)); 167 Sput_arg(2, Schar(x2)); 168 Sput_arg(3, Sinteger(x3)); 169 Sput_arg(4, Sunsigned(x4)); 170 Sput_arg(5, Sflonum((double)x5)); 171 Sput_arg(6, Sflonum(x6)); 172 Sput_arg(7, x7); 173 return Sstring_value(Scall(proc, 7)); 174} 175 176int baz(ptr proc) { 177 return Sfixnum_value(Scall0(proc)); 178} 179------------------------------------------------------------------------ 180