From 849cefacf15c265a091aa7d582d14b84f82ddcda Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Sat, 3 May 2008 18:32:46 +0200
Subject: [PATCH] unify variant types and records; also make-foo instead of
 <foo>

* module/system/base/syntax.scm (define-record): Rework to separate the
  type and its constructor. Now (define-record (<foo> bar)) will create
  `make-foo' as the constructor, not `<foo>'. Also the constructor now
  takes either keyword or positional arguments, so that it can be used as
  the implementation of variant types as well.
  (|): Map directly to define-record instead of rolling our own thing.

* module/language/scheme/translate.scm:
* module/system/base/language.scm:
* module/system/il/compile.scm:
* module/system/il/ghil.scm:
* module/system/il/glil.scm:
* module/system/repl/common.scm:
* module/system/vm/assemble.scm:
* module/system/vm/debug.scm: Change instances of record creation to use
  the make-foo procedures instead of <foo>. Adjust module exports as
  necessary.
---
 module/language/scheme/translate.scm | 44 ++++++++--------
 module/system/base/language.scm      |  2 +-
 module/system/base/syntax.scm        | 79 ++++++++++++++--------------
 module/system/il/compile.scm         | 64 +++++++++++-----------
 module/system/il/ghil.scm            | 47 ++++++++---------
 module/system/il/glil.scm            | 28 +++++-----
 module/system/repl/common.scm        | 11 ++--
 module/system/vm/assemble.scm        | 24 ++++-----
 module/system/vm/debug.scm           |  3 +-
 9 files changed, 151 insertions(+), 151 deletions(-)

diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm
index 843a8472a..9757c08f0 100644
--- a/module/language/scheme/translate.scm
+++ b/module/language/scheme/translate.scm
@@ -52,7 +52,7 @@
 
     (call-with-ghil-environment (make-ghil-mod e) '()
       (lambda (env vars)
-	(<ghil-lambda> env #f vars #f (trans env #f x))))))
+	(make-ghil-lambda env #f vars #f (trans env #f x))))))
 
 
 ;;;
@@ -139,9 +139,9 @@
 	((symbol? x)
 	 (let ((y (symbol-expand x)))
 	   (if (symbol? y)
-	       (<ghil-ref> e l (ghil-lookup e y))
+	       (make-ghil-ref e l (ghil-lookup e y))
 	       (trans e l y))))
-	(else (<ghil-quote> e l x))))
+	(else (make-ghil-quote e l x))))
 
 (define (symbol-expand x)
   (let loop ((s (symbol->string x)))
@@ -155,7 +155,7 @@
   (define (trans:x x) (trans e l x))
   (define (trans:pair x) (trans-pair e l (car x) (cdr x)))
   (define (trans:body body) (trans-body e l body))
-  (define (make:void) (<ghil-void> e l))
+  (define (make:void) (make-ghil-void e l))
   (define (bad-syntax)
     (syntax-error l (format #f "bad ~A" head) (cons head tail)))
   (case head
@@ -168,26 +168,26 @@
     ;; (quote OBJ)
     ((quote)
      (match tail
-       ((obj) (<ghil-quote> e l obj))
+       ((obj) (make-ghil-quote e l obj))
        (else (bad-syntax))))
 
     ;; (quasiquote OBJ)
     ((quasiquote)
      (match tail
-       ((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj)))
+       ((obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))
        (else (bad-syntax))))
 
     ((define define-private)
      (match tail
        ;; (define NAME VAL)
        (((? symbol? name) val)
-	(<ghil-define> e l (ghil-lookup e name) (trans:x val)))
+	(make-ghil-define e l (ghil-lookup e name) (trans:x val)))
 
        ;; (define (NAME FORMALS...) BODY...)
        ((((? symbol? name) . formals) . body)
 	;; -> (define NAME (lambda FORMALS BODY...))
 	(let ((val (trans:x `(lambda ,formals ,@body))))
-	  (<ghil-define> e l (ghil-lookup e name) val)))
+	  (make-ghil-define e l (ghil-lookup e name) val)))
 
        (else (bad-syntax))))
 
@@ -203,7 +203,7 @@
      (match tail
        ;; (set! NAME VAL)
        (((? symbol? name) val)
-	(<ghil-set> e l (ghil-lookup e name) (trans:x val)))
+	(make-ghil-set e l (ghil-lookup e name) (trans:x val)))
 
        ;; (set! (NAME ARGS...) VAL)
        ((((? symbol? name) . args) val)
@@ -216,22 +216,22 @@
     ((if)
      (match tail
        ((test then)
-	(<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
+	(make-ghil-if e l (trans:x test) (trans:x then) (make:void)))
        ((test then else)
-	(<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
+	(make-ghil-if e l (trans:x test) (trans:x then) (trans:x else)))
        (else (bad-syntax))))
 
     ;; (and EXPS...)
     ((and)
-     (<ghil-and> e l (map trans:x tail)))
+     (make-ghil-and e l (map trans:x tail)))
 
     ;; (or EXPS...)
     ((or)
-     (<ghil-or> e l (map trans:x tail)))
+     (make-ghil-or e l (map trans:x tail)))
 
     ;; (begin EXPS...)
     ((begin)
-     (<ghil-begin> e l (map trans:x tail)))
+     (make-ghil-begin e l (map trans:x tail)))
 
     ((let)
      (match tail
@@ -243,14 +243,14 @@
        ;; (let () BODY...)
        ((() body ...)
 	;; NOTE: This differs from `begin'
-	(<ghil-begin> e l (list (trans:body body))))
+	(make-ghil-begin e l (list (trans:body body))))
 
        ;; (let ((SYM VAL) ...) BODY...)
        (((((? symbol? sym) val) ...) body ...)
 	(let ((vals (map trans:x val)))
 	  (call-with-ghil-bindings e sym
 	    (lambda (vars)
-	      (<ghil-bind> e l vars vals (trans:body body))))))
+	      (make-ghil-bind e l vars vals (trans:body body))))))
 
        (else (bad-syntax))))
 
@@ -270,7 +270,7 @@
 	(call-with-ghil-bindings e sym
 	  (lambda (vars)
 	    (let ((vals (map trans:x val)))
-	      (<ghil-bind> e l vars vals (trans:body body))))))
+	      (make-ghil-bind e l vars vals (trans:body body))))))
        (else (bad-syntax))))
 
     ;; (cond (CLAUSE BODY...) ...)
