Skip to content
Snippets Groups Projects

Add applicable records

Merged David Thompson requested to merge applicable-structs into main
1 unresolved thread
Compare and Show latest version
3 files
+ 44
29
Compare changes
  • Side-by-side
  • Inline
Files
3
+ 42
27
@@ -34,22 +34,24 @@
@@ -34,22 +34,24 @@
(hoot inline-wasm)
(hoot inline-wasm)
(hoot syntax))
(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)
(define (procedure? x)
(or (%procedure? x)
(or (%procedure? x) (applicable-struct? 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)))))))
(cond-expand
(cond-expand
(guile-vm
(guile-vm
@@ -58,15 +60,28 @@
@@ -58,15 +60,28 @@
#f))
#f))
(hoot
(hoot
(define (procedure-name proc)
(define (procedure-name proc)
(check-type proc procedure? 'procedure-name)
(cond
(%inline-wasm
((%procedure? proc)
'(func (param $proc (ref $proc)) (result (ref eq))
(%inline-wasm
(local $maybe-string (ref null string))
'(func (param $proc (ref $proc)) (result (ref eq))
(call $code-name (struct.get $proc $func (local.get $proc)))
(local $maybe-string (ref null string))
(local.set $maybe-string)
(call $code-name (struct.get $proc $func (local.get $proc)))
(if (ref eq)
(local.set $maybe-string)
(ref.is_null (local.get $maybe-string))
(if (ref eq)
(then (ref.i31 (i32.const 1)))
(ref.is_null (local.get $maybe-string))
(else (struct.new $string (i32.const 0)
(then (ref.i31 (i32.const 1)))
(ref.as_non_null (local.get $maybe-string))))))
(else
proc)))))
(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?))))))))
Loading