Support writing recursive data structures and quoted symbols.

Eliminate use of #="undefined" as an explicit initializer for boxes.
Do not allow #@ ("freeze") to be applied to references, for sanity's sake.

Inside compiler, builtins are now represented by (#%builtin "name") form.
Plain symbols are promoted to builtins; quoted symbols become structures.

libcompiler/mapper.scm

@@ -12,9 +12,9 @@
         [unused-g-vars global-variables]
         [i-vars '()])
     (define (add-g-var value)
-      (let ([value (if (and (pair? value) (eq? (first value) 'quote))
+      (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)]
-                       (second value)
+                         [(symbol? value) `(#%builtin ,(symbol->string value))]
-                       value)])
+                         [else value])])
         (let/cc return
           (for ([g-var (in-list global-variables)]
                 [val (in-list g-vars)])

libcompiler/primitives.scm

@@ -147,7 +147,7 @@
 (define value-primitives
  (append unary-value-primitives
          binary-value-primitives
-         (list '(#%if #f #f))))
+         '((#%if #f #f))))
 
 (define statement-primitives
  (append unary-statement-primitives

libcompiler/simplifier.scm

@@ -294,9 +294,9 @@
   (map-form form
             #:bind       (lambda (recurse op vars . subforms)
                            (flatten-binds
-                             `(#%bind ,(subst variable variable vars)
+                             `(#%bind ,vars
                                 ,@(if (memq variable vars)
-                                      `((#%set! ,variable (#%make-box #%undef)))
+                                      `((#%set! ,variable (#%make-box ,variable)))
                                       '())
                                 ,@(map recurse subforms))))
             #:set        (lambda (recurse op var value)

libcompiler/utilities.scm

@@ -100,14 +100,13 @@
                            (append curried-non-keywords non-keywords))))))))
 
 (define (variable-value? form)
-  (and (symbol? form)
+  (symbol? form))
-       (not (eq? form '#%undef))))
 
 (define (literal-value? form)
   (and (not (variable-value? form))
        (or (not (pair? form))
            (eq? (first form) 'quote)
-           (eq? (first form) '#%template))))
+           (memq (first form) '(#%builtin #%immutable #%struct #%template)))))
 
 (define (simple-value? form)
   (or (variable-value? form)
@@ -292,7 +291,7 @@
       (let* ([prefix (string-append (symbol->string var) "->g")]
              [unique-var (gensym prefix)])
         `(#%bind ,(subst var unique-var (second bind))
-           ,@(map (lambda (sf) (subst-var var unique-var sf))))))
+           ,@(map (lambda (sf) (subst-var var unique-var sf)) (cddr bind)))))
     (foldr make-binding-unique bind (filter needs-rename? (second bind))))
 
   (map-form form

libcompiler/writer.scm

@@ -13,173 +13,243 @@
 (define current-indent-step (make-parameter 2))
 (define verbose-rla? (make-parameter #f))
 
+(define current-object-map (make-parameter #f))
+(define next-object-number (make-parameter #f))
+
+(define symbol-structs (make-parameter #f))
+(define symbol-type '(#%immutable (#%struct (#%builtin "structure") () 1 #f)))
+
+(define (write-rla-value value (port (current-output-port)))
+  (void (parameterize ([current-output-port port]
+                       [current-object-map (make-hasheq)]
+                       [next-object-number 0]
+                       [symbol-structs (make-hasheq)])
+          (build-object-map value)
+          (port-count-lines! port)
+          (write-rla-val value))))
+
+(define (symbol->struct sym)
+  (if (hash-has-key? (symbol-structs) sym)
+      (hash-ref (symbol-structs) sym)
+      (begin
+        (let ([s `(#%immutable (#%struct ,symbol-type ,(symbol->string sym)))])
+          (hash-set! (symbol-structs) sym s)
+          s))))
+
+(define (build-object-map value)
+  (cond
+    [(or (boolean? value) (number? value) (char? value) (null? value)) (void)]
+    [(and (pair? value) (eq? (car value) '#%immutable))
+      (build-object-map (second value))]
+    [else (let* ([objmap (current-object-map)]
+                 [in-map (hash-has-key? objmap value)])
+            (hash-set! objmap value in-map)
+            (unless in-map
+              (cond
+                [(pair? value)
+                  (build-object-map (car value))
+                  (build-object-map (cdr value))]
+                [(symbol? value)
+                  (build-object-map (symbol->struct value))]
+                [(vector? value)
+                  (for ([item (in-vector value)])
+                    (build-object-map item))])))]))
+
 (define hex-digits "0123456789abcdef")
 
-(define (hard-new-line port)
+(define (hard-new-line)
-  (write-char #\Newline port)
+  (write-char #\Newline)
   (for ([i (in-range 0 (current-indent))])
-    (write-char #\Space port)))
+    (write-char #\Space)))
 
-(define (req-new-line port)
+(define (req-new-line)
   (if (verbose-rla?)
-      (hard-new-line port)
+      (hard-new-line)
-      (write-char #\Space port)))
+      (write-char #\Space)))
 
-(define (opt-new-line port)
+(define (opt-new-line)
   (when (verbose-rla?)
-    (hard-new-line port)))
+    (hard-new-line)))
 
-(define (write-hex-char ord port)
+(define (write-hex-char ord)
-  (write-string "\\x" port)
+  (write-string "\\x")
-  (write-char (string-ref hex-digits (quotient  ord 16)) port)
+  (write-char (string-ref hex-digits (quotient  ord 16)))
-  (write-char (string-ref hex-digits (remainder ord 16)) port))
+  (write-char (string-ref hex-digits (remainder ord 16))))
 
-(define (write-hex-byte ord port)
+(define (write-hex-byte ord)
-  (write-string "0x" port)
+  (write-string "0x")
-  (write-char (string-ref hex-digits (quotient  ord 16)) port)
+  (write-char (string-ref hex-digits (quotient  ord 16)))
-  (write-char (string-ref hex-digits (remainder ord 16)) port))
+  (write-char (string-ref hex-digits (remainder ord 16))))
 
-(define (write-rla-string value port)
+(define (write-rla-string value)
-  (write-char #\" port)
+  (write-char #\")
   (for ([ch (in-string value)])
     (cond
       [(and (eq? ch #\"))
-         (write-string "\\\"" port)]
+         (write-string "\\\"")]
       [(and (< (char->integer ch) 128) (char-graphic? ch))
-         (write-char ch port)]
+         (write-char ch)]
       [else
-         (write-hex-char (char->integer ch) port)]))
+         (write-hex-char (char->integer ch))]))
-  (write-char #\" port))
+  (write-char #\"))
 
-(define (write-instance-string inst-vars port)
+(define (write-rla-struct value)
-  (write-string "#@\"" port)
+  (write-string "#S(")
+  (write-rla-val (second value))
+  (for ([slotval (in-list (cddr value))])
+    (write-char #\Space)
+    (write-rla-val slotval))
+  (write-char #\)))
+
+(define (write-instance-string inst-vars)
+  (write-string "#@\"")
   (for ([var (in-list inst-vars)])
-    (write-hex-char (variable->code var) port))
+    (write-hex-char (variable->code var)))
-  (write-char #\" port))
+  (write-char #\"))
 
-(define (write-rla-bytecode+tail-call forms port)
+(define (write-rla-bytecode+tail-call forms)
   (define (write-tail-call tc-form)
-    (req-new-line port)
+    (req-new-line)
-    (write-string "#@\"" port)
+    (write-string "#@\"")
     (for ([var (in-list (cdr tc-form))])
-      (write-hex-char (variable->code var) port))
+      (write-hex-char (variable->code var)))
-    (write-char #\" port)
+    (write-char #\")
     (when (verbose-rla?)
-      (write-char #\; port)
+      (write-char #\;)
       (for ([var (in-list (cdr tc-form))])
-        (write-char #\Space port)
+        (write-char #\Space)
-        (write var port))))
+        (write var))))
 
-  (let-values ([(line col pos) (port-next-location port)])
+  (let-values ([(line col pos) (port-next-location (current-output-port))])
     (parameterize ([current-indent col])
-      (write-string "#@\"" port)
+      (write-string "#@\"")
       (if (eq? (first (first forms)) '#%tail-call)
           (begin
-            (write-char #\" port)
+            (write-char #\")
             (write-tail-call (first forms)))
           (let iter ([forms forms])
-            (map (lambda (x) (write-hex-char x port))
+            (map (lambda (x) (write-hex-char x))
                  (statement->code (car forms)))
             (if (eq? (first (second forms)) '#%tail-call)
                 (begin
                   (if (verbose-rla?)
                       (begin
-                        (write-string "\"; " port)
+                        (write-string "\"; ")
-                        (write (car forms) port))
+                        (write (car forms)))
-                      (write-char #\" port))
+                      (write-char #\"))
                   (write-tail-call (second forms)))
                 (begin
                   (when (verbose-rla?)
-                    (write-string "\\; " port)
+                    (write-string "\\; ")
-                    (write (car forms) port)
+                    (write (car forms))
-                    (hard-new-line port)
+                    (hard-new-line)
-                    (write-char #\Space port))
+                    (write-string "   "))
                   (iter (cdr forms)))))))))
 
-(define (write-rla-function value port)
+(define (write-rla-function value)
   (define template? (eq? (first value) '#%template))
-  (let-values ([(line col pos) (port-next-location port)])
+  (let-values ([(line col pos) (port-next-location (current-output-port))])
     (parameterize ([current-indent col])
-      (write-string "#@#S(" port)
+      (write-string "#@#S(")
       (if (eq? (first value) '#%template)
-          (write-string "#=\"template\"" port)
+          (write-string "#=\"template\"")
-          (write-string "#=\"lambda\"" port))
+          (write-string "#=\"lambda\""))
       (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
-        (req-new-line port)
+        (req-new-line)
-        (write-string "#@#(" port)
+        (write-string "#@#(")
         (unless (null? (second value))
           (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
-            (opt-new-line port)
+            (opt-new-line)
-            (write-rla-value (first (second value)) port)
+            (write-rla-val (first (second value)))
             (for ([global (in-list (cdr (second value)))])
-              (req-new-line port)
+              (req-new-line)
-              (write-rla-value global port)))
+              (write-rla-val global)))
-          (opt-new-line port))
+          (opt-new-line))
-        (write-string ")" port)
+        (write-string ")")
-        (req-new-line port)
+        (req-new-line)
         (if template?
-            (write-instance-string (third value) port)
+            (write-instance-string (third value))
             (begin
-              (write-string "#@#(" port)
+              (write-string "#@#(")
               (unless (null? (third value))
                 (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
-                  (opt-new-line port)
+                  (opt-new-line)
-                  (write-rla-value (first (third value)) port)
+                  (write-rla-val (first (third value)))
                   (for ([instance (in-list (cdr (third value)))])
-                    (req-new-line port)
+                    (req-new-line)
-                    (write-rla-value instance port)))
+                    (write-rla-val instance)))
-                (opt-new-line port))
+                (opt-new-line))
-              (write-string ")" port)))
+              (write-string ")")))
-        (req-new-line port)
+        (req-new-line)
-        (write-rla-value (length (second (fourth value))) port)
+        (write-rla-val (length (second (fourth value))))
-        (req-new-line port)
+        (req-new-line)
-        (write-rla-bytecode+tail-call (cddr (fourth value)) port))
+        (write-rla-bytecode+tail-call (cddr (fourth value))))
-      (opt-new-line port))
+      (opt-new-line))
-    (write-string ")" port)))
+    (write-string ")")))
 
-(define (write-rla-value value [port (current-output-port)])
+(define (write-rla-val value)
-  (port-count-lines! port)
+  (let ([ref (hash-ref (current-object-map) value #f)])
-  (void
     (cond
-      [(eq? value '#%undef)
+      [(number? ref)
-         (write-string "#=\"undefined\"" port)]
+        (write-string "#=")
-      [(symbol? value)
+        (write ref)]
-         (write-string "#=\"" port)
+      [ref
-         (write-string (symbol->string value) port)
+        (let ([objnum (next-object-number)])
-         (write-string "\"" port)]
+          (hash-set! (current-object-map) value objnum)
-      [(or (boolean? value) (number? value))
+          (next-object-number (+ 1 objnum))
-         (write value port)]
+          (write-char #\#)
-      [(char? value)
+          (write objnum)
-         (write (char->integer value) port)]
+          (write-char #\=))
-      [(string? value)
+          (write-plain-rla-val value)]
-         (write-rla-string value port)]
+      [else
-      [(and (pair? value) (memq (car value) '(#%lambda #%template)))
+          (write-plain-rla-val value)])))
-         (write-rla-function value port)]
+
-      [(vector? value)
+(define (write-plain-rla-val value)
-         (write-string "#(" port)
+  (cond
-         (unless (zero? (vector-length value))
+    [(or (boolean? value) (number? value))
-           (write-rla-value (vector-ref value 0) port))
+       (write value)]
-         (for ([i (in-range 1 (vector-length value))])
+    [(char? value)
-           (write-rla-value (vector-ref value i) port)
+       (write (char->integer value))]
-           (write-char #\Space port))
+    [(symbol? value)
-         (write-string ")" port)]
+       (write-plain-rla-val (symbol->struct value))]
-      [(null? value)
+    [(string? value)
-         (write-string "()" port)]
+       (write-rla-string value)]
-      [(pair? value)
+    [(and (pair? value) (memq (car value) '(#%builtin)))
-         (write-string "(" port)
+       (write-string "#=")
-         (let iter ([lst value])
+       (write-rla-string (second value))]
-           (write-rla-value (car lst) port)
+    [(and (pair? value) (memq (car value) '(#%immutable)))
-           (cond
+       (unless (number? (hash-ref (current-object-map) (second value) #f))
-             [(null? (cdr lst))
+         (write-string "#@"))
-                (write-string ")" port)]
+       (write-rla-val (second value))]
-             [(pair? (cdr lst))
+    [(and (pair? value) (memq (car value) '(#%struct)))
-                (write-char #\Space port)
+       (write-rla-struct value)]
-                (iter (cdr lst))]
+    [(and (pair? value) (memq (car value) '(#%lambda #%template)))
-             [else
+       (write-rla-function value)]
-                (write-string " . " port)
+    [(vector? value)
-                (write-rla-value (cdr lst))
+       (write-string "#(")
-                (write-string ")" port)]))]
+       (unless (zero? (vector-length value))
-      [else (error "Don't know how to write Rosella syntax for:" value)])))
+         (write-rla-val (vector-ref value 0)))
+       (for ([i (in-range 1 (vector-length value))])
+         (write-rla-val (vector-ref value i))
+         (write-char #\Space))
+       (write-string ")")]
+    [(null? value)
+       (write-string "()")]
+    [(pair? value)
+       (write-string "(")
+       (let iter ([lst value])
+         (write-rla-val (car lst))
+         (cond
+           [(null? (cdr lst))
+              (write-string ")")]
+           [(and (pair? (cdr lst)) (not (hash-ref (current-object-map) (cdr lst) #f)))
+              (write-char #\Space)
+              (iter (cdr lst))]
+           [else
+              (write-string " . ")
+              (write-rla-val (cdr lst))
+              (write-string ")")]))]
+    [else (error "Don't know how to write Rosella syntax for:" value)]))
 
 (define (variable->code var)
   (or (and (eq? var '#%nil) #x00)

reader.c

@@ -678,6 +678,7 @@ static value_t read_immutable(reader_state_t *state)
   register_gc_root(&ph_root, make_struct(immutable_ph_root.value));
 
   val = read_one_value(state);
+  release_assert(!struct_is_a(val, reference_root.value));
   IMMUTABLE_PH_VALUE(ph_root.value) = val;
   WRITE_BARRIER(ph_root.value);
 

src/reader.rls

@@ -1,11 +1,4 @@
-(define (make-structure-type supers nslots callable)
+(define s:symbol (struct-type 'a))
-  (let ([struct (make-struct structure)])
-    (struct-set! struct 0 supers)
-    (struct-set! struct 1 nslots)
-    (struct-set! struct 2 callable)
-    struct))
-
-(define s:symbol (make-structure-type '() 1 #f))
 (define *symbols* '())
 
 (define (make-symbol name)