Working on Chicken bugs, backup
This commit is contained in:
parent
a94bfc0768
commit
531c8bc42d
1
Makefile
1
Makefile
|
|
@ -70,6 +70,7 @@ test-sagittarius: build
|
|||
RACKET=racket -I r7rs -S . -S ./schubert --script
|
||||
test-racket: build
|
||||
${SCHEME_RUNNER} racket "${RACKET} test.scm"
|
||||
#${RACKET} test.scm
|
||||
|
||||
STKLOS=stklos -A . -A ./schubert -f
|
||||
test-stklos: build
|
||||
|
|
|
|||
|
|
@ -53,7 +53,8 @@
|
|||
|
||||
(define pffi-pointer?
|
||||
(lambda (object)
|
||||
(pointer? object)))
|
||||
(or (string? object)
|
||||
(pointer? object))))
|
||||
|
||||
(define-syntax pffi-define
|
||||
(er-macro-transformer
|
||||
|
|
@ -175,17 +176,33 @@
|
|||
(lambda ()
|
||||
(address->pointer 0)))
|
||||
|
||||
(pffi-define strncpy-ps #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
(pffi-define puts #f 'puts 'int (list 'pointer))
|
||||
(pffi-define memset #f 'memset 'void (list 'pointer 'int 'int))
|
||||
|
||||
(define pffi-string->pointer
|
||||
(lambda (string-content)
|
||||
(let* ((size (+ (string-length string-content) 1))
|
||||
(pointer (pffi-pointer-allocate size)))
|
||||
(move-memory! string-content pointer (- size 1) 0)
|
||||
pointer)))
|
||||
|
||||
(define pffi-string->pointer-maybe
|
||||
(lambda (string-content)
|
||||
(location string-content)))
|
||||
(let* ((size (string-length string-content))
|
||||
(pointer (pffi-pointer-allocate (+ size 1))))
|
||||
(memset pointer 0 size)
|
||||
(display "STRING-LENGTH: ")
|
||||
(display size)
|
||||
(display " / ")
|
||||
(display pointer)
|
||||
(display " === ")
|
||||
(strncpy-ps pointer (location string-content) size)
|
||||
;(move-memory! string-content pointer size 0)
|
||||
;(pffi-pointer-set! pointer 'char size #\null)
|
||||
(puts pointer)
|
||||
(display " ::: ")
|
||||
(write string-content)
|
||||
(display " OTHER: ")
|
||||
(display (strlen pointer))
|
||||
(newline)
|
||||
;(pointer-s8-set! pointer size (foreign-value "\0" char))
|
||||
pointer)))
|
||||
|
||||
(pffi-define strncpy-pp #f 'strncpy 'pointer (list 'pointer 'pointer 'int))
|
||||
(pffi-define strlen #f 'strlen 'int (list 'pointer))
|
||||
|
||||
(define pffi-pointer->string
|
||||
|
|
@ -193,7 +210,17 @@
|
|||
(cond ((pffi-pointer? pointer)
|
||||
(let* ((size (strlen pointer))
|
||||
(string-content (make-string size)))
|
||||
(move-memory! pointer string-content size 0)
|
||||
(display "STRLEN: ")
|
||||
(display size)
|
||||
(display " / ")
|
||||
(display pointer)
|
||||
;(move-memory! pointer string-content size)
|
||||
(strncpy-pp (location string-content) pointer size)
|
||||
(display " ::: ")
|
||||
(write string-content)
|
||||
(display " === ")
|
||||
(puts pointer)
|
||||
(newline)
|
||||
string-content))
|
||||
(error "pffi-pointer->string -- Argument not pointer " pointer))))
|
||||
|
||||
|
|
@ -221,8 +248,6 @@
|
|||
|
||||
(define pffi-pointer-set!
|
||||
(lambda (pointer type offset value)
|
||||
(write pointer)
|
||||
(newline)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'uint8) (pointer-u8-set! (pointer+ pointer offset) value))
|
||||
|
|
@ -239,15 +264,13 @@
|
|||
((equal? type 'unsigned-int) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'long) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'unsigned-long) (pointer-u32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'float) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-s32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-s8-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'string) (pffi-pointer-set! pointer type offset (pffi-string->pointer value))))))
|
||||
((equal? type 'float) (pointer-f32-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'double) (pointer-f64-set! (pointer+ pointer offset) value))
|
||||
((equal? type 'pointer) (pointer-u64-set! (pointer+ pointer offset) (pointer->address value)))
|
||||
((equal? type 'string) (pffi-pointer-set! pointer 'pointer offset (pffi-string->pointer value))))))
|
||||
|
||||
(define pffi-pointer-get
|
||||
(lambda (pointer type offset)
|
||||
(write pointer)
|
||||
(newline)
|
||||
(cond
|
||||
((equal? type 'int8) (pointer-s8-ref (pointer+ pointer offset)))
|
||||
((equal? type 'uint8) (pointer-u8-ref (pointer+ pointer offset)))
|
||||
|
|
@ -264,9 +287,9 @@
|
|||
((equal? type 'unsigned-int) (pointer-u32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'long) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'unsigned-long) (pointer-u32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'float) (pointer-s32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-s8-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (pointer->address (pointer+ pointer offset)))
|
||||
((equal? type 'float) (pointer-f32-ref (pointer+ pointer offset)))
|
||||
((equal? type 'double) (pointer-f64-ref (pointer+ pointer offset)))
|
||||
((equal? type 'pointer) (address->pointer (pointer-u64-ref (pointer+ pointer offset))))
|
||||
((equal? type 'string) (pffi-pointer->string (pffi-pointer-get pointer 'pointer offset))))))
|
||||
|
||||
(define pffi-pointer-deref
|
||||
|
|
|
|||
212
test.scm
212
test.scm
|
|
@ -6,6 +6,7 @@
|
|||
|
||||
(define print-header
|
||||
(lambda (title)
|
||||
(set-tag title)
|
||||
(display "=========================================")
|
||||
(newline)
|
||||
(display title)
|
||||
|
|
@ -13,11 +14,26 @@
|
|||
(display "=========================================")
|
||||
(newline)))
|
||||
|
||||
(define count 0)
|
||||
(define assert-tag 'none)
|
||||
|
||||
(define set-tag
|
||||
(lambda (tag)
|
||||
(set! assert-tag tag)
|
||||
(set! count 0)))
|
||||
|
||||
(define-syntax assert
|
||||
(syntax-rules ()
|
||||
((_ check value-a value-b)
|
||||
(let ((result (apply check (list value-a value-b))))
|
||||
(if (not result) (display "FAIL: ") (display "PASS: "))
|
||||
(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))))))
|
||||
|
|
@ -46,54 +62,30 @@
|
|||
(pffi-shared-object-auto-load (list "stdlib.h") (list) "ucrtbase" (list ""))
|
||||
(pffi-shared-object-auto-load (list "stdlib.h") (list) "c" (list "" ".6"))))
|
||||
|
||||
;; pffi-define
|
||||
;; pffi-string->pointer
|
||||
|
||||
(print-header 'pffi-define)
|
||||
(print-header 'pffi-string->pointer)
|
||||
|
||||
(define string-pointer (pffi-string->pointer "Hello world"))
|
||||
(debug string-pointer)
|
||||
(assert equal? (pffi-pointer? string-pointer) #t)
|
||||
(assert equal? (pffi-pointer-null? string-pointer) #f)
|
||||
|
||||
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
|
||||
(assert = (atoi (pffi-string->pointer "100")) 100)
|
||||
;; pffi-pointer->string
|
||||
|
||||
;; pffi-define-callback
|
||||
(print-header 'pffi-pointer->string)
|
||||
|
||||
(print-header 'pffi-define-callback)
|
||||
|
||||
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers
|
||||
(list ".") ; Additional search paths
|
||||
"curl" ; The named of shared object without the lib prefix
|
||||
(list ".4")))
|
||||
(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list))
|
||||
(pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer))
|
||||
(pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback))
|
||||
(pffi-define curl-easy-getinfo libcurl 'curl_easy_getinfo 'int (list 'pointer 'int 'pointer))
|
||||
(pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer))
|
||||
(define CURLOPT-WRITEFUNCTION 20011)
|
||||
(define CURLOPT-FOLLOWLOCATION 52)
|
||||
(define CURLOPT-URL 10002)
|
||||
(define CURLINFO-RESPONSE-CODE 2097154)
|
||||
|
||||
(define result "")
|
||||
(pffi-define-callback collect-result
|
||||
'void
|
||||
(list 'pointer 'int 'int 'pointer)
|
||||
(lambda (pointer size nmemb client-pointer)
|
||||
(set! result (string-append result (pffi-pointer->string pointer)))))
|
||||
|
||||
(define handle (curl-easy-init))
|
||||
(define url (pffi-string->pointer "https://scheme.org"))
|
||||
(define curl-code1 (curl-easy-setopt handle CURLOPT-FOLLOWLOCATION url))
|
||||
(debug curl-code1)
|
||||
(assert = curl-code1 0)
|
||||
(define curl-code2 (curl-easy-setopt handle CURLOPT-URL url))
|
||||
(debug curl-code2)
|
||||
(assert = curl-code2 0)
|
||||
(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
|
||||
(debug curl-code3)
|
||||
(assert = curl-code3 0)
|
||||
(debug (curl-easy-perform handle))
|
||||
(define http-code (pffi-pointer-allocate (pffi-size-of 'int)))
|
||||
(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE http-code)
|
||||
(assert = (pffi-pointer-get http-code 'int 0) 200)
|
||||
(define pointer-string (pffi-pointer->string string-pointer))
|
||||
(debug pointer-string)
|
||||
(assert equal? (string? pointer-string) #t)
|
||||
(assert string=? pointer-string "Hello world")
|
||||
(assert string=? (pffi-pointer->string (pffi-string->pointer "https://scheme.org")) "https://scheme.org")
|
||||
(define test-url-string "https://scheme.org")
|
||||
(debug test-url-string)
|
||||
(define test-url (pffi-string->pointer test-url-string))
|
||||
(debug test-url)
|
||||
(debug (pffi-pointer->string test-url))
|
||||
(assert equal? (string=? (pffi-pointer->string test-url) test-url-string) #t)
|
||||
|
||||
;; pffi-size-of
|
||||
|
||||
|
|
@ -104,24 +96,62 @@
|
|||
(assert equal? (number? size-int8) #t)
|
||||
(assert = size-int8 1)
|
||||
|
||||
(define size-uint8 (pffi-size-of 'uint8))
|
||||
(debug size-uint8)
|
||||
(assert equal? (number? (pffi-size-of 'uint8)) #t)
|
||||
(define size-int16 (pffi-size-of 'int16))
|
||||
(debug size-int16)
|
||||
(assert equal? (number? (pffi-size-of 'int16)) #t)
|
||||
(define size-uint16 (pffi-size-of 'uint16))
|
||||
(debug size-uint16)
|
||||
(assert equal? (number? (pffi-size-of 'uint16)) #t)
|
||||
(define size-int32 (pffi-size-of 'int32))
|
||||
(debug size-int32)
|
||||
(assert equal? (number? (pffi-size-of 'int32)) #t)
|
||||
(define size-uint32 (pffi-size-of 'uint32))
|
||||
(debug size-uint32)
|
||||
(assert equal? (number? (pffi-size-of 'uint32)) #t)
|
||||
(define size-int64 (pffi-size-of 'int64))
|
||||
(debug size-int64)
|
||||
(assert equal? (number? (pffi-size-of 'int64)) #t)
|
||||
(define size-uint64 (pffi-size-of 'uint64))
|
||||
(debug size-uint64)
|
||||
(assert equal? (number? (pffi-size-of 'uint64)) #t)
|
||||
(define size-char (pffi-size-of 'char))
|
||||
(debug size-char)
|
||||
(assert equal? (number? (pffi-size-of 'char)) #t)
|
||||
(define size-unsigned-char (pffi-size-of 'unsigned-char))
|
||||
(debug size-unsigned-char)
|
||||
(assert equal? (number? (pffi-size-of 'unsigned-char)) #t)
|
||||
(define size-short (pffi-size-of 'short))
|
||||
(debug size-short)
|
||||
(assert equal? (number? (pffi-size-of 'short)) #t)
|
||||
(define size-unsigned-short (pffi-size-of 'unsigned-short))
|
||||
(debug size-unsigned-short)
|
||||
(assert equal? (number? (pffi-size-of 'unsigned-short)) #t)
|
||||
(define size-int (pffi-size-of 'int))
|
||||
(debug size-int)
|
||||
(assert equal? (number? (pffi-size-of 'int)) #t)
|
||||
(define size-unsigned-int (pffi-size-of 'unsigned-int))
|
||||
(debug size-unsigned-int)
|
||||
(assert equal? (number? (pffi-size-of 'unsigned-int)) #t)
|
||||
(define size-long (pffi-size-of 'long))
|
||||
(debug size-long)
|
||||
(assert equal? (number? (pffi-size-of 'long)) #t)
|
||||
(define size-unsigned-long (pffi-size-of 'unsigned-long))
|
||||
(debug size-unsigned-long)
|
||||
(assert equal? (number? (pffi-size-of 'unsigned-long)) #t)
|
||||
(define size-float (pffi-size-of 'float))
|
||||
(debug size-float)
|
||||
(assert equal? (number? (pffi-size-of 'float)) #t)
|
||||
(define size-double (pffi-size-of 'double))
|
||||
(debug size-double)
|
||||
(assert equal? (number? (pffi-size-of 'double)) #t)
|
||||
(define size-string (pffi-size-of 'string))
|
||||
(debug size-string)
|
||||
(assert equal? (number? (pffi-size-of 'string)) #t)
|
||||
(define size-pointer (pffi-size-of 'pointer))
|
||||
(debug size-pointer)
|
||||
(assert equal? (number? (pffi-size-of 'pointer)) #t)
|
||||
|
||||
;; pffi-pointer-allocate
|
||||
|
|
@ -140,22 +170,6 @@
|
|||
(debug null-pointer)
|
||||
(assert equal? (pffi-pointer-null? null-pointer) #t)
|
||||
|
||||
;; pffi-string->pointer
|
||||
|
||||
(print-header 'pffi-string->pointer)
|
||||
|
||||
(define string-pointer (pffi-string->pointer "Hello world"))
|
||||
(debug string-pointer)
|
||||
(assert equal? (pffi-pointer? string-pointer) #t)
|
||||
|
||||
;; pffi-pointer->string
|
||||
|
||||
(print-header 'pffi-pointer->string)
|
||||
|
||||
(define pointer-string (pffi-pointer->string string-pointer))
|
||||
(debug pointer-string)
|
||||
(assert string=? pointer-string "Hello world")
|
||||
|
||||
;; pffi-pointer-free
|
||||
|
||||
(print-header 'pffi-pointer-free)
|
||||
|
|
@ -192,9 +206,9 @@
|
|||
|
||||
(print-header "pffi-pointer-set! and pffi-pointer-get")
|
||||
|
||||
(define set-pointer (pffi-pointer-allocate 100))
|
||||
(define set-pointer (pffi-pointer-allocate 256))
|
||||
(define offset 50)
|
||||
(define value 10)
|
||||
(define value 1)
|
||||
(debug set-pointer)
|
||||
(debug offset)
|
||||
(debug value)
|
||||
|
|
@ -220,15 +234,25 @@
|
|||
(test-type 'unsigned-int)
|
||||
(test-type 'long)
|
||||
(test-type 'unsigned-long)
|
||||
(test-type 'float)
|
||||
(test-type 'double)
|
||||
|
||||
(pffi-pointer-set! set-pointer 'float offset 1.5)
|
||||
(debug (pffi-pointer-get set-pointer 'float offset))
|
||||
(assert = (pffi-pointer-get set-pointer 'float offset) 1.5)
|
||||
(pffi-pointer-set! set-pointer 'double offset 1.5)
|
||||
(debug (pffi-pointer-get set-pointer 'double offset))
|
||||
(assert = (pffi-pointer-get set-pointer 'double offset) 1.5)
|
||||
|
||||
(define pointer-to-be-set (pffi-string->pointer "FOOBAR"))
|
||||
(debug pointer-to-be-set)
|
||||
(pffi-pointer-set! set-pointer 'pointer offset pointer-to-be-set)
|
||||
(debug (pffi-pointer-get set-pointer 'pointer offset))
|
||||
(assert equal?
|
||||
(pffi-pointer? (pffi-pointer-get set-pointer 'pointer offset))
|
||||
#t)
|
||||
(debug (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)))
|
||||
(assert equal?
|
||||
(string? (pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset)))
|
||||
#t)
|
||||
(assert string=?
|
||||
(pffi-pointer->string (pffi-pointer-get set-pointer 'pointer offset))
|
||||
"FOOBAR")
|
||||
|
|
@ -256,6 +280,66 @@
|
|||
(string=? pffi-os-name "unix"))
|
||||
#t)
|
||||
|
||||
;; pffi-define
|
||||
|
||||
(print-header 'pffi-define)
|
||||
|
||||
|
||||
(pffi-define atoi libc-stdlib 'atoi 'int (list 'pointer))
|
||||
(assert = (atoi (pffi-string->pointer "100")) 100)
|
||||
|
||||
;; pffi-define-callback
|
||||
|
||||
(print-header 'pffi-define-callback)
|
||||
|
||||
(define libcurl (pffi-shared-object-auto-load (list "curl/curl.h") ; Headers
|
||||
(list ".") ; Additional search paths
|
||||
"curl" ; The named of shared object without the lib prefix
|
||||
(list ".4")))
|
||||
(pffi-define curl-easy-init libcurl 'curl_easy_init 'pointer (list))
|
||||
(pffi-define curl-easy-setopt libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'pointer))
|
||||
(pffi-define curl-easy-setopt-url libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'string))
|
||||
(pffi-define curl-easy-setopt-callback libcurl 'curl_easy_setopt 'int (list 'pointer 'int 'callback))
|
||||
(pffi-define curl-easy-getinfo libcurl 'curl_easy_getinfo 'int (list 'pointer 'int 'pointer))
|
||||
(pffi-define curl-easy-perform libcurl 'curl_easy_perform 'int (list 'pointer))
|
||||
(pffi-define curl-easy-strerror libcurl 'curl_easy_strerror 'string (list 'int))
|
||||
(define CURLOPT-WRITEFUNCTION 20011)
|
||||
(define CURLOPT-FOLLOWLOCATION 52)
|
||||
(define CURLOPT-URL 10002)
|
||||
(define CURLINFO-RESPONSE-CODE 2097154)
|
||||
|
||||
(define result "")
|
||||
(pffi-define-callback collect-result
|
||||
'void
|
||||
(list 'pointer 'int 'int 'pointer)
|
||||
(lambda (pointer size nmemb client-pointer)
|
||||
(set! result (string-append result (string-copy (pffi-pointer->string pointer))))))
|
||||
|
||||
(define handle (curl-easy-init))
|
||||
(define url "https://scheme.org")
|
||||
(debug url)
|
||||
(define curl-code1 (curl-easy-setopt-url handle CURLOPT-FOLLOWLOCATION url))
|
||||
(debug curl-code1)
|
||||
(when (not (= curl-code1 0)) (error (curl-easy-strerror curl-code1)))
|
||||
(assert = curl-code1 0)
|
||||
|
||||
(define curl-code2 (curl-easy-setopt-url handle CURLOPT-URL url))
|
||||
(debug curl-code2)
|
||||
(when (not (= curl-code2 0)) (error (curl-easy-strerror curl-code2)))
|
||||
(assert = curl-code2 0)
|
||||
|
||||
(define curl-code3 (curl-easy-setopt-callback handle CURLOPT-WRITEFUNCTION collect-result))
|
||||
(debug curl-code3)
|
||||
(when (not (= curl-code3 0)) (error (curl-easy-strerror curl-code3)))
|
||||
(assert = curl-code3 0)
|
||||
|
||||
(define curl-code4 (curl-easy-perform handle))
|
||||
(debug curl-code4)
|
||||
(when (not (= curl-code4 0)) (error (curl-easy-strerror curl-code4)))
|
||||
(assert = curl-code4 0)
|
||||
|
||||
(define http-code (pffi-pointer-allocate (pffi-size-of 'int)))
|
||||
(curl-easy-getinfo handle CURLINFO-RESPONSE-CODE http-code)
|
||||
(assert = (pffi-pointer-get http-code 'int 0) 200)
|
||||
|
||||
(exit 0)
|
||||
|
|
|
|||
Loading…
Reference in New Issue