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

Backup

This commit is contained in:
retropikzel 2024-08-25 17:30:10 +03:00
parent a587525793
commit b60defacb3
1 changed files with 9 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
retropikzel/r7rs-pffi/version/chicken.scm
View File

@ -141,8 +141,7 @@
`(begin (define-external ,(cons 'external_123456789 arguments) `(begin (define-external ,(cons 'external_123456789 arguments)
,return-type ,return-type
(begin ,@ procedure-body)) (begin ,@ procedure-body))
(define ,scheme-name (location external_123456789))) (define ,scheme-name (location external_123456789)))))))
))))
(define-syntax pffi-size-of-old (define-syntax pffi-size-of-old
(er-macro-transformer (er-macro-transformer
@ -202,14 +201,14 @@
(lambda () (lambda ()
(address->pointer 0))) (address->pointer 0)))
(define pffi-string->pointer-old (define pffi-string->pointer
(lambda (string-content) (lambda (string-content)
(let* ((size (+ (string-length string-content) 1)) (let* ((size (+ (string-length string-content) 1))
(pointer (pffi-pointer-allocate size))) (pointer (pffi-pointer-allocate size)))
(move-memory! string-content pointer (- size 1) 0) (move-memory! string-content pointer (- size 1) 0)
pointer))) pointer)))
(define pffi-string->pointer (define pffi-string->pointer-maybe
(lambda (string-content) (lambda (string-content)
(location string-content))) (location string-content)))
@ -217,16 +216,12 @@
(define pffi-pointer->string (define pffi-pointer->string
(lambda (pointer) (lambda (pointer)
(write pointer) (cond ((pffi-pointer? pointer)
(newline)
(cond ((string? pointer) pointer)
((locative? pointer) (locative->object pointer))
((pffi-pointer? pointer)
(let* ((size (strlen pointer)) (let* ((size (strlen pointer))
(string-content (make-string size))) (string-content (make-string size)))
(move-memory! pointer string-content size 0) (move-memory! pointer string-content size 0)
string-content)) string-content))
(error "Argument not pointer or string" pointer)))) (error "pffi-pointer->string -- Argument not pointer " pointer))))
(define-syntax pffi-shared-object-load (define-syntax pffi-shared-object-load
(er-macro-transformer (er-macro-transformer
@ -252,6 +247,8 @@
(define pffi-pointer-set! (define pffi-pointer-set!
(lambda (pointer type offset value) (lambda (pointer type offset value)
(write pointer)
(newline)
(cond (cond
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value)) ((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value)) ((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
@ -275,6 +272,8 @@
(define pffi-pointer-get (define pffi-pointer-get
(lambda (pointer type offset) (lambda (pointer type offset)
(write pointer)
(newline)
(cond (cond
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset))) ((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset))) ((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))