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

Add c-type-signed? and c-type-unsigned?. Add array utilities.

This commit is contained in:
retropikzel 2025-08-06 16:54:18 +03:00
parent e9bacd4b0f
commit 83f67de603
9 changed files with 317 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Jenkinsfile vendored
View File

@ -1,4 +1,4 @@
def tests = ['primitives', 'addressof', 'callback']
def tests = ['primitives', 'array', 'addressof', 'callback']
pipeline {
agent any

3
Makefile
View File

@ -168,6 +168,9 @@ guile:
kawa:
@echo "Nothing to build for Kawa"
mit-scheme:
@echo "Nothing to build for Kawa"
larceny:
@echo "Nothing to build for Larceny"

44
README.md
View File

@ -72,6 +72,10 @@ is portable in the sense that it supports multiple implementations.
- c-bytevector-\>bytevector
- string-\>c-utf8
- c-utf8-\>string
- [c-array](#c-array)
- make-c-array
- c-array-ref
- c-array-set!
- [Environment variables](#environment-variables)
@ -646,6 +650,46 @@ UTF-8 encoding of the given string.
Returns a newly allocated string whose character sequence is
encoded by the given c-bytevector. It is an error if _c-bytevector_ is null.
### c-array
(**make-c-array** _type_ _size_)<br></br>
(**make-c-array** _type_ _size_ _fill_)
If the _fill_ argument is missing, the initial contents of the
returned c-bytevector are unspecified.
If the _fill_ argument is present, it specifies the initial value for the items
of the array. If it's value does not match _type_ behaviour is unspecified.
Returns a newly allocated c-bytevector with size of _type_ times _size_.
(**c-array-ref** _array_ _type_ _index_)
_array_ is a c-bytevector.
Returns the given value of _type_ from _index_ of _array_. If the value is not
of _type_ or _index_ is out of bounds the behaviour is unspecified.
(**c-array-set!** _array_ _type_ _index_ _value_)
_array_ is a c-bytevector.
Sets the given _value_ of _type_ at _index_ of _array_. If _value_ is not of
_type_ or _index_ is out of bounds behaviour is unspecified.
(**list->c-array** list _type_)
Returns newly allocated c-bytevector with values of the _list_ in it. List
values must be of _type_. If the values are not of type behaviour is
unspecified.
(**c-array->list** _array_ _type_ _size_)
_array_ is a c-bytevector.
Returns a list with values of _array_ in it. If _type_ and _size_ do not match
what is in the _c-bytevector_ the behaviour is unspecified.
### Utilities
**libc-name**

25
foreign/c.sld
View File

@ -203,6 +203,8 @@
;;;; Utilities
libc-name
c-type-signed?
c-type-unsigned?
;; TODO endianness
native-endianness
@ -281,14 +283,12 @@
;c-string-length ;; TODO Documentation, Testing
;; c-struct
;pffi-define-struct;define-c-struct
;pffi-struct-pointer;c-struct-bytevector
;pffi-struct-offset-get;c-struct-offset
;pffi-struct-set!;c-struct-set!
;pffi-struct-get;c-struct-get
;; c-array
make-c-array
c-array-ref
c-array-set!
list->c-array
c-array->list
;define-c-array (?)
;pffi-array-allocate;make-c-array
;pffi-array-pointer;c-array-pointer
@ -299,6 +299,14 @@
;pffi-list->array;list->c-array
;pffi-array->list;c-array->list
;; c-struct
;pffi-define-struct;define-c-struct
;pffi-struct-pointer;c-struct-bytevector
;pffi-struct-offset-get;c-struct-offset
;pffi-struct-set!;c-struct-set!
;pffi-struct-get;c-struct-get
;; c-variable
;define-c-variable (?)
)
@ -325,10 +333,11 @@
bytevector-c-int8-set!
bytevector-c-uint8-ref)
(include "c/primitives/ypsilon.scm")))
(include "c/c-types.scm")
(include "c/main.scm")
(include "c/libc.scm")
(include "c/c-bytevectors.scm")
(include "c/pointer.scm")
;(include "c/array.scm")
(include "c/array.scm")
;(include "c/struct.scm")
)

105
foreign/c/array.scm
View File

