Add read-leab128 and read-uleab128

Makefile

@@ -6,30 +6,33 @@ AUTHOR=retropikzel
 PKG=${AUTHOR}-${LIBRARY}-${VERSION}.tgz
 
 LIBRARY_FILE=retropikzel/${LIBRARY}.sld
-VERSION=$(shell cat retropikzel/${LIBRARY}/VERSION)
-DESCRIPTION=$(shell head -n1 retropikzel/${LIBRARY}/README.md)
-README=retropikzel/${LIBRARY}/README.html
 TESTFILE=retropikzel/${LIBRARY}/test.scm
+VERSION != cat retropikzel/${LIBRARY}/VERSION
+DESCRIPTION != head -n1 retropikzel/${LIBRARY}/README.md
+README=retropikzel/${LIBRARY}/README.html
 
-SFX=scm
+SFX != if [ "${RNRS}" = "r6rs" ]; then echo "sps"; else echo "scm"; fi
-SNOW=snow-chibi --impls=${SCHEME} install --always-yes
+SNOW != if [ "${RNRS}" = "r6rs" ]; then echo "snow-chibi --impls=${SCHEME} install --always-yes --install-source-dir=. --install-library-dir=."; else echo "snow-chibi --impls=${SCHEME} install --always-yes"; fi
-LIB_PATHS=
+LIB_PATHS != if [ "${RNRS}" = "r6rs" ]; then echo "-I .akku/lib"; else echo ""; fi
-ifeq "${RNRS}" "r6rs"
+SNOW_TEST != if [ -f "retropikzel/${LIBRARY}/snow-test.scm" ]; echo "--test=retropikzel/${LIBRARY}/snow-test.scm"; else echo ""; fi
-SNOW=snow-chibi --impls=${SCHEME} install --always-yes --install-source-dir=. --install-library-dir=.
-SFX=sps
-LIB_PATHS=-I .akku/lib
-endif
 
-all: build
+all: package
 
-build: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md
+package: retropikzel/${LIBRARY}/LICENSE retropikzel/${LIBRARY}/VERSION retropikzel/${LIBRARY}/README.md
 	echo "<pre>$$(cat retropikzel/${LIBRARY}/README.md)</pre>" > ${README}
-	snow-chibi package --always-yes --version=${VERSION} --authors=${AUTHOR} --doc=${README} --description="${DESCRIPTION}" ${LIBRARY_FILE}
+	snow-chibi package \
+		--always-yes \
+		--version=${VERSION} \
+		--authors=${AUTHOR} \
+		--doc=${README} \
+		${SNOW_TEST} \
+		--description="${DESCRIPTION}" \
+		${LIBRARY_FILE}
 
 install:
 	snow-chibi install --impls=${SCHEME} --always-yes ${PKG}
 
-testfiles: build
+testfiles: package ${TESTFILE}
 	rm -rf .tmp
 	mkdir -p .tmp
 	cp ${PKG} .tmp/
@@ -44,6 +47,7 @@ test-docker: testfiles
 	cd .tmp && SNOW_PACKAGES="srfi.64 srfi.60 srfi.145 srfi.180 retropikzel.mouth" \
 		APT_PACKAGES="libcurl4-openssl-dev" \
 		COMPILE_R7RS=${SCHEME} \
+		TEST_R7RS_DEBUG=1 \
 		CSC_OPIONS="-L -lcurl" \
 		test-r7rs test.${SFX} ${PKG}
 

retropikzel/leb128.scm

@@ -111,3 +111,56 @@
              (not (exact-integer? (car start-index))))
     (error "uleb128->integer: start-index must be exact integer" (car start-index)))
   (car (uleb128->integer-and-length bytes (if (null? start-index) 0 (car start-index)))))
