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