Retropikzel
/
foreign-c
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Added array utilities

This commit is contained in:
retropikzel 2025-04-06 07:59:19 +03:00
parent 70d19a8a90
commit 3f4cb7f668
5 changed files with 118 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
README.md
View File

@ -26,11 +26,9 @@ conforming to some specification.
- [Status](#status) - [Status](#status)
- [Current caveats](#current-caveats) - [Current caveats](#current-caveats)
- [Roadmap](#roadmap) - [Roadmap](#roadmap)
- [Implementation table](#implementation-table) - [Feature implementation table](#feature-implementation-table)
- [Beta](#beta) - [Primitives](#feature-implementation-table-primitives)
- [Alpha](#alpha) - [Built upon](#feature-implementation-table-built-upon)
- [Not started](#not-started)
- [Other](#other)
- [Documentation](#documentation) - [Documentation](#documentation)
- [Installation](#installation) - [Installation](#installation)
- [Compiling the library](#compiling-the-library) - [Compiling the library](#compiling-the-library)
@ -93,10 +91,6 @@ conforming to some specification.
Currently the interface of the library is in okay shape. It propably will not change much but no Currently the interface of the library is in okay shape. It propably will not change much but no
guarantees are being made just yet. guarantees are being made just yet.
Due to supporting many different Scheme implementations, different parts of this software are in
different stage. As a whole it is still in **alpha** stage. That said the interface should not be
changing anymore and some implementations are in **beta**.
### Current caveats ### Current caveats
<a name="current-caveats"></a> <a name="current-caveats"></a>
@ -112,41 +106,46 @@ changing anymore and some implementations are in **beta**.
For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?search=status%3Aopen%20label%3A%221.0.0%22) For roadmap to 1.0.0 see [issues](https://todo.sr.ht/~retropikzel/r7rs-pffi?search=status%3Aopen%20label%3A%221.0.0%22)
## Implementation table ## Feature mplementation table
<a name="implementation-table"></a> <a name="feature-implementation-table"></a>
### Released ## Primitives
<a name="released"></a> <a name="feature-implementation-table-primitives"></a>
| | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-address | pffi-pointer? | pffi-pointer-set! | pffi-pointer-get | pffi-define | pffi-define-callback |
|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:--------------------:|:-------------:|:-----------------:|:----------------:|:-----------:|:--------------------:|
| Chibi | X | X | X | X | X | X | X | X | X | X | |
| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X |
| Cyclone | X | X | X | X | X | | X | X | X | X | |
| Gambit | X | X | | | | X | | | | | |
| Gauche | X | X | X | X | X | X | X | X | X | X | |
| Gerbil | X | | | | | | | | | | |
| Guile | X | X | X | X | X | X | X | X | X | X | X |
| Kawa | X | X | X | X | X | X | X | X | X | X | X |
| Larceny | X | | | | | | | | | | |
| Mosh | X | X | X | X | X | | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X | X | X | X | X |
| Skint | X | | | | | | | | | | |
| Stklos | X | X | X | X | X | | X | | | | |
| tr7 | | | | | | | | | | | |
| Ypsilon | X | X | X | X | X | X | X | X | X | X | X |
### Beta ## Built upon
<a name="beta"></a> <a name="feature-implementation-table-built-upon"></a>
| | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | These features are built upon the primitives and if primitives are implemented
|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| and work, they should work too.
| Chibi | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | |
| Chicken-5 | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Gauche | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | |
| Guile | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Kawa | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Racket | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Saggittarius | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
- pffi-pointer-allocate
### Alpha - pffi-pointer-free
<a name="alpha"></a> - pffi-pointer-\>string
- pffi-string-\>pointer
| | pffi-init | pffi-size-of | pffi-define-library | pffi-pointer-null | pffi-pointer-null? | pffi-pointer-allocate | pffi-pointer-address | pffi-pointer? | pffi-pointer-free | pffi-pointer-set! | pffi-pointer-get | pffi-string->pointer | pffi-pointer->string | pffi-struct-make | pffi-struct-pointer | pffi-struct-offset-get | pffi-struct-get | pffi-struct-set! | pffi-define | pffi-define-callback | - pffi-struct-make
|--------------|:---------:|:------------:|:-------------------:|:-----------------:|:------------------:|:---------------------:|:--------------------:|:-------------:|:-----------------:|:-----------------:|:----------------:|:--------------------:|:--------------------:|:----------------:|:-------------------:|:----------------------:|:---------------:|:----------------:|:-----------:|:--------------------:| - pffi-struct-pointer
| Cyclone | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | | - pffi-struct-offset-get
| Gambit | X | X | | | | | X | | | | | | | X | X | X | X | X | | | - pffi-struct-get
| Gerbil | X | | | | | | | | | | | | | X | X | X | X | X | | | - pffi-struct-set!
| Larceny | X | | | | | | | | | | | | | X | X | X | X | X | | |
| Mosh | X | X | X | X | X | X | | X | X | X | X | X | X | X | X | X | X | X | X | X |
| Skint | X | | | | | | | | | | | | | X | X | X | X | X | | |
| Stklos | X | X | X | X | X | X | | X | X | | | | | X | X | X | X | X | | |
| tr7 | | | | | | | | | | | | | | X | X | X | X | X | | |
| Ypsilon | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X | X |
### Not started ### Not started
<a name="not-started"></a> <a name="not-started"></a>

35
retropikzel/pffi.sld
View File

@ -29,6 +29,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback pffi-define-callback
;scheme-procedure-to-pointer ;scheme-procedure-to-pointer
@ -65,6 +67,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(chicken6 (chicken6
@ -97,6 +101,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(cyclone (cyclone
@ -126,6 +132,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -156,6 +164,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -187,6 +197,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -215,6 +227,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
;pffi-define ;pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -247,6 +261,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(kawa (kawa
@ -275,6 +291,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback pffi-define-callback
)) ))
@ -309,6 +327,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
;pffi-define ;pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -339,6 +359,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(racket (racket
@ -372,6 +394,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(sagittarius (sagittarius
@ -402,6 +426,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(skint (skint
@ -429,6 +455,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
;pffi-define ;pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -459,6 +487,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -488,6 +518,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
;pffi-define ;pffi-define
;pffi-define-callback ;pffi-define-callback
)) ))
@ -520,6 +552,8 @@
pffi-struct-offset-get pffi-struct-offset-get
pffi-struct-get pffi-struct-get
pffi-struct-set! pffi-struct-set!
pffi-list->array
pffi-array->list
pffi-define pffi-define
pffi-define-callback)) pffi-define-callback))
(else (error "Unsupported implementation"))) (else (error "Unsupported implementation")))
@ -544,5 +578,6 @@
;(include "pffi/shared/union.scm") ;(include "pffi/shared/union.scm")
(include "pffi/shared/main.scm") (include "pffi/shared/main.scm")
(include "pffi/shared/pointer.scm") (include "pffi/shared/pointer.scm")
(include "pffi/shared/array.scm")
(include "pffi/shared/struct.scm") (include "pffi/shared/struct.scm")
) )

5
retropikzel/pffi/sagittarius.scm
View File

@ -22,7 +22,8 @@
((equal? type 'string) 'void*) ((equal? type 'string) 'void*)
((equal? type 'void) 'void) ((equal? type 'void) 'void)
((equal? type 'callback) 'callback) ((equal? type 'callback) 'callback)
((equal? type 'struct) 'char*) ((equal? type 'struct) 'void*)
((list? type) (map pffi-type->native-type type))
(else #f)))) (else #f))))
(define pffi-pointer? (define pffi-pointer?
@ -81,7 +82,7 @@
(lambda (pointer) (lambda (pointer)
(address pointer 0))) (address pointer 0)))
#;(define pffi-pointer-null (define pffi-pointer-null
(lambda () (lambda ()
(empty-pointer))) (empty-pointer)))

22
retropikzel/pffi/shared/array.scm Normal file
View File

@ -0,0 +1,22 @@
(define pffi-list->array
(lambda (type list-arg)
(let* ((type-size (pffi-size-of type))
(array (pffi-pointer-allocate (* type-size (length list-arg))))
(offset 0))
(for-each
(lambda (item)
(pffi-pointer-set! array type offset item)
(set! offset (+ offset type-size)))
list-arg)
array)))
(define pffi-array->list
(lambda (type array size)
(letrec* ((type-size (pffi-size-of type))
(max-offset (* type-size size))
(looper (lambda (offset result)
(if (= offset max-offset)
result
(looper (+ offset type-size)
(append result (list (pffi-pointer-get array type offset))))))))
(looper 0 (list)))))

20
tests/compliance.scm
View File

@ -884,6 +884,26 @@
(debug (pffi-struct-get struct-test2 'n)) (debug (pffi-struct-get struct-test2 'n))
(assert = (pffi-struct-get struct-test2 'n) 14.0) (assert = (pffi-struct-get struct-test2 'n) 14.0)
; Array utilities
(print-header "Array utilities")
(define test-list1 (list 1 2 3))
(debug test-list1)
(debug (pffi-list->array 'int test-list1))
(assert equal? (pffi-array->list 'int (pffi-list->array 'int test-list1) 3) test-list1)
(define test-array1 (pffi-pointer-allocate (* (pffi-size-of 'int) 3)))
(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 0) 4)
(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 1) 5)
(pffi-pointer-set! test-array1 'int (* (pffi-size-of 'int) 2) 6)
(debug test-array1)
(debug (pffi-array->list 'int test-array1 3))
(define check-list1 (list 4 5 6))
(assert equal? (pffi-array->list 'int test-array1 3) check-list1)
;; pffi-struct-dereference ;; pffi-struct-dereference
;(print-header "pffi-struct-dereference 1") ;(print-header "pffi-struct-dereference 1")