+
+(define (read-leb128-and-length port)
+  (when (not (binary-port? port))
+    (error "read-leb128-and-length: port must be binary-port" port))
+  (letrec*
+    ((result 0)
+     (shift 0)
+     (byte #f)
+     (looper
+       (lambda ()
+         (set! byte (read-u8 port))
+         (set! result (+ result (arithmetic-shift (bitwise-and byte #x7f) shift)))
+         (when (not (= (bitwise-and byte #x80) 0))
+           (set! shift (+ shift 7))
+           (set! index (+ index 1))
+           (looper)))))
+    (looper)
+    (cons
+      (if (not (= (bitwise-and byte #x40) 0))
+        (bitwise-ior result (* (arithmetic-shift 1 (+ shift 7)) -1))
+        result)
+      (+ index 1))))
+
+(define (read-leb128 port)
+  (when (not (binary-port? port))
+    (error "read-leb128: port must be binary-port" port))
+  (cdr (read-leb128-and-length port)))
+
+(define (read-uleb128-and-length port)
+  (when (not (binary-port? port))
+    (error "read-uleb128: port must be binary port" port))
+  (letrec*
+    ((uleb-bytes-count 1)
+     (byte (read-u8 port))
+     (shift 0)
+     (result (arithmetic-shift (bitwise-and byte #x7f) shift))
+     (looper
+       (lambda ()
+         (cond
+           ((= (bitwise-and byte #x80) 0) (cons result uleb-bytes-count))
+           (else
+             (set! uleb-bytes-count (+ uleb-bytes-count 1))
+             (set! byte (read-u8 port))
+             (set! result (bitwise-ior result (arithmetic-shift (bitwise-and byte #x7f) shift)))
+             (set! shift (+ shift 7))
+             (looper))))))
+    (set! shift (+ shift 7))
+    (looper)))
+
+(define (read-uleb128 port)
+  (when (not (binary-port? port))
+    (error "read-uleb128: port must be binary-port" port))
+  (cdr (read-uleb128-and-length port)))

retropikzel/leb128.sld

@@ -8,5 +8,9 @@
           leb128->integer-and-length
           integer->uleb128
           uleb128->integer
-          uleb128->integer-and-length)
+          uleb128->integer-and-length
+          read-leb128
+          read-leb128-and-length
+          read-uleb128
+          read-uleb128-and-length)
   (include "leb128.scm"))

retropikzel/leb128/README.md

@@ -43,6 +43,15 @@ positive integer or 0 of uleb128 value.
 Sams as uleb128->integer but returns a pair with integer as car and uleb128
 bytevector length, as in how many bytes long the leb128 was, as cdr.
 
+(**read-uleb12** port)
+
+Read uleb128 from given port. *port* must be binary inpurt port.  Returns exact
+positive integer or 0 of uleb128 value.
+
+(**read-leb12** port)
+
+Read leb128 from given port. *port* must be binary inpurt port. Returns exact
+integer of leb128 value.
 
 Resources used:
     https://en.wikipedia.org/wiki/LEB128

retropikzel/mouth/snow-test.scm

@@ -0,0 +1,15 @@
+(import (scheme base)
+        (retropikzel mouth)
+        (srfi 64))
+
+(test-begin "mouth")
+
+(spit "/tmp/mouthtestfile" "Hello world")
+
+(test-assert (string=? (slurp "/tmp/mouthtestfile") "Hello world"))
+
+(spit "/tmp/mouthtestfile" ", and append" #t)
+
+(test-assert (string=? (slurp "/tmp/mouthtestfile") "Hello world, and append"))
+
+(test-end "mouth")

retropikzel/r7rs-tests.scm

@@ -0,0 +1,3 @@
+(define (run-r7rs-tests)
+  (display "To run r7rs-tests run this packages test with snow-chibi")
+  (newline))

retropikzel/r7rs-tests.sld

@@ -0,0 +1,8 @@
+(define-library
+  (retropikzel r7rs-tests)
+  (import (scheme base)
+          (scheme write)
+          (srfi 64)
+          (retropikzel ctrf))
+  (export run-r7rs-tests)
+  (include "r7rs-tests.scm"))

retropikzel/r7rs-tests/LICENSE

@@ -0,0 +1 @@
+WIP

retropikzel/r7rs-tests/README.md

@@ -0,0 +1,3 @@
+R7RS test suite.  Covers all procedures and syntax in the small language except
+`delete-file'.  Currently assumes full-unicode support, the full numeric tower
+and all standard libraries provided.

retropikzel/r7rs-tests/VERSION

@@ -0,0 +1 @@
+1.0.0

retropikzel/wasm.scm

@@ -23,9 +23,6 @@
 
 (define (bytes->type bytes)
   (let ((first-byte (bytevector-u8-ref bytes 0)))
-    (display "HERE: ")
-    (display first-byte)
-    (newline)
     (cond
       ((equal? first-byte #x7C) 'f64)
       ((equal? first-byte #x7D) 'f32)
@@ -46,39 +43,79 @@
     (looper 0 '())))
 
 (define (section-bytes->sexp name bytes)
+  (let* ((id-and-id-length (leb128->integer-and-length bytes))
+        (data-bytes (bytevector-copy bytes (cdr id-and-id-length)))
+        (data-length (bytevector-length data-bytes))
+        )
   (cond
-    ((equal? name 'type)
+    #;((equal? name 'type)
      (let* ((number-of-types (leb128->integer-and-length bytes))
             (types (bytes->types (bytevector-copy bytes (cdr number-of-types)))))
-       (display "TYPE: ")
+       (display "TYPE: type, content = ")
        (write bytes)
        (newline)
        `((number-of-types . ,(car number-of-types))
-         (types . ,types)
+         (types . ,types))))
-         )))
+    ((equal? name 'type)
-    (else '())))
+     (let ((number-of-types (bytevector-u8-ref bytes 0)))
+       (display "TYPE: type ")
+       (write data-length)
+       (newline)
+       (write data-bytes)
+       (newline)
+       (write number-of-types)
+       (newline)
+       '()))
+    (else '()))))
+
+(define (wasm->sexp-old bytes)
+  (let* ((bytes-length (bytevector-length bytes))
+         (magic-bytes (if (> bytes-length 3) (bytevector-copy bytes 0 4) #u8())))
+    (when (not (equal? magic-bytes #u8(#x00 #x61 #x73 #x6D)))
+      (error "Binary is not wasm (missing magic bytes)"))
+    (letrec*
+      ((wasm-version (bytevector-copy bytes 4 8))
+       (section-data '())
+       (index 8) ;; Jump over magic bytes and version
+       (looper (lambda ()
+                 (when (< index bytes-length)
+                   (let* ((id (bytevector-u8-ref bytes index))
+                          (name (section-id->name id))
+                          (len (uleb128->integer-and-length bytes (+ index 1) 0 0))
+                          (data-bytes (bytevector-copy bytes index (+ index (car len)))))
+                     (display "HERE: index ")
+                     (write index)
+                     (newline)
+                     (display "HERE: data-bytes ")
+                     (write data-bytes)
+                     (newline)
+                     (set! section-data
+                       (append section-data
+                               `((id . ,id)
+                                 (name . ,name)
+                                 (data . ,(section-bytes->sexp name data-bytes)))))
+                     (set! index (+ index 1 (car len) (cdr len)))
+                     (looper)
+                     )))))
+      (looper)
+      section-data)))
+
+(define (wasm->sexp port)
+  (let ((magic-bytes (read-bytevector 4 port)))
+    (when (not (equal? magic-bytes #u8(#x00 #x61 #x73 #x6D)))
+      (error "Binary is not wasm (missing magic bytes)"))
+    (let ((version (read-bytevector 4 port)))
+
+    (display "HERE: ")
+    (write magic-bytes)
+    (newline)
+    (write version)
+    (newline)
+    (write (read-uleb128 port))
+    (newline)
+    (write (read-uleb128 port))
+    (newline)
+
+
+    )))
 
-(define (wasm->sexp bytes)
-  (display bytes)
-  (newline)
-  (letrec*
-    ((bytes-length (bytevector-length bytes))
-     (section-data '())
-     (index 8) ;; Jump over magic bytes and version
-     (looper (lambda ()
-               (when (< index bytes-length)
-                 (let* ((id (bytevector-u8-ref bytes index))
-                        (name (section-id->name id))
-                        (len (uleb128->integer-and-length bytes (+ index 1) 0 0))
-                        (data-bytes (bytevector-copy bytes index (+ index (car len)))))
-                   (set! section-data
-                     (append section-data
-                             `((id . ,id)
-                               (name . ,name)
-                               (data . ,(section-bytes->sexp name data-bytes)))))
-                   (set! index (+ index 1 (car len) (cdr len)))
-                   (looper)
-                   )))))
-    (looper)
-     section-data
-    ))

retropikzel/wasm/README.md

@@ -0,0 +1 @@
+WIP

retropikzel/wasm/plus.c

@@ -1,3 +1,9 @@
 int plus(int a, int b) {
     return a + b;
 }
+
+/*
+int plus_three(int a, int b, int c) {
+    return a + b + c;
+}
+*/

retropikzel/wasm/test.scm

@@ -3,12 +3,12 @@
 (define testdir "retropikzel/wasm")
 (define testfile1 (string-append testdir "/" "plus.wasm"))
 
-(when (not (file-exists? testfile1))
+;(when (not (file-exists? testfile1)) (error (string-append testfile1 " does not exist")))
-  (error (string-append testfile1 " does not exist")))
 
-(define bytes (with-input-from-file testfile1 (lambda () (read-bytevector 10000))))
+;(define bytes (with-input-from-file testfile1 (lambda () (read-bytevector 10000))))
 
-(write (wasm->sexp bytes))
+(define sexp (with-input-from-file testfile1 (lambda () (wasm->sexp (current-input-port)))))
+(write sexp)
 (newline)
 
 (test-end "wasm")