@@ -321,7 +321,7 @@
 	(receive (syms rest) (parse-formals formals)
 	  (call-with-ghil-environment e syms
 	    (lambda (env vars)
-	      (<ghil-lambda> env l vars rest (trans-body env l body))))))
+	      (make-ghil-lambda env l vars rest (trans-body env l body))))))
        (else (bad-syntax))))
 
     ((eval-case)
@@ -339,11 +339,11 @@
 
     (else
      (if (memq head %scheme-primitives)
-	 (<ghil-inline> e l head (map trans:x tail))
+	 (make-ghil-inline e l head (map trans:x tail))
 	 (if (memq head %forbidden-primitives)
 	     (syntax-error l (format #f "`~a' is forbidden" head)
 			   (cons head tail))
-	     (<ghil-call> e l (trans:x head) (map trans:x tail)))))))
+	     (make-ghil-call e l (trans:x head) (map trans:x tail)))))))
 
 (define (trans-quasiquote e l x)
   (cond ((not (pair? x)) x)
@@ -352,8 +352,8 @@
 	   (match (cdr x)
 	     ((obj)
 	      (if (eq? (car x) 'unquote)
-		  (<ghil-unquote> e l (trans e l obj))
-		  (<ghil-unquote-splicing> e l (trans e l obj))))
+		  (make-ghil-unquote e l (trans e l obj))
+		  (make-ghil-unquote-splicing e l (trans e l obj))))
 	     (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
 	(else (cons (trans-quasiquote e l (car x))
 		    (trans-quasiquote e l (cdr x))))))
diff --git a/module/system/base/language.scm b/module/system/base/language.scm
index 44dda1f64..57396e340 100644
--- a/module/system/base/language.scm
+++ b/module/system/base/language.scm
@@ -36,7 +36,7 @@
 			   ))
 
 (define-macro (define-language name . spec)
-  `(define ,name (,<language> :name ',name ,@spec)))
+  `(define ,name (,make-language :name ',name ,@spec)))
 
 (define (lookup-language name)
   (let ((m (resolve-module `(language ,name spec))))
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 3a61ea6f6..8599d99fc 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -73,17 +73,22 @@
 ;;; Record
 ;;;
 
+(define (symbol-trim-both sym pred)
+  (string->symbol (string-trim-both (symbol->string sym) pred)))
+
+
 (define-macro (define-record def)
-  (let ((name (car def)) (slots (cdr def)))
+  (let* ((name (car def)) (slots (cdr def))
+         (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
     `(begin
-       (define (,name . args)
-	 (vector ',name (%make-struct
-			 args
-			 (list ,@(map (lambda (slot)
-					(if (pair? slot)
-					  `(cons ',(car slot) ,(cadr slot))
-					  `',slot))
-				      slots)))))
+       (define ,(symbol-append 'make- stem)
+         (let ((slots (list ,@(map (lambda (slot)
+                                     (if (pair? slot)
+                                         `(cons ',(car slot) ,(cadr slot))
+                                         `',slot))
+                                   slots))))
+           (lambda args
+             (vector ',name (%make-struct args slots)))))
        (define (,(symbol-append name '?) x)
 	 (and (vector? x) (eq? (vector-ref x 0) ',name)))
        ,@(do ((n 1 (1+ n))
@@ -96,22 +101,32 @@
 			    ls)))
 	     ((null? slots) (reverse! ls))))))
 
-(define *unbound* "#<unbound>")
-
 (define (%make-struct args slots)
-  (map (lambda (slot)
-	 (let* ((key (if (pair? slot) (car slot) slot))
-		(def (if (pair? slot) (cdr slot) *unbound*))
-		(val (get-key args (symbol->keyword key) def)))
-	   (if (eq? val *unbound*)
-	     (error "slot unbound" key)
-	     (cons key val))))
-       slots))
-
-(define (get-key klist key def)
-  (do ((ls klist (cddr ls)))
-      ((or (null? ls) (eq? (car ls) key))
-       (if (null? ls) def (cadr ls)))))
+  (define (finish-bindings out)
+    (map (lambda (slot)
+           (let ((name (if (pair? slot) (car slot) slot)))
+             (or (assq name out)
+                 (if (pair? slot)
+                     (cons name (cdr slot))
+                     (error "unbound slot" args slots name)))))
+         slots))
+  (let lp ((in args) (positional slots) (out '()))
+    (cond
+     ((null? in)
+      (finish-bindings out))
+     ((keyword? (car in))
+      (let ((sym (keyword->symbol (car in))))
+        (cond
+         ((and (not (memq sym slots))
+               (not (assq sym (filter pair? slots))))
+          (error "unknown slot" sym))
+         ((assq sym out) (error "slot already set" sym out))
+         (else (lp (cddr in) '() (acons sym (cadr in) out))))))
+     ((null? positional)
+      (error "too many initargs" args slots))
+     (else
+      (lp (cdr in) (cdr positional)
+          (acons (car positional) (car in) out))))))
 
 (define (get-slot struct name . names)
   (let ((data (assq name (vector-ref struct 1))))
@@ -134,21 +149,7 @@
 ;;;
 
 (define-macro (| . rest)
-  `(begin ,@(map %make-variant-type rest)))
-
-(define (%make-variant-type def)
-  (let ((name (car def)) (slots (cdr def)))
-    `(begin
-       (define ,def (vector ',name ,@slots))
-       (define (,(symbol-append name '?) x)
-	 (and (vector? x) (eq? (vector-ref x 0) ',name)))
-       ,@(do ((n 1 (1+ n))
-	      (slots slots (cdr slots))
-	      (ls '() (cons `(define ,(string->symbol
-				       (format #f "~A-~A" name n))
-			       ,(string->symbol (format #f "%slot-~A" n)))
-			    ls)))
-	     ((null? slots) (reverse! ls))))))
+  `(begin ,@(map (lambda (def) `(define-record ,def)) rest)))
 
 (define (%slot-1 x) (vector-ref x 1))
 (define (%slot-2 x) (vector-ref x 2))
diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index eab25d600..549dd2e80 100644
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -39,23 +39,23 @@
 (define (optimize x)
   (match x
     (($ <ghil-set> env var val)
-     (<ghil-set> env var (optimize val)))
+     (make-ghil-set env var (optimize val)))
 
     (($ <ghil-if> test then else)
-     (<ghil-if> (optimize test) (optimize then) (optimize else)))
+     (make-ghil-if (optimize test) (optimize then) (optimize else)))
 
     (($ <ghil-begin> exps)
-     (<ghil-begin> (map optimize exps)))
+     (make-ghil-begin (map optimize exps)))
 
     (($ <ghil-bind> env vars vals body)
-     (<ghil-bind> env vars (map optimize vals) (optimize body)))
+     (make-ghil-bind env vars (map optimize vals) (optimize body)))
 
     (($ <ghil-lambda> env vars rest body)
-     (<ghil-lambda> env vars rest (optimize body)))
+     (make-ghil-lambda env vars rest (optimize body)))
 
 ;; FIXME:  <ghil-inst> does not exist.  -- Ludo'.
 ;     (($ <ghil-inst> inst args)
-;      (<ghil-inst> inst (map optimize args)))
+;      (make-ghil-inst inst (map optimize args)))
 
     (($ <ghil-call> env proc args)
      (match proc
@@ -67,9 +67,9 @@
 		    (set! v.env env)
 		    (ghil-env-add! env v))
 		  lambda-env.variables)
-	(optimize (<ghil-bind> env vars args body)))
+	(optimize (make-ghil-bind env vars args body)))
        (else
-	(<ghil-call> env (optimize proc) (map optimize args)))))
+	(make-ghil-call env (optimize proc) (map optimize args)))))
     (else x)))
 
 
@@ -77,25 +77,25 @@
 ;;; Stage 3: Code generation
 ;;;
 
-(define *ia-void* (<glil-void>))
-(define *ia-drop* (<glil-call> 'drop 0))
-(define *ia-return* (<glil-call> 'return 0))
+(define *ia-void* (make-glil-void))
+(define *ia-drop* (make-glil-call 'drop 0))
+(define *ia-return* (make-glil-call 'return 0))
 
 (define (make-label) (gensym ":L"))
 
 (define (make-glil-var op env var)
   (case var.kind
     ((argument)
-     (<glil-argument> op var.index))
+     (make-glil-argument op var.index))
     ((local)
-     (<glil-local> op var.index))
+     (make-glil-local op var.index))
     ((external)
      (do ((depth 0 (1+ depth))
 	  (e env e.parent))
 	 ((eq? e var.env)
-	  (<glil-external> op depth var.index))))
+	  (make-glil-external op depth var.index))))
     ((module)
-     (<glil-module> op var.env var.name))
+     (make-glil-module op var.env var.name))
     (else (error "Unknown kind of variable:" var))))
 
 (define (codegen ghil)
@@ -104,13 +104,13 @@
       (set! stack (cons code stack)))
     (define (comp tree tail drop)
       (define (push-label! label)
-	(push-code! (<glil-label> label)))
+	(push-code! (make-glil-label label)))
       (define (push-branch! inst label)
-	(push-code! (<glil-branch> inst label)))
+	(push-code! (make-glil-branch inst label)))
       (define (push-call! loc inst args)
 	(for-each comp-push args)
-	(push-code! (<glil-call> inst (length args)))
-	(push-code! (<glil-source> loc)))
+	(push-code! (make-glil-call inst (length args)))
+	(push-code! (make-glil-source loc)))
       ;; possible tail position
       (define (comp-tail tree) (comp tree tail drop))
       ;; push the result
@@ -132,7 +132,7 @@
 	(return-code! *ia-void*))
       ;; return object if necessary
       (define (return-object! obj)
-	(return-code! (<glil-const> obj)))
+	(return-code! (make-glil-const obj)))
       ;;
       ;; dispatch
       (match tree
@@ -152,14 +152,14 @@
 	     ((? pair? pp)
 	      (loop (car pp))
 	      (loop (cdr pp))
-	      (push-code! (<glil-call> 'cons 2)))
+	      (push-code! (make-glil-call 'cons 2)))
 	     (($ <ghil-unquote> env loc exp)
 	      (comp-push exp))
 	     (($ <ghil-unquote-splicing> env loc exp)
 	      (comp-push exp)
 	      (push-call! #f 'list-break '()))
 	     (else
-	      (push-code! (<glil-const> x)))))
+	      (push-code! (make-glil-const x)))))
 	 (maybe-drop)
 	 (maybe-return))
 
@@ -253,11 +253,11 @@
 	 ;; BODY
 	 (for-each comp-push vals)
 	 (let ((vars (map (lambda (v) (list v.name v.kind v.index)) vars)))
-	   (if (not (null? vars)) (push-code! (<glil-bind> vars))))
+	   (if (not (null? vars)) (push-code! (make-glil-bind vars))))
 	 (for-each (lambda (var) (push-code! (make-glil-var 'set env var)))
 		   (reverse vars))
 	 (comp-tail body)
-	 (push-code! (<glil-unbind>)))
+	 (push-code! (make-glil-unbind)))
 
 	(($ <ghil-lambda> env loc vars rest body)
 	 (return-code! (codegen tree)))
@@ -289,23 +289,23 @@
 	 (finalize-index! exts)
 	 ;; meta bindings
 	 (let ((vars (map (lambda (v) (list v.name v.kind v.index)) args)))
-	   (if (not (null? vars)) (push-code! (<glil-bind> vars))))
+	   (if (not (null? vars)) (push-code! (make-glil-bind vars))))
 	 ;; export arguments
 	 (do ((n 0 (1+ n))
 	      (l args (cdr l)))
 	     ((null? l))
 	   (let ((v (car l)))
 	     (cond ((eq? v.kind 'external)
-		    (push-code! (<glil-argument> 'ref n))
-		    (push-code! (<glil-external> 'set 0 v.index))))))
+		    (push-code! (make-glil-argument 'ref n))
+		    (push-code! (make-glil-external 'set 0 v.index))))))
 	 ;; compile body
 	 (comp body #t #f)
 	 ;; create GLIL
-	 (let ((vars (<glil-vars> :nargs (length args)
-				  :nrest (if rest 1 0)
-				  :nlocs (length locs)
-				  :nexts (length exts))))
-	   (<glil-asm> vars (reverse! stack))))))))
+	 (let ((vars (make-glil-vars :nargs (length args)
+                                     :nrest (if rest 1 0)
+                                     :nlocs (length locs)
+                                     :nexts (length exts))))
+	   (make-glil-asm vars (reverse! stack))))))))
 
 (define (finalize-index! list)
   (do ((n 0 (1+ n))
diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index ea3d66e4e..84814bd13 100644
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -25,33 +25,33 @@
   :use-module (ice-9 regex)
   :export
   (
-   <ghil-void> <ghil-void>? <ghil-void>-1 <ghil-void>-2
-   <ghil-quote> <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
-   <ghil-quasiquote> <ghil-quasiquote>?
+   <ghil-void> make-ghil-void <ghil-void>? <ghil-void>-1 <ghil-void>-2
+   <ghil-quote> make-ghil-quote <ghil-quote>? <ghil-quote>-1 <ghil-quote>-2 <ghil-quote>-3
+   <ghil-quasiquote> make-ghil-quasiquote <ghil-quasiquote>?
    <ghil-quasiquote>-1 <ghil-quasiquote>-2 <ghil-quasiquote>-3
-   <ghil-unquote> <ghil-unquote>?
+   <ghil-unquote> make-ghil-unquote <ghil-unquote>?
    <ghil-unquote>-1 <ghil-unquote>-2 <ghil-unquote>-3
-   <ghil-unquote-splicing> <ghil-unquote-splicing>?
+   <ghil-unquote-splicing> make-ghil-unquote-splicing <ghil-unquote-splicing>?
    <ghil-unquote-splicing>-1 <ghil-unquote-splicing>-2
    <ghil-unquote-splicing>-3
 
-   <ghil-ref> <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
-   <ghil-set> <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
-   <ghil-define> <ghil-define>?
+   <ghil-ref> make-ghil-ref <ghil-ref>? <ghil-ref>-1 <ghil-ref>-2 <ghil-ref>-3
+   <ghil-set> make-ghil-set <ghil-set>? <ghil-set>-1 <ghil-set>-2 <ghil-set>-3 <ghil-set>-4
+   <ghil-define> make-ghil-define <ghil-define>?
    <ghil-define>-1 <ghil-define>-2 <ghil-define>-3 <ghil-define>-4
 
-   <ghil-if> <ghil-if>?
+   <ghil-if> make-ghil-if <ghil-if>?
    <ghil-if>-1 <ghil-if>-2 <ghil-if>-3 <ghil-if>-4 <ghil-if>-5
-   <ghil-and> <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
-   <ghil-or> <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
-   <ghil-begin> <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
-   <ghil-bind> <ghil-bind>?
+   <ghil-and> make-ghil-and <ghil-and>? <ghil-and>-1 <ghil-and>-2 <ghil-and>-3
+   <ghil-or> make-ghil-or <ghil-or>? <ghil-or>-1 <ghil-or>-2 <ghil-or>-3
+   <ghil-begin> make-ghil-begin <ghil-begin>? <ghil-begin>-1 <ghil-begin>-2 <ghil-begin>-3
+   <ghil-bind> make-ghil-bind <ghil-bind>?
    <ghil-bind>-1 <ghil-bind>-2 <ghil-bind>-3 <ghil-bind>-4 <ghil-bind>-5
-   <ghil-lambda> <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
+   <ghil-lambda> make-ghil-lambda <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
    <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
-   <ghil-inline> <ghil-inline>?
+   <ghil-inline> make-ghil-inline <ghil-inline>?
    <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
-   <ghil-call> <ghil-call>?
+   <ghil-call> make-ghil-call <ghil-call>?
    <ghil-call>-1 <ghil-call>-2 <ghil-call>-3 <ghil-call>-4
    ))
 
@@ -112,9 +112,7 @@
 ;;;
 
 (define-record (<ghil-var> env name kind (type #f) (value #f) (index #f)))
-
-(define-public (make-ghil-var env name kind)
-  (<ghil-var> :env env :name name :kind kind))
+(export make-ghil-var)
 
 
 ;;;
@@ -122,9 +120,7 @@
 ;;;
 
 (define-record (<ghil-mod> module (table '()) (imports '())))
-
-(define-public (make-ghil-mod module)
-  (<ghil-mod> :module module))
+(export make-ghil-mod)
 
 
 ;;;
@@ -133,10 +129,11 @@
 
 (define-record (<ghil-env> mod parent (table '()) (variables '())))
 
+(define %make-ghil-env make-ghil-env)
 (define-public (make-ghil-env e)
-  (match e
-    (($ <ghil-mod>) (<ghil-env> :mod e :parent e))
-    (($ <ghil-env> m) (<ghil-env> :mod m :parent e))))
+  (record-case e
+    ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
+    ((<ghil-env> m) (%make-ghil-env :mod m :parent e))))
 
 (define (ghil-env-toplevel? e)
   (eq? e.mod e.parent))
diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index f4a5c560d..8b10c4b4b 100644
--- a/module/system/il/glil.scm
+++ b/module/system/il/glil.scm
@@ -24,26 +24,26 @@
   :use-module (ice-9 match)
   :export
   (pprint-glil
-   <glil-vars>
-   <glil-asm> <glil-asm>?
+   <glil-vars> make-glil-vars
+   <glil-asm> make-glil-asm <glil-asm>?
    <glil-asm>-1 <glil-asm>-2 <glil-asm>-3 <glil-asm>-4 <glil-asm>-5
-   <glil-bind> <glil-bind>? <glil-bind>-1
-   <glil-unbind> <glil-unbind>?
-   <glil-source> <glil-source>? <glil-source>-1 <glil-source>-2
+   <glil-bind> make-glil-bind <glil-bind>? <glil-bind>-1
+   <glil-unbind> make-glil-unbind <glil-unbind>?
+   <glil-source> make-glil-source <glil-source>? <glil-source>-1 <glil-source>-2
 
-   <glil-void> <glil-void>?
-   <glil-const> <glil-const>? <glil-const>-1
+   <glil-void> make-glil-void <glil-void>?
+   <glil-const> make-glil-const <glil-const>? <glil-const>-1
 
-   <glil-argument> <glil-argument>? <glil-argument>-1 <glil-argument>-2
-   <glil-local> <glil-local>? <glil-local>-1 <glil-local>-2
-   <glil-external> <glil-external>?
+   <glil-argument> make-glil-argument <glil-argument>? <glil-argument>-1 <glil-argument>-2
+   <glil-local> make-glil-local <glil-local>? <glil-local>-1 <glil-local>-2
+   <glil-external> make-glil-external <glil-external>?
    <glil-external>-1 <glil-external>-2 <glil-external>-3
-   <glil-module> <glil-module>?
+   <glil-module> make-glil-module <glil-module>?
    <glil-module>-1 <glil-module>-2 <glil-module>-3
 
-   <glil-label> <glil-label>? <glil-label>-1
-   <glil-branch> <glil-branch>? <glil-branch>-1 <glil-branch>-2
-   <glil-call> <glil-call>? <glil-call>-1 <glil-call>-2
+   <glil-label> make-glil-label <glil-label>? <glil-label>-1
+   <glil-branch> make-glil-branch <glil-branch>? <glil-branch>-1 <glil-branch>-2
+   <glil-call> make-glil-call <glil-call>? <glil-call>-1 <glil-call>-2
    ))
 
 (define-record (<glil-vars> nargs nrest nlocs nexts))
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index ba3fe5aa5..eb2ad601c 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -35,15 +35,16 @@
 (define repl-default-options
   '((trace . #f)))
 
+(define %make-repl make-repl)
 (define-public (make-repl lang)
   (let ((cenv (make-cenv :vm (the-vm)
 			 :language (lookup-language lang)
 			 :module (current-module))))
-    (<repl> :env cenv
-	    :options repl-default-options
-	    :tm-stats (times)
-	    :gc-stats (gc-stats)
-	    :vm-stats (vm-stats cenv.vm))))
+    (%make-repl :env cenv
+                :options repl-default-options
+                :tm-stats (times)
+                :gc-stats (gc-stats)
+                :vm-stats (vm-stats cenv.vm))))
 
 (define-public (repl-welcome repl)
   (format #t "~A interpreter ~A on Guile ~A\n"
diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 47e7b8a69..a885e571e 100644
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -55,9 +55,9 @@
 (define (preprocess x e)
   (record-case x
     ((<glil-asm> vars body)
-     (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
+     (let* ((venv (make-venv :parent e :nexts (slot vars 'nexts) :closure? #f))
 	    (body (map (lambda (x) (preprocess x venv)) body)))
-       (<vm-asm> :venv venv :glil x :body body)))
+       (make-vm-asm :venv venv :glil x :body body)))
     ((<glil-external> op depth index)
      (do ((d depth (- d 1))
  	  (e e (slot e 'parent)))
@@ -147,7 +147,7 @@
 		     (push-code! `(external-set ,(+ n index)))))))
 
 	   ((<glil-module> op module name)
-	    (push-object! (<vlink> :module #f :name name))
+	    (push-object! (make-vlink :module #f :name name))
 	    (if (eq? op 'ref)
 		(push-code! '(variable-ref))
 		(push-code! '(variable-set))))
@@ -175,15 +175,15 @@
        (let ((bytes (stack->bytes (reverse! stack) label-alist)))
 	 (if toplevel
 	     (bytecode->objcode bytes vars.nlocs vars.nexts)
-	     (<bytespec> :vars vars :bytes bytes
-			 :meta (if (and (null? binding-alist)
-					(null? source-alist))
-				 #f
-				 (cons (reverse! binding-alist)
-				       (reverse! source-alist)))
-			 :objs (let ((objs (map car (reverse! object-alist))))
-				 (if (null? objs) #f (list->vector objs)))
-			 :closure? venv.closure?)))))))))
+	     (make-bytespec :vars vars :bytes bytes
+                            :meta (if (and (null? binding-alist)
+                                           (null? source-alist))
+                                      #f
+                                      (cons (reverse! binding-alist)
+                                            (reverse! source-alist)))
+                            :objs (let ((objs (map car (reverse! object-alist))))
+                                    (if (null? objs) #f (list->vector objs)))
+                            :closure? venv.closure?)))))))))
 
 (define (object-assoc x alist)
   (record-case x
diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index c78f28aa4..686d89714 100644
--- a/module/system/vm/debug.scm
+++ b/module/system/vm/debug.scm
@@ -38,7 +38,8 @@
   (let ((chain (vm-last-frame-chain vm)))
     (if (null? chain)
       (display "Nothing to debug\n")
-      (debugger-repl (<debugger> :vm vm :chain chain :index (length chain))))))
+      (debugger-repl (make-debugger
+                      :vm vm :chain chain :index (length chain))))))
 
 (define (debugger-repl db)
   (let loop ()