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

Ypsilon uint8-ref fixes

This commit is contained in:
retropikzel 2025-07-23 10:57:23 +03:00
parent 50df6bc3c9
commit fee8d23458
2 changed files with 13 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
foreign/c.sld
View File

@ -61,7 +61,7 @@
(system foreign-library)
(only (guile) include-from-path)
(only (rnrs bytevectors)
bytevector-uint-set!
bytevector-int8-set!
bytevector-uint-ref)))
(kawa
(import (scheme base)
@ -170,7 +170,11 @@
(scheme process-context)
(ypsilon c-ffi)
(ypsilon c-types)
(only (core) define-macro syntax-case))))
(only (core)
define-macro
syntax-case
bytevector-c-int8-set!
bytevector-c-uint8-ref))))
(export ;;;; Primitives 1
c-type-size
define-c-library
@ -296,9 +300,7 @@
(include "c/internal.scm")
(cond-expand
(chibi (include "c/primitives/chibi.scm"))
(chicken (export foreign-declare
foreign-safe-lambda
void)
(chicken (export foreign-declare foreign-safe-lambda void)
(include "c/primitives/chicken.scm"))
;(cyclone (include "c/primitives/cyclone.scm"))
(gambit (include "c/primitives/gambit.scm"))
@ -313,7 +315,10 @@
;(skint (include "c/primitives/skint.scm"))
(stklos (include "c/primitives/stklos.scm"))
;(tr7 (include "c/primitives/tr7.scm"))
(ypsilon (export c-function c-callback)
(ypsilon (export c-function
c-callback
bytevector-c-int8-set!
bytevector-c-uint8-ref)
(include "c/primitives/ypsilon.scm")))
(include "c/main.scm")
(include "c/libc.scm")

75
foreign/c/primitives/ypsilon.scm
View File

@ -30,14 +30,14 @@
(define c-bytevector-u8-set!
(lambda (c-bytevector k byte)
(bytevector-c-uint8_t-set! (make-bytevector-mapping (+ c-bytevector k)
(bytevector-c-int8-set! (make-bytevector-mapping (+ c-bytevector k)
(c-type-size 'uint8))
0
byte)))
(define c-bytevector-u8-ref
(lambda (c-bytevector k)
(bytevector-c-uint8_t-ref (make-bytevector-mapping (+ c-bytevector k)
(bytevector-c-uint8-ref (make-bytevector-mapping (+ c-bytevector k)
(c-type-size 'uint8))
0)))
@ -54,81 +54,10 @@
(c-type-size 'pointer))
0)))
#;(define pointer-set!
(lambda (pointer type offset value)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type))))
(cond ((equal? type 'int8) (bytevector-c-int8-set! bv 0 value))
((equal? type 'uint8) (bytevector-c-int8-set! bv 0 value))
((equal? type 'int16) (bytevector-c-int16-set! bv 0 value))
((equal? type 'uint16) (bytevector-c-int16-set! bv 0 value))
((equal? type 'int32) (bytevector-c-int32-set! bv 0 value))
((equal? type 'uint32) (bytevector-c-int32-set! bv 0 value))
((equal? type 'int64) (bytevector-c-int64-set! bv 0 value))
((equal? type 'uint64) (bytevector-c-int64-set! bv 0 value))
((equal? type 'char) (bytevector-c-int8-set! bv 0 (char->integer value)))
((equal? type 'short) (bytevector-c-short-set! bv 0 value))
((equal? type 'unsigned-short) (bytevector-c-short-set! bv 0 value))
((equal? type 'int) (bytevector-c-int-set! bv 0 value))
((equal? type 'unsigned-int) (bytevector-c-int-set! bv 0 value))
((equal? type 'long) (bytevector-c-long-set! bv 0 value))
((equal? type 'unsigned-long) (bytevector-c-long-set! bv 0 value))
((equal? type 'float) (bytevector-c-float-set! bv 0 value))
((equal? type 'double) (bytevector-c-double-set! bv 0 value))
((equal? type 'void) (bytevector-c-void*-set! bv 0 value))
((equal? type 'pointer) (bytevector-c-void*-set! bv 0 value))))))
#;(define pointer-get
(lambda (pointer type offset)
(let ((bv (make-bytevector-mapping (+ pointer offset) (c-type-size type))))
(cond ((equal? type 'int8) (bytevector-c-int8-ref bv 0))
((equal? type 'uint8) (bytevector-c-uint8-ref bv 0))
((equal? type 'int16) (bytevector-c-int16-ref bv 0))
((equal? type 'uint16) (bytevector-c-uint16-ref bv 0))
((equal? type 'int32) (bytevector-c-int32-ref bv 0))
((equal? type 'uint32) (bytevector-c-uint32-ref bv 0))
((equal? type 'int64) (bytevector-c-int64-ref bv 0))
((equal? type 'uint64) (bytevector-c-uint64-ref bv 0))
((equal? type 'char) (integer->char (bytevector-c-uint8-ref bv 0)))
((equal? type 'short) (bytevector-c-short-ref bv 0))
((equal? type 'unsigned-short) (bytevector-c-unsigned-short-ref bv 0))
((equal? type 'int) (bytevector-c-int-ref bv 0))
((equal? type 'unsigned-int) (bytevector-c-unsigned-int-ref bv 0))
((equal? type 'long) (bytevector-c-long-ref bv 0))
((equal? type 'unsigned-long) (bytevector-c-unsigned-long-ref bv 0))
((equal? type 'float) (bytevector-c-float-ref bv 0))
((equal? type 'double) (bytevector-c-double-ref bv 0))
((equal? type 'void) (bytevector-c-void*-ref bv 0))
((equal? type 'pointer) (bytevector-c-void*-ref bv 0))))))
(define shared-object-load
(lambda (path options)
(load-shared-object path)))
#;(define-macro
(type->native-type type)
`(cond ((equal? ,type 'int8) 'int8_t)
((equal? ,type 'uint8) 'uint8_t)
;((equal? ,type 'int16) 'int16_t)
;((equal? ,type 'uint16) 'uint16_t)
;((equal? ,type 'int32) 'int32_t)
;((equal? ,type 'uint32) 'uint32_t)
;((equal? ,type 'int64) 'int64_t)
;((equal? ,type 'uint64) 'uint64_t)
;((equal? ,type 'char) 'char)
;((equal? ,type 'unsigned-char) 'char)
;((equal? ,type 'short) 'short)
;((equal? ,type 'unsigned-short) 'unsigned-short)
((equal? ,type 'int) 'int)
;((equal? ,type 'unsigned-int) 'unsigned-int)
;((equal? ,type 'long) 'long)
;((equal? ,type 'unsigned-long) 'unsigned-long)
;((equal? ,type 'float) 'float)
;((equal? ,type 'double) 'double)
((equal? ,type 'pointer) 'void*)
((equal? ,type 'void) 'void)
;((equal? ,type 'callback) 'void*)
(else (error "type->native-type -- No such type" ,type))))
(define-macro
(define-c-procedure scheme-name shared-object c-name return-type argument-types)
(begin