Skip to content

Commit 4d8ee55

Browse files
ktakashiktakashi
committed
Improving define-foreign-variable to recognise type alias
1 parent 3b985ff commit 4d8ee55

File tree

5 files changed

+138
-28
lines changed

5 files changed

+138
-28
lines changed

‎Makefile‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -37,6 +37,7 @@ prepare-racket:
3737
$(RACKET) --force --install src/pffi/misc.sls
3838
$(RACKET) --force --install src/pffi/compat.mzscheme.sls
3939
$(RACKET) --force --install src/pffi/procedure.sls
40+
$(RACKET) --force --install src/pffi/variable/helper.sls
4041
$(RACKET) --force --install src/pffi/variable.sls
4142
$(RACKET) --force --install src/pffi/pointers.sls
4243
$(RACKET) --force --install src/pffi/struct/helper.sls

‎src/pffi/variable.sls‎

Lines changed: 14 additions & 27 deletions
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,8 @@
3434
(import (rnrs)
3535
(for (pffi misc) expand)
3636
(only (pffi misc) define-type-alias)
37-
(pffi compat))
37+
(pffi compat)
38+
(pffi variable helper))
3839

3940
(define-syntax array (syntax-rules ()))
4041

@@ -45,10 +46,6 @@
4546
(string->symbol
4647
(string-map (lambda (c) (if (char=? c #\_) #\- c))
4748
(string-downcase (symbol->string (syntax->datum name))))))
48-
(define (derefs t)
49-
(let ((s (symbol->string (syntax->datum t))))
50-
(list (string->symbol (string-append "pointer-ref-c-" s))
51-
(string->symbol (string-append "pointer-set-c-" s "!")))))
5249
(define (sizeof t)
5350
(let ((s (symbol->string (syntax->datum t))))
5451
(string->symbol (string-append "size-of-" s))))
@@ -59,20 +56,21 @@
5956
#'(k lib type name scheme-name)))
6057
((k lib type name scheme-name)
6158
(identifier? #'type)
62-
(with-syntax (((pointer-ref pointer-set!)
63-
(datum->syntax #'dummy (derefs #'type))))
64-
#'(begin
65-
(define dummy (lookup-shared-object lib (symbol->string 'name)))
66-
(define-syntax scheme-name
67-
(identifier-syntax
68-
(_ (pointer-ref dummy 0))
69-
((set! _ e) (pointer-set! dummy 0 e)))))))
59+
#'(begin
60+
(define pointer-ref (type->pointer-ref type))
61+
(define pointer-set! (type->pointer-set! type))
62+
(define dummy (lookup-shared-object lib (symbol->string 'name)))
63+
(define-syntax scheme-name
64+
(identifier-syntax
65+
(_ (pointer-ref dummy 0))
66+
((set! _ e) (pointer-set! dummy 0 e))))))
7067
((k lib (array type) name scheme-name)
7168
(identifier? #'type)
72-
(with-syntax (((pointer-ref pointer-set!)
73-
(datum->syntax #'dummy (derefs #'type)))
74-
(size-of (datum->syntax #'dummy (sizeof #'type))))
69+
(with-syntax ((size-of (datum->syntax #'dummy (sizeof #'type))))
7570
#'(begin
71+
(define pointer-ref (type->pointer-ref type))
72+
(define pointer-set! (type->pointer-set! type))
73+
(define size-of (type->size-of type))
7674
(define dummy (lookup-shared-object lib (symbol->string 'name)))
7775
(define-syntax scheme-name
7876
(make-variable-transformer
@@ -82,15 +80,4 @@
8280
#'(pointer-set! dummy (* size-of n) val))
8381
((_ n) #'(pointer-ref dummy (* size-of n)))
8482
(id (identifier? #'id) #'dummy)))))))))))
85-
86-
;; some need to be fixed things
87-
(define size-of-int8 size-of-int8_t)
88-
(define size-of-int16 size-of-int16_t)
89-
(define size-of-int32 size-of-int32_t)
90-
(define size-of-int64 size-of-int64_t)
91-
(define size-of-uint8 size-of-int8_t)
92-
(define size-of-uint16 size-of-int16_t)
93-
(define size-of-uint32 size-of-int32_t)
94-
(define size-of-uint64 size-of-int64_t)
95-
9683
)

‎src/pffi/variable/helper.chezscheme.sls‎

Lines changed: 69 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,69 @@
1+
;;; -*- mode:scheme; coding: utf-8; -*-
2+
;;;
3+
;;; src/pffi/variable/helper.sls - Foreign varialbe helper
4+
;;;
5+
;;; Copyright (c) 2015-2025 Takashi Kato <ktakashi@ymail.com>
6+
;;;
7+
;;; Redistribution and use in source and binary forms, with or without
8+
;;; modification, are permitted provided that the following conditions
9+
;;; are met:
10+
;;;
11+
;;; 1. Redistributions of source code must retain the above copyright
12+
;;; notice, this list of conditions and the following disclaimer.
13+
;;;
14+
;;; 2. Redistributions in binary form must reproduce the above copyright
15+
;;; notice, this list of conditions and the following disclaimer in the
16+
;;; documentation and/or other materials provided with the distribution.
17+
;;;
18+
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19+
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20+
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21+
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22+
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23+
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24+
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25+
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26+
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29+
;;;
30+
#!r6rs
31+
(library (pffi variable helper)
32+
(export type->pointer-ref
33+
type->pointer-set!
34+
type->size-of)
35+
(import (rnrs)
36+
(only (chezscheme) foreign-ref foreign-set! ftype-sizeof)
37+
(pffi compat)
38+
(pffi helper)
39+
(pffi ffi-type-descriptor))
40+
;; maybe, we need to make pointer-ref generic...
41+
(define-syntax type->pointer-ref
42+
(lambda (x)
43+
(syntax-case x ()
44+
((_ type)
45+
(if (eq? (pffi-type->foreign-type (syntax->datum #'type)) 'void*)
46+
#'(lambda (ptr offset)
47+
(integer->pointer
48+
(foreign-ref (pffi-type->foreign-type 'type)
49+
(pointer->integer ptr) offset)))
50+
#'(lambda (ptr offset)
51+
(foreign-ref (pffi-type->foreign-type 'type)
52+
(pointer->integer ptr) offset)))))))
53+
54+
(define-syntax type->pointer-set!
55+
(lambda (x)
56+
(syntax-case x ()
57+
((_ type)
58+
(if (eq? (pffi-type->foreign-type (syntax->datum #'type)) 'void*)
59+
#'(lambda (ptr offset value)
60+
(foreign-set! (pffi-type->foreign-type 'type)
61+
(pointer->integer ptr)
62+
offset (pointer->integer value)))
63+
#'(lambda (ptr offset value)
64+
(foreign-set! (pffi-type->foreign-type 'type)
65+
(pointer->integer ptr) offset value)))))))
66+
67+
(define-syntax type->size-of (identifier-syntax ftype-sizeof))
68+
69+
)

‎src/pffi/variable/helper.sls‎

Lines changed: 52 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,52 @@
1+
;;; -*- mode:scheme; coding: utf-8; -*-
2+
;;;
3+
;;; src/pffi/variable/helper.sls - Foreign varialbe helper
4+
;;;
5+
;;; Copyright (c) 2015-2025 Takashi Kato <ktakashi@ymail.com>
6+
;;;
7+
;;; Redistribution and use in source and binary forms, with or without
8+
;;; modification, are permitted provided that the following conditions
9+
;;; are met:
10+
;;;
11+
;;; 1. Redistributions of source code must retain the above copyright
12+
;;; notice, this list of conditions and the following disclaimer.
13+
;;;
14+
;;; 2. Redistributions in binary form must reproduce the above copyright
15+
;;; notice, this list of conditions and the following disclaimer in the
16+
;;; documentation and/or other materials provided with the distribution.
17+
;;;
18+
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19+
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20+
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21+
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22+
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23+
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24+
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25+
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26+
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29+
;;;
30+
#!r6rs
31+
(library (pffi variable helper)
32+
(export type->pointer-ref
33+
type->pointer-set!
34+
type->size-of)
35+
(import (rnrs)
36+
(pffi ffi-type-descriptor))
37+
(define (type->pointer-ref type)
38+
(unless (pointer-accesible-ffi-type-descriptor? type)
39+
(let ((name (ffi-type-descriptor-name type)))
40+
(assertion-violation 'define-foreign-variable
41+
(string-append (symbol->string name) " is not supported") type)))
42+
(pointer-accesible-ffi-type-descriptor-pointer-ref type))
43+
44+
(define (type->pointer-set! type)
45+
(unless (pointer-accesible-ffi-type-descriptor? type)
46+
(let ((name (ffi-type-descriptor-name type)))
47+
(assertion-violation 'define-foreign-variable
48+
(string-append (symbol->string name) " is not supported") type)))
49+
(pointer-accesible-ffi-type-descriptor-pointer-set! type))
50+
51+
(define (type->size-of type) (ffi-type-descriptor-size type))
52+
)

‎tests/test.scm‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -357,7 +357,8 @@
357357
(test-assert "check-dispatch (2)" (not (check-dispatch 2 #f))))
358358

359359
(let ()
360-
(define-foreign-variable test-lib (array int) int_array int-array)
360+
(define-type-alias my-int int)
361+
(define-foreign-variable test-lib (array my-int) int_array int-array)
361362
(define get-int-array (foreign-procedure test-lib pointer get_int_array ()))
362363
(test-assert (pointer? int-array))
363364
(test-equal 1 (int-array 0))

0 commit comments

Comments
 (0)