From 8772c5355b7c2593c0c4997f4322a23395ad556a Mon Sep 17 00:00:00 2001
From: Justin Ethier <justin.ethier@gmail.com>
Date: Wed, 27 Feb 2019 14:31:14 -0500
Subject: [PATCH] Faster initialization of objects create via
 define-record-type

---
 CHANGELOG.md    |  4 ++++
 scheme/base.sld | 46 +++++++++++++++-------------------------------
 2 files changed, 19 insertions(+), 31 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index c11428dd..650d3e03 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,10 @@
 
 ## 0.9.10 - TBD
 
+Features
+
+- Faster initialization of objects create via `define-record-type`.
+
 ## 0.9.9 - February 19, 2019
 
 Bug Fixes
diff --git a/scheme/base.sld b/scheme/base.sld
index 9a26cf58..fdec5565 100644
--- a/scheme/base.sld
+++ b/scheme/base.sld
@@ -23,6 +23,7 @@
     register-simple-type
     make-type-predicate
     make-constructor
+    make-constructor/args
     make-getter
     make-setter
     slot-ref
@@ -1831,18 +1832,18 @@
          (equal? (vector-ref obj 0) record-marker)
          (equal? (vector-ref obj 1) name))))
 (define (make-constructor make name)
-  (lambda ()
+  (lambda args
     (let* ((field-tags (vector-ref name 2))
            (field-values (make-vector (length field-tags) #f))
-    ;       (new (make-vector 3 #f))
           )
-    ;  (vector-set! new 0 record-marker)
-    ;  (vector-set! new 1 name)
-    ;  (vector-set! new 2 field-values)
-    ;  new
-      (vector record-marker name field-values)
-    )
-    ));
+      (vector record-marker name field-values))))
+(define (make-constructor/args make name)
+  (lambda args
+    (let* ((field-tags (vector-ref name 2))
+           (field-values (list->vector args)))
+      (when (not (equal? (length field-tags) (length args)))
+        (error "invalid number of arguments passed to record type constructor" args))
+      (vector record-marker name field-values))))
 (define (type-slot-offset name sym)
   (let ((field-tags (vector-ref name 2)))
     (_list-index sym field-tags)))
@@ -1940,27 +1941,10 @@
                 fields)
          ;; constructor
          (,_define ,make
-           ,(let lp ((ls make-fields) (sets '()))
-              (cond
-               ((null? ls)
-                `(,_let ((%make (,(rename 'make-constructor)
-                                 ,(symbol->string make) ;(identifier->symbol make))
-                                 ,name)))
-                   (,_lambda ,make-fields
-                     (,_let ((res (%make)))
-                       ,@sets
-                       res))))
-               (else
-                (let ((field (assq (car ls) fields)))
-                  (cond
-                   ((not field)
-                    (error "unknown record field in constructor" (car ls)))
-                   ((pair? (cddr field))
-                    (lp (cdr ls)
-                        (cons `(,(car (cddr field)) res ,(car ls)) sets)))
-                   (else
-                    (lp (cdr ls)
-                        (cons `(,_slot-set! ,name res (,_type_slot_offset ,name ',(car ls)) ,(car ls))
-                              sets)))))))))
+            (,_let ((%make (,(rename 'make-constructor/args)
+                            ,(symbol->string make) ;(identifier->symbol make))
+                            ,name)))
+              (,_lambda ,make-fields
+                (%make ,@make-fields))))
   )))))
 ))