From a319acd01ac950d479d43d77c07d44a9af3012cd Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 27 Feb 2016 20:40:54 -0500
Subject: Add packed record type hack.

This should work well enough until Guile is able to unbox struct fields.

* sly/records.scm (define-packaged-f64-record-type): New syntax.
---
 sly/records.scm | 41 ++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 40 insertions(+), 1 deletion(-)

(limited to 'sly/records.scm')

diff --git a/sly/records.scm b/sly/records.scm
index a7e180d..3ac2fda 100644
--- a/sly/records.scm
+++ b/sly/records.scm
@@ -23,8 +23,12 @@
 ;;; Code:
 
 (define-module (sly records)
+  #:use-module (srfi srfi-4)
   #:use-module (srfi srfi-9)
-  #:export (define-record-type*))
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (rnrs bytevectors)
+  #:export (define-record-type*
+            define-packed-f64-record-type))
 
 (define-syntax-rule (define-record-type* type
                       constructor keyword-constructor
@@ -52,3 +56,38 @@ overridden."
         (lambda* (#:key (inherit default-record)
                         (field (getter inherit)) ...)
           (constructor field ...))))))
+
+;; A little hack until Guile can unbox fields in record types. ;)
+(define-syntax-rule (define-packed-f64-record-type <name>
+                      constructor
+                      box unbox
+                      predicate?
+                      (field index getter setter) ...)
+  (begin
+    (define-record-type <name>
+      (box bv)
+      predicate?
+      (bv unbox))
+
+    (set-record-type-printer! <name>
+      (lambda (obj port)
+        (display "<" port)
+        (display '<name> port)
+        (begin
+          (display " " port)
+          (display 'field port)
+          (display ": " port)
+          (display (getter obj) port))
+        ...
+        (display " >" port)))
+
+    (define-inlinable (constructor field ...)
+      (box (f64vector field ...)))
+
+    (define-inlinable (getter obj)
+      (f64vector-ref (unbox obj) index))
+    ...
+
+    (define-inlinable (setter obj value)
+      (f64vector-set! (unbox obj) index value))
+    ...))
-- 
cgit v1.2.3