Add applicable records

Fixes #267 (closed)

lib/hoot/procedures.scm

@@ -34,22 +34,24 @@
           (hoot inline-wasm)
           (hoot syntax))
 
+  ;; Can't use applicable-struct? from (hoot applicable-structs) as it
+  ;; would create a module cycle.
+  (define (applicable-struct? x)
+    (and (%struct? x)
+         (let ((parents (%inline-wasm
+                         '(func (param $vtable (ref $vtable))
+                                (result (ref eq))
+                                (call $vtable-parents (local.get $vtable)))
+                         (%struct-vtable x))))
+           (if (%eq? (%vector-length parents) 0)
+               #f
+               (%eq? (%inline-wasm
+                      '(func (result (ref eq))
+                             (global.get $applicable-struct-vtable)))
+                     (%vector-ref parents 0))))))
+
   (define (procedure? x)
-    (or (%procedure? x)
-        ;; Can't call applicable-struct? here as it would create a
-        ;; module cycle.
-        (and (%struct? x)
-             (let ((parents (%inline-wasm
-                             '(func (param $vtable (ref $vtable))
-                                    (result (ref eq))
-                                    (call $vtable-parents (local.get $vtable)))
-                             (%struct-vtable x))))
-               (if (%eq? (%vector-length parents) 0)
-                   #f
-                   (%eq? (%inline-wasm
-                          '(func (result (ref eq))
-                                 (global.get $applicable-struct-vtable)))
-                         (%vector-ref parents 0)))))))
+    (or (%procedure? x) (applicable-struct? x)))
 
   (cond-expand
    (guile-vm
@@ -58,15 +60,28 @@
       #f))
    (hoot
     (define (procedure-name proc)
-      (check-type proc procedure? 'procedure-name)
-      (%inline-wasm
-       '(func (param $proc (ref $proc)) (result (ref eq))
-              (local $maybe-string (ref null string))
-              (call $code-name (struct.get $proc $func (local.get $proc)))
-              (local.set $maybe-string)
-              (if (ref eq)
-                  (ref.is_null (local.get $maybe-string))
-                  (then (ref.i31 (i32.const 1)))
-                  (else (struct.new $string (i32.const 0)
-                                    (ref.as_non_null (local.get $maybe-string))))))
-       proc)))))
+      (cond
+       ((%procedure? proc)
+        (%inline-wasm
+         '(func (param $proc (ref $proc)) (result (ref eq))
+                (local $maybe-string (ref null string))
+                (call $code-name (struct.get $proc $func (local.get $proc)))
+                (local.set $maybe-string)
+                (if (ref eq)
+                    (ref.is_null (local.get $maybe-string))
+                    (then (ref.i31 (i32.const 1)))
+                    (else
+                     (call $string->symbol
+                           (struct.new $string (i32.const 0)
+                                       (ref.as_non_null
+                                        (local.get $maybe-string)))))))
+         proc))
+       ((applicable-struct? proc)
+        (procedure-name
+         (%inline-wasm
+          '(func (param $struct (ref $struct/1)) (result (ref eq))
+                 (struct.get $struct/1 $field0
+                             (local.get $struct)))
+          proc)))
+       (else
+        (raise (make-type-error proc 'procedure-name 'procedure?))))))))