From fee8d23458827802f3905ebe871091aee6acd82e Mon Sep 17 00:00:00 2001 From: retropikzel Date: Wed, 23 Jul 2025 10:57:23 +0300 Subject: [PATCH] Ypsilon uint8-ref fixes --- foreign/c.sld | 17 +++++--- foreign/c/primitives/ypsilon.scm | 75 +------------------------------- 2 files changed, 13 insertions(+), 79 deletions(-) diff --git a/foreign/c.sld b/foreign/c.sld index cb88540..1ca6ada 100644 --- a/foreign/c.sld +++ b/foreign/c.sld @@ -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") diff --git a/foreign/c/primitives/ypsilon.scm b/foreign/c/primitives/ypsilon.scm index 26cbf99..8e5220b 100644 --- a/foreign/c/primitives/ypsilon.scm +++ b/foreign/c/primitives/ypsilon.scm @@ -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