Update to latest hoot.

6 files changed, 209 insertions, 87 deletions

diff --git a/Makefile b/Makefile
index 09171f6..a20c180 100644
--- a/Makefile
+++ b/Makefile
@@ -10,3 +10,6 @@ bundle: game.wasm
 
 serve: game.wasm
 	guile web-server.scm
+
+clean:
+	rm game.wasm level.scm
diff --git a/game.scm b/game.scm
index 52c373a..9dd788b 100644
--- a/game.scm
+++ b/game.scm
@@ -161,8 +161,9 @@
               field)))
          ...
          (define setter
-           (let ((i (1+ (- (length '(field ...))
-                           (length (memq 'field '(field ...)))))))
+           (let ((i (+ (- (length '(field ...))
+                          (length (memq 'field '(field ...))))
+                       1)))
              (lambda (obj val)
                (match obj
                  (#('name field ...)
@@ -172,38 +173,10 @@
      (define (assert-float x)
        (unless (and (number? x) (inexact? x) (rational? x))
          (error "expected inexact rational" x)))
-     (define (truncate x)
-       (assert-float x)
-       (%inline-wasm
-        '(func (param $x (ref eq)) (result (ref eq))
-               (call $s64->scm
-                     (i64.trunc_f64_s
-                      (struct.get $flonum $val (ref.cast $flonum (local.get $x))))))
-        x))
      (define (fmod x y)
        (assert-float x)
        (assert-float y)
-       (%inline-wasm
-        '(func (param $x (ref eq)) (param $y (ref eq)) (result (ref eq))
-               (struct.new
-                $flonum
-                (i32.const 0)
-                (f64.sub (struct.get
-                          $flonum $val
-                          (ref.cast $flonum (local.get $x)))
-                         (f64.mul
-                          (f64.trunc
-                           (f64.div
-                            (struct.get $flonum $val
-                                        (ref.cast $flonum
-                                                  (local.get $x)))
-                            (struct.get $flonum $val
-                                        (ref.cast $flonum
-                                                  (local.get $y)))))
-                          (struct.get $flonum $val
-                                      (ref.cast $flonum
-                                                (local.get $y)))))))
-        x y))
+       (- x (* (truncate (/ x y)) y)))
 
      (define s32-ref bytevector-s32-native-ref)
      (define s32-set! bytevector-s32-native-set!)
@@ -696,8 +669,8 @@
      (define (point-collides-with-level? level x y)
        (match level
          (#('level height foreground collision objects)
-          (let ((tx (truncate (/ x tile-width)))
-                (ty (truncate (/ y tile-height))))
+          (let ((tx (exact (truncate (/ x tile-width))))
+                (ty (exact (truncate (/ y tile-height)))))
             (and (>= tx 0) (< tx level-width)
                  (>= ty 0) (< tx height)
                  (= (bytevector-u8-ref collision (level-offset tx ty)) 1))))))
@@ -705,10 +678,10 @@
        (match level
          (#('level height foreground collision objects)
           (let* ((y (+ y (- (* height tile-height) game-height *scroll*)))
-                 (tx0 (truncate (/ x tile-width)))
-                 (ty0 (truncate (/ y tile-height)))
-                 (tx1 (truncate (/ (+ x w) tile-width)))
-                 (ty1 (truncate (/ (+ y h) tile-height))))
+                 (tx0 (exact (truncate (/ x tile-width))))
+                 (ty0 (exact (truncate (/ y tile-height))))
+                 (tx1 (exact (truncate (/ (+ x w) tile-width))))
+                 (ty1 (exact (truncate (/ (+ y h) tile-height)))))
             (define (occupied? x y)
               (and (>= x 0) (< x level-width)
                    (>= y 0) (< x height)
@@ -724,7 +697,7 @@
                  (th tile-height)
                  (scroll (* *scroll* parallax))
                  (pixel-y-offset (- (* height th) scroll game-height))
-                 (scroll-y-offset (- height (truncate (/ scroll tile-height))))
+                 (scroll-y-offset (- height (exact (truncate (/ scroll tile-height)))))
                  (y-start (clamp (- scroll-y-offset 21) 0 height))
                  (y-end (clamp scroll-y-offset 0 height)))
             (do ((y y-start (+ y 1)))
@@ -774,10 +747,12 @@
           (let ((scroll (min (+ *scroll* *scroll-speed*) max-scroll)))
             (set! *last-scroll* *scroll*)
             (set! *scroll* scroll)
-            (let ((row (max (truncate
-                             (/ (- (* height tile-height)
-                                   game-height scroll)
-                                tile-height))
+            (let ((row (max
+                        (exact
+                         (truncate
+                          (/ (- (* height tile-height)
+                                game-height scroll)
+                             tile-height)))
                             0)))
               (do ((y row (+ y 1)))
                   ((= y *last-row-scanned*))
@@ -872,9 +847,10 @@
            (#('enemy type _ position size _ _ _ spawn-time animation
                      image image-size)
             (let* ((tx (vector-ref animation
-                                   (modulo (truncate
-                                            (/ (- time spawn-time)
-                                               frame-duration))
+                                   (modulo (exact
+                                            (truncate
+                                             (/ (- time spawn-time)
+                                                frame-duration)))
                                            (vector-length animation))))
                    (x (vec2-x position))
                    (y (vec2-y position))
@@ -1697,13 +1673,13 @@
        (let* ((win (current-window))
               (w (window-inner-width win))
               (h (window-inner-height win))
-              (gw (truncate game-width))
-              (gh (truncate game-height))
+              (gw (exact (truncate game-width)))
+              (gh (exact (truncate game-height)))
               (scale (max (min (quotient w gw) (quotient h gh)) 1))
               (cw (* gw scale))
               (ch (* gh scale)))
-         (set-element-width! canvas cw)
-         (set-element-height! canvas ch)
+         (set-element-width! canvas (pk 'canvas-width cw))
+         (set-element-height! canvas (pk 'canvas-height ch))
          (set-image-smoothing-enabled! context 0)
          (set! *canvas-scale* (inexact scale))
          (set! *canvas-width* (* game-width *canvas-scale*))
@@ -2053,6 +2029,24 @@
      (request-animation-frame draw-callback)
      (timeout update-callback dt)))
 
+(define %imports
+  '((scheme base)
+    (only (scheme inexact) atan cos sin sqrt)
+    (scheme time)
+    (only (hoot bytevectors)
+          bytevector-s32-native-ref
+          bytevector-s32-native-set!
+          bytevector-ieee-double-native-ref
+          bytevector-ieee-double-native-set!)
+    (only (hoot control)
+          make-prompt-tag
+          abort-to-prompt
+          call-with-prompt)
+    (hoot ffi)
+    (hoot match)
+    (only (hoot syntax) define-syntax-rule define*)
+    (hoot debug)))
+
 (call-with-output-file "game.wasm"
   (lambda (port)
-    (put-bytevector port (assemble-wasm (compile src)))))
+    (put-bytevector port (assemble-wasm (compile src #:imports %imports)))))
diff --git a/js-runtime/reflect.js b/js-runtime/reflect.js
index 5ee2928..172f187 100644
--- a/js-runtime/reflect.js
+++ b/js-runtime/reflect.js
@@ -165,6 +165,7 @@ class Scheme {
             await instantiate_streaming('js-runtime/reflect.wasm', {
               abi,
               rt: {
+                  die(tag, data) { throw new SchemeTrapError(tag, data); },
                   wtf8_to_string(wtf8) { return wtf8_to_string(wtf8); },
                   string_to_wtf8(str) { return string_to_wtf8(str); },
               }
@@ -352,7 +353,22 @@ function wtf8_to_string(wtf8) {
     let iter = as_iter(wtf8);
     for (let cp = iter_next(iter); cp != -1; cp = iter_next(iter))
         codepoints.push(cp);
-    return String.fromCodePoint(...codepoints);
+
+    // Passing too many codepoints can overflow the stack.
+    let maxcp = 100000;
+    if (codepoints.length <= maxcp) {
+        return String.fromCodePoint(...codepoints);
+    }
+
+    // For converting large strings, concatenate several smaller
+    // strings.
+    let substrings = [];
+    let end = 0;
+    for (let start = 0; start != codepoints.length; start = end) {
+        end = Math.min(start + maxcp, codepoints.length);
+        substrings.push(String.fromCodePoint(...codepoints.slice(start, end)));
+    }
+    return substrings.join('');
 }
 
 function string_to_wtf8(str) {
@@ -473,25 +489,131 @@ class SchemeModule {
 
     constructor(instance) {
         this.#instance = instance;
-        let read_stdin = () => '';
-        if (typeof printErr === 'function') {
+        if (typeof printErr === 'function') { // v8/sm dev console
             // On the console, try to use 'write' (v8) or 'putstr' (sm),
             // as these don't add an extraneous newline.  Unfortunately
             // JSC doesn't have a printer that doesn't add a newline.
             let write_no_newline =
                 typeof write === 'function' ? write
                 : typeof putstr === 'function' ? putstr : print;
+            // Use readline when available.  v8 strips newlines so
+            // we need to add them back.
+            let read_stdin =
+                typeof readline == 'function' ? () => {
+                    let line = readline();
+                    if (line) {
+                        return `${line}\n`;
+                    } else {
+                        return '\n';
+                    }
+                }: () => '';
+            let delete_file = (filename) => false;
             this.#io_handler = {
                 write_stdout: write_no_newline,
                 write_stderr: printErr,
-                read_stdin
+                read_stdin,
+                file_exists: (filename) => false,
+                open_input_file: (filename) => {},
+                open_output_file: (filename) => {},
+                close_file: () => undefined,
+                read_file: (handle, length) => 0,
+                write_file: (handle, length) => 0,
+                seek_file: (handle, offset, whence) => -1,
+                file_random_access: (handle) => false,
+                file_buffer_size: (handle) => 0,
+                file_buffer_ref: (handle, i) => 0,
+                file_buffer_set: (handle, i, x) => undefined,
+                delete_file: (filename) => undefined
             };
-        } else {
+        } else if (typeof window !== 'undefined') { // web browser
             this.#io_handler = {
                 write_stdout: console.log,
                 write_stderr: console.error,
-                read_stdin
-            }
+                read_stdin: () => '',
+                file_exists: (filename) => false,
+                open_input_file: (filename) => {},
+                open_output_file: (filename) => {},
+                close_file: () => undefined,
+                read_file: (handle, length) => 0,
+                write_file: (handle, length) => 0,
+                seek_file: (handle, offset, whence) => -1,
+                file_random_access: (handle) => false,
+                file_buffer_size: (handle) => 0,
+                file_buffer_ref: (handle, i) => 0,
+                file_buffer_set: (handle, i, x) => undefined,
+                delete_file: (filename) => undefined
+            };
+        } else { // nodejs
+            const fs = require('fs');
+            const process = require('process');
+            const bufLength = 1024;
+            const stdinBuf = Buffer.alloc(bufLength);
+            const SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2;
+            this.#io_handler = {
+                write_stdout: console.log,
+                write_stderr: console.error,
+                read_stdin: () => {
+                    let n = fs.readSync(process.stdin.fd, stdinBuf, 0, stdinBuf.length);
+                    return stdinBuf.toString('utf8', 0, n);
+                },
+                file_exists: fs.existsSync.bind(fs),
+                open_input_file: (filename) => {
+                    let fd = fs.openSync(filename, 'r');
+                    return {
+                        fd,
+                        buf: Buffer.alloc(bufLength),
+                        pos: 0
+                    };
+                },
+                open_output_file: (filename) => {
+                    let fd = fs.openSync(filename, 'w');
+                    return {
+                        fd,
+                        buf: Buffer.alloc(bufLength),
+                        pos: 0
+                    };
+                },
+                close_file: (handle) => {
+                    fs.closeSync(handle.fd);
+                },
+                read_file: (handle, count) => {
+                    const n = fs.readSync(handle.fd, handle.buf, 0, count, handle.pos);
+                    handle.pos += n;
+                    return n;
+                },
+                write_file: (handle, count) => {
+                    const n = fs.writeSync(handle.fd, handle.buf, 0, count, handle.pos);
+                    handle.pos += n;
+                    return n;
+                },
+                seek_file: (handle, offset, whence) => {
+                    // There doesn't seem to be a way to ask NodeJS if
+                    // a position is valid or not.
+                    if (whence == SEEK_SET) {
+                        handle.pos = offset;
+                        return handle.pos;
+                    } else if (whence == SEEK_CUR) {
+                        handle.pos += offset;
+                        return handle.pos;
+                    }
+
+                    // SEEK_END not supported.
+                    return -1;
+                },
+                file_random_access: (handle) => {
+                    return true;
+                },
+                file_buffer_size: (handle) => {
+                    return handle.buf.length;
+                },
+                file_buffer_ref: (handle, i) => {
+                    return handle.buf[i];
+                },
+                file_buffer_set: (handle, i, x) => {
+                    handle.buf[i] = x;
+                },
+                delete_file: fs.rmSync.bind(fs)
+            };
         }
         this.#debug_handler = {
             debug_str(x) { console.log(`debug: ${x}`); },
@@ -505,7 +627,19 @@ class SchemeModule {
             write_stdout(str) { mod.#io_handler.write_stdout(str); },
             write_stderr(str) { mod.#io_handler.write_stderr(str); },
             read_stdin() { return mod.#io_handler.read_stdin(); },
-        }
+            file_exists(filename) { return mod.#io_handler.file_exists(filename); },
+            open_input_file(filename) { return mod.#io_handler.open_input_file(filename); },
+            open_output_file(filename) { return mod.#io_handler.open_output_file(filename); },
+            close_file(handle) { mod.#io_handler.close_file(handle); },
+            read_file(handle, length) { return mod.#io_handler.read_file(handle, length); },
+            write_file(handle, length) { return mod.#io_handler.write_file(handle, length); },
+            seek_file(handle, offset, whence) { return mod.#io_handler.seek_file(handle, offset, whence); },
+            file_random_access(handle) { return mod.#io_handler.file_random_access(handle); },
+            file_buffer_size(handle) { return mod.#io_handler.file_buffer_size(handle); },
+            file_buffer_ref(handle, i) { return mod.#io_handler.file_buffer_ref(handle, i); },
+            file_buffer_set(handle, i, x) { return mod.#io_handler.file_buffer_set(handle, i, x); },
+            delete_file(filename) { mod.#io_handler.delete_file(filename); }
+        };
         let debug = {
             debug_str(x) { mod.#debug_handler.debug_str(x); },
             debug_str_i32(x, y) { mod.#debug_handler.debug_str_i32(x, y); },
diff --git a/js-runtime/reflect.wasm b/js-runtime/reflect.wasm
index 68441b9..770c94c 100644
--- a/js-runtime/reflect.wasm
+++ b/js-runtime/reflect.wasm
diff --git a/manifest.scm b/manifest.scm
index 690128b..a2e24be 100644
--- a/manifest.scm
+++ b/manifest.scm
@@ -13,31 +13,21 @@
              (gnu packages pkg-config)
              (gnu packages texinfo))
 
-;; (define guile-hoot*
-;;   (let ((commit "90b9c8c8ece2b60ccaf7cad6228234feb7c1e734")
-;;         (revision "1"))
-;;     (package
-;;       (name "guile-hoot")
-;;       (version (git-version "0.2.0" revision commit))
-;;       (source (origin
-;;                 (method git-fetch)
-;;                 (uri (git-reference
-;;                       (url "https://gitlab.com/spritely/guile-hoot.git")
-;;                       (commit commit)))
-;;                 (file-name (git-file-name "guile-hoot" version))
-;;                 (sha256
-;;                  (base32 "09km5i3yj4zklvm1jc2j6qrha47xywscxw2djwljxrwmzxawz865"))))
-;;       (build-system gnu-build-system)
-;;       (arguments
-;;        '(#:make-flags '("GUILE_AUTO_COMPILE=0")
-;;          #:tests? #f))
-;;       (native-inputs
-;;        (list autoconf automake pkg-config texinfo))
-;;       (inputs
-;;        (list guile-next))
-;;       (synopsis "WASM compiler for Guile Scheme")
-;;       (description "Guile-hoot is an ahead-of-time WebAssembly compiler for GNU Guile.")
-;;       (home-page "https://spritely.institute/hoot/")
-;;       (license (list license:asl2.0 license:lgpl3+)))))
+(define guile-hoot-next
+  (let ((commit "f161d83c51bb39b372fd9d5d102841c2a4d6d524")
+        (revision "1"))
+    (package
+      (inherit guile-hoot)
+      (version (git-version "0.3.0" revision commit))
+      (source (origin
+                (method git-fetch)
+                (uri (git-reference
+                      (url "https://gitlab.com/spritely/guile-hoot.git")
+                      (commit commit)))
+                (file-name (git-file-name "guile-hoot" version))
+                (sha256
+                 (base32 "1wr170q2rsd1bg7gbcp28f1nm8fxxkdlgijs68ssdf231vr8gq1w"))))
+      (native-inputs
+       (list autoconf automake pkg-config texinfo)))))
 
-(packages->manifest (list guile-next guile-hoot gnu-make zip))
+(packages->manifest (list guile-next guile-hoot-next gnu-make zip))
diff --git a/web-server.scm b/web-server.scm
index 86a6902..e21eb42 100644
--- a/web-server.scm
+++ b/web-server.scm
@@ -153,5 +153,6 @@ FILE-NAME."
   "Run a simple HTTP server that serves files in WORK-DIR."
   (run-server (make-handler work-dir) 'http open-params))
 
-(when (batch-mode?)
-  (serve (getcwd) #:open-params `(#:port 8088 #:addr ,INADDR_ANY)))
+(let ((port 8088))
+  (format #t "Serving on http://localhost:~a\n" port)
+  (serve (getcwd) #:open-params `(#:port ,port #:addr ,INADDR_ANY)))