From aafe5f0d684b5478c2438c0c7b376ea24a81564b Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Wed, 31 Jan 2018 19:08:47 -0500
Subject: [PATCH] Record type enhancements

---
 scheme/base.sld | 13 ++++++++++++-
 1 file changed, 12 insertions(+), 1 deletion(-)

diff --git a/scheme/base.sld b/scheme/base.sld
index 04dc8574..200b4e1e 100644
--- a/scheme/base.sld
+++ b/scheme/base.sld
@@ -19,11 +19,13 @@
     ;; Record types
     define-record-type
     record?
+    is-a?
     register-simple-type
     make-type-predicate
     make-constructor
     make-getter
     make-setter
+    slot-ref
     slot-set!
     type-slot-offset
     ;; END records
@@ -1803,6 +1805,10 @@
 (define (slot-set! name obj idx val)
   (let ((vec obj)) ;; TODO: get actual slots from obj
     (vector-set! (vector-ref vec 2) idx val)))
+(define (slot-ref name obj field)
+  ;; TODO: type check
+  ;; TODO: support field as number or symbol
+  (vector-ref (vector-ref obj 2) field))
 (define (make-getter sym name idx)
   (lambda (obj)
     (vector-ref (vector-ref obj 2) idx)))
@@ -1826,6 +1832,11 @@
        (> (vector-length obj) 0)
        (equal? record-marker (vector-ref obj 0))))
 
+(define (is-a? obj rtype)
+  (and (record? obj)
+       (record? rtype)
+       (equal? (vector-ref obj 1) rtype)))
+
 (define-syntax define-record-type
   (er-macro-transformer
    (lambda (expr rename compare)
@@ -1850,7 +1861,7 @@
        `(,(rename 'begin)
          ;; type
          (,_define ,name (,_register 
-                          ,name ;,name-str 
+                          ,name-str 
                           ,parent 
                           ',(map car fields)))
          ;; predicate