Add basic support for outputting values suitable for the Rosella reader.

compiler.ss

@@ -976,18 +976,166 @@
     [(%set!) (let ([out (variable->code (second form))]
                    [value (third form)])
                (if (machine-var? value)
-                   (list #x00 out #x01 (variable->code value) form)
+                   (list #x00 out #x01 (variable->code value))
                    (case (first value)
-                     [(%unbox)       (list #x00 out #x02 (variable->code (second value)) form)]
+                     [(%unbox)       (list  #x00 out #x02 (variable->code (second value)))]
-                     [(%car)         (list #x00 out #x03 (variable->code (second value)) form)]
+                     [(%car)         (list  #x00 out #x03 (variable->code (second value)))]
-                     [(%cdr)         (list #x00 out #x04 (variable->code (second value)) form)]
+                     [(%cdr)         (list  #x00 out #x04 (variable->code (second value)))]
-                     [(%make-lambda) (list #x00 out #x1b (variable->code (second value)) form)]
+                     [(%make-box)    (list  #x00 out #x18 (variable->code (second value)))]
+                     [(%make-lambda) (list  #x00 out #x1b (variable->code (second value)))]
+                     [(%cons)        (list* #x02 out (map variable->code (cdr value)))]
+                     [(%if)          (list* out (map variable->code (cdr value)))]
                      [else (error "Unknown statement type:" form)])))]
-    [(%set-box!) (list #x50 (variable->code (second form)) (variable->code (third form)) #x00 form)]
+    [(%set-box!) (list #x50 (variable->code (second form)) (variable->code (third form)) #x00)]
-    [(%set-car!) (list #x51 (variable->code (second form)) (variable->code (third form)) #x00 form)]
+    [(%set-car!) (list #x51 (variable->code (second form)) (variable->code (third form)) #x00)]
-    [(%set-cdr!) (list #x52 (variable->code (second form)) (variable->code (third form)) #x00 form)]
+    [(%set-cdr!) (list #x52 (variable->code (second form)) (variable->code (third form)) #x00)]
     [else (error "Unknown statement type:" form)]))
 
+(define current-indent (make-parameter 0))
+(define indent-step 3)
+
+(define (write-rla-value value [port (current-output-port)])
+  (define (new-line port)
+    (write-char #\Newline port)
+    (for ([i (in-range 0 (current-indent))])
+      (write-char #\Space port)))
+
+  (define (write-hex-char ord port)
+    (define digits "0123456789abcdef")
+    (write-string "\\x" port)
+    (write-char (string-ref digits (quotient ord 16)) port)
+    (write-char (string-ref digits (remainder ord 16)) port))
+
+  (define (write-rla-string value port)
+    (write-char #\" port)
+    (for ([ch (in-string value)])
+      (cond
+        [(and (eq? ch #\"))
+           (write-string "\\\"" port)]
+        [(and (< (char->integer ch) 128) (char-graphic? ch))
+           (write-char ch port)]
+        [else
+           (write-hex-char (char->integer ch) port)]))
+    (write-char #\" port))
+
+  (define (write-instance-string inst-vars port)
+    (write-char #\" port)
+    (for ([var (in-list inst-vars)])
+      (write-hex-char (variable->code var) port))
+    (write-char #\" port))
+
+  (define (write-rla-bytecode+tail-call forms port)
+    (let-values ([(line col pos) (port-next-location port)])
+      (parameterize ([current-indent col])
+        (write-char #\" port)
+        (if (eq? (first (first forms)) '%tail-call)
+            (begin
+              (write-char #\" port)
+              (new-line port)
+              (write-rla-value (variable->code (second (second forms))) port)
+              (new-line port)
+              (write-rla-value (variable->code (third (second forms))) port)
+              (new-line port)
+              (write-rla-value (variable->code (fourth (second forms))) port)
+              (new-line port)
+              (write-rla-value (variable->code (fifth (second forms))) port))
+            (let iter ([forms forms])
+              (map (lambda (x) (write-hex-char x port))
+                   (statement->code (car forms)))
+              (if (eq? (first (second forms)) '%tail-call)
+                  (begin
+                    (write-string "\"; " port)
+                    (write (car forms) port)
+                    (new-line port)
+                    (write-rla-value (variable->code (second (second forms))) port)
+                    (new-line port)
+                    (write-rla-value (variable->code (third (second forms))) port)
+                    (new-line port)
+                    (write-rla-value (variable->code (fourth (second forms))) port)
+                    (new-line port)
+                    (write-rla-value (variable->code (fifth (second forms))) port))
+                  (begin
+                    (write-string "\\; " port)
+                    (write (car forms) port)
+                    (new-line port)
+                    (write-char #\Space port)
+                    (iter (cdr forms)))))))))
+  
+  (define (write-rla-function value port)
+    (define template? (eq? (first value) '%template))
+    (let-values ([(line col pos) (port-next-location port)])
+      (parameterize ([current-indent col])
+        (write-string "#S(" port)
+        (if (eq? (first value) '%template)
+            (write-string "#=\"template\"" port)
+            (write-string "#=\"lambda\"" port))
+        (parameterize ([current-indent (+ indent-step (current-indent))])
+          (new-line port)
+          (write-string "#(" port)
+          (unless (null? (second value))
+            (parameterize ([current-indent (+ indent-step (current-indent))])
+              (for ([global (in-list (second value))])
+                (new-line port)
+                (write-rla-value global port)))
+            (new-line port))
+          (write-string ")" port)
+          (new-line port)
+          (if template?
+              (write-instance-string (third value) port)
+              (begin
+                (write-string "#(" port)
+                (unless (null? (third value))
+                  (parameterize ([current-indent (+ indent-step (current-indent))])
+                    (for ([instance (in-list (third value))])
+                      (new-line port)
+                      (write-rla-value instance port)))
+                  (new-line port))
+                (write-string ")" port)))
+          (new-line port)
+          (write-rla-value (length (second (fourth value))) port)
+          (new-line port)
+          (write-rla-bytecode+tail-call (cddr (fourth value)) port))
+        (new-line port))
+      (write-string ")" port)))
+
+  (port-count-lines! port)
+  (cond
+    [(eq? value '%undef)
+       (write-string "#=\"undefined\"" port)]
+    [(symbol? value)
+       (write-string "#=\"" port)
+       (write-string (symbol->string value) port)
+       (write-string "\"" port)]
+    [(or (boolean? value) (number? value))
+       (write value port)]
+    [(string? value)
+       (write-rla-string value port)]
+    [(and (pair? value) (memq (first value) '(%lambda %template)))
+       (write-rla-function value port)]
+    [(vector? value)
+       (write-string "#(" port)
+       (unless (zero? (vector-length value))
+         (write-rla-value (vector-ref value 0) port))
+       (for ([i (in-range 1 (vector-length value))])
+         (write-rla-value (vector-ref value i) port)
+         (write-char #\Space port))
+       (write-string ")" port)]
+    [(pair? value)
+       (write-string "(" port)
+       (let iter ([lst value])
+         (write-rla-value (car lst) port)
+         (cond
+           [(null? (cdr lst))
+              (write-string ")" port)]
+           [(pair? (cdr lst))
+              (write-char #\Space port)
+              (iter (cdr lst))]
+           [else
+              (write-string " . " port)
+              (write-rla-value (cdr lst))
+              (write-string ")" port)]))]
+    [else (error "Don't know how to write Rosella syntax for:" value)]))
+
 (define (simplify-function lambda-form)
   ((compose
             promote-free-vars
@@ -1005,7 +1153,8 @@
    simple-lambda-form))
 
 (define (compile-function lambda-form)
-  ((compose pretty-print
+  ((compose (lambda (x) (write-rla-value x) (write-char #\Newline))
+            ;pretty-print
             map-variables
             optimize-function
             simplify-function