@ -1,58 +1,59 @@
(define-record-type <pffi-array>
(array-make type size pointer)
pffi-array?
(type pffi-array-type)
(size pffi-array-size)
(pointer pffi-array-pointer))
(define make-c-array
(lambda (type size . fill)
(let ((array (make-c-bytevector (* (c-type-size type) size))))
(when (not (null? fill))
(letrec* ((filler (car fill))
(looper (lambda (count)
(when (> size count)
(c-array-set! array type count filler)
(looper (+ count 1))))))
(looper 0)))
array)))
(define pffi-list->array
(lambda (type list-arg)
(let* ((array-size (length list-arg))
(type-size (c-size-of type))
(define c-array-ref
(lambda (array type index)
(let* ((size (c-type-size type))
(offset (* index size)))
(cond
((equal? 'pointer type)
(c-bytevector-pointer-ref array offset))
((c-type-signed? type)
(c-bytevector-sint-ref array offset (native-endianness) size))
(else
(c-bytevector-uint-ref array offset (native-endianness) size))))))
(define c-array-set!
(lambda (array type index value)
(let* ((size (c-type-size type))
(offset (* index size)))
(cond
((equal? 'pointer type)
(c-bytevector-pointer-set! array offset value))
((c-type-signed? type)
(c-bytevector-sint-set! array offset value (native-endianness) size))
(else
(c-bytevector-uint-set! array offset value (native-endianness) size))))))
(define list->c-array
(lambda (list type)
(let* ((array-size (length list))
(type-size (c-type-size type))
(array (make-c-bytevector (* type-size array-size)))
(offset 0))
(index 0))
(for-each
(lambda (item)
(pffi-pointer-set! array type offset item)
(set! offset (+ offset type-size)))
list-arg)
(array-make type array-size array))))
(c-array-set! array type index item)
(set! index (+ index 1)))
list)
array)))
(define pffi-pointer->array
(lambda (pointer type size)
(array-make type size pointer)))
(define pffi-array->list
(lambda (array)
(letrec* ((type (pffi-array-type array))
(type-size (c-size-of type))
(max-offset (* type-size (pffi-array-size array)))
(array-pointer (pffi-array-pointer array))
(looper (lambda (offset result)
(if (= offset max-offset)
result
(looper (+ offset type-size)
(append result
(list (pffi-pointer-get array-pointer
type
offset))))))))
(define c-array->list
(lambda (array type size)
(letrec*
((looper (lambda (index result)
(if (>= index size)
result
(looper (+ index 1)
(append result
(list (c-array-ref array type index))))))))
(looper 0 (list)))))
(define pffi-array-allocate
(lambda (type size)
(array-make type size (pffi-pointer-allocate-calloc size (c-size-of type)))))
(define pffi-array-get
(lambda (array index)
(let ((type (pffi-array-type array)))
(pffi-pointer-get (pffi-array-pointer array)
type
(* (c-size-of type) index)))))
(define pffi-array-set!
(lambda (array index value)
(let ((type (pffi-array-type array)))
(pffi-pointer-set! (pffi-array-pointer array)
type
(* (c-size-of type) index)
value))))

11
foreign/c/c-types.scm Normal file
View File

@ -0,0 +1,11 @@
(define c-type-signed?
(lambda (type)
(if (member type '(int8 int16 int32 int64 char short int long float double))
#t
#f)))
(define c-type-unsigned?
(lambda (type)
(if (member type '(uint8 uint16 uint32 uint64 unsigned-char unsigned-short unsigned-int unsigned-long))
#t
#f)))

30
foreign/c/struct.scm
View File

@ -1,12 +1,12 @@
(define-record-type <pffi-struct>
(struct-make c-type size pointer members)
pffi-struct?
(c-type pffi-struct-c-type)
(size pffi-struct-size)
(pointer pffi-struct-pointer)
(members pffi-struct-members))
(define-record-type <c-struct>
(c-struct-make c-type size pointer members)
c-struct?
(c-type c-struct:type)
(size c-struct:size)
(pointer c-struct:pointer)
(members c-struct:members))
(define-syntax pffi-define-struct
(define-syntax define-c-struct
(syntax-rules ()
((_ name c-type members)
(define name
@ -19,13 +19,7 @@
(car arguments)
(make-c-bytevector size)))
(c-type-string (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type-string size pointer offsets)))))))
(define c-align-of
(lambda (type)
(cond-expand
;(guile (alignof (pffi-type->native-type type)))
(else (size-of-type type)))))
(c-struct-make c-type-string size pointer offsets)))))))
(define round-to-next-modulo-of
(lambda (to-round roundee)
@ -81,19 +75,19 @@
(c-type (if (string? c-type) c-type (symbol->string c-type))))
(struct-make c-type size pointer offsets))))
(define (pffi-struct-offset-get struct member-name)
#;(define (pffi-struct-offset-get struct member-name)
(when (not (assoc member-name (pffi-struct-members struct)))
(error "Struct has no such member" (list struct member-name)))
(car (cdr (cdr (assoc member-name (pffi-struct-members struct))))))
(define (pffi-struct-get struct member-name)
#;(define (pffi-struct-get struct member-name)
(when (not (assoc member-name (pffi-struct-members struct)))
(error "Struct has no such member" (list struct member-name)))
(let ((type (car (cdr (assoc member-name (pffi-struct-members struct)))))
(offset (car (cdr (cdr (assoc member-name (pffi-struct-members struct)))))))
(pffi-pointer-get (pffi-struct-pointer struct) type offset)))
(define (pffi-struct-set! struct member-name value)
#;(define (pffi-struct-set! struct member-name value)
(when (not (assoc member-name (pffi-struct-members struct)))
(error "Struct has no such member" (list struct member-name)))
(let ((type (car (cdr (assoc member-name (pffi-struct-members struct)))))

98
tests/array.scm Normal file
View File

@ -0,0 +1,98 @@
(import (scheme base)
(scheme write)
(scheme read)
(scheme char)
(scheme file)
(scheme process-context)
(foreign c))
;; util
(define header-count 1)
(define print-header
(lambda (title)
(set-tag title)
(display "=========================================")
(newline)
(display header-count)
(display " ")
(display title)
(newline)
(display "=========================================")
(newline)
(set! header-count (+ header-count 1))))
(define count 0)
(define assert-tag 'none)
(define set-tag
(lambda (tag)
(set! assert-tag tag)
(set! count 0)))
(cond-expand
(gambit
(define assert
(lambda (check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))
(else
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))))
(define-syntax debug
(syntax-rules ()
((_ value)
(begin
(display 'value)
(display ": ")
(write value)
(newline)))))
;; make-c-array
(print-header 'make-c-array)
(define arr (make-c-array 'uint64 10 0))
(debug arr)
(c-array-set! arr 'uint64 5 100)
(debug (c-array-ref arr 'uint64 5))
(assert = (c-array-ref arr 'uint64 5) 100)
(c-array-set! arr 'uint64 9 101)
(assert = (c-array-ref arr 'uint64 9) 101)
(define l (c-array->list arr 'uint64 10))
(debug l)
(assert equal? l '(0 0 0 0 0 100 0 0 0 101))
(define arr1 (list->c-array '(0 1 2 3 4 5 6 7 8 9) 'uint32))
(assert = (c-array-ref arr1 'uint32 0) 0)
(assert = (c-array-ref arr1 'uint32 3) 3)
(assert = (c-array-ref arr1 'uint32 8) 8)

78
tests/structs.scm Normal file
View File

@ -0,0 +1,78 @@
(import (scheme base)
(scheme write)
(scheme read)
(scheme char)
(scheme file)
(scheme process-context)
(foreign c))
;; util
(define header-count 1)
(define print-header
(lambda (title)
(set-tag title)
(display "=========================================")
(newline)
(display header-count)
(display " ")
(display title)
(newline)
(display "=========================================")
(newline)
(set! header-count (+ header-count 1))))
(define count 0)
(define assert-tag 'none)
(define set-tag
(lambda (tag)
(set! assert-tag tag)
(set! count 0)))
(cond-expand
(gambit
(define assert
(lambda (check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))
(else
(define-syntax assert
(syntax-rules ()
((_ check value-a value-b)
(let ((result (apply check (list value-a value-b))))
(set! count (+ count 1))
(if (not result) (display "FAIL ") (display "PASS "))
(display "[")
(display assert-tag)
(display " - ")
(display count)
(display "]")
(display ": ")
(write (list 'check 'value-a 'value-b))
(newline)
(when (not result) (exit 1))))))))
(define-syntax debug
(syntax-rules ()
((_ value)
(begin
(display 'value)
(display ": ")
(write value)
(newline)))))
;; define-c-struct
(define-c-struct test '() '())