From 03fc616b7a519fa4a978b1ab6ee3ab4f816234a8 Mon Sep 17 00:00:00 2001 From: Jesse McDonald Date: Tue, 20 Apr 2010 17:37:58 -0500 Subject: [PATCH] Add basic support for outputting values suitable for the Rosella reader. --- compiler.ss | 167 +++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 158 insertions(+), 9 deletions(-) diff --git a/compiler.ss b/compiler.ss index e65ef9f..2129f08 100755 --- a/compiler.ss +++ b/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)] - [(%car) (list #x00 out #x03 (variable->code (second value)) form)] - [(%cdr) (list #x00 out #x04 (variable->code (second value)) form)] - [(%make-lambda) (list #x00 out #x1b (variable->code (second value)) form)] + [(%unbox) (list #x00 out #x02 (variable->code (second value)))] + [(%car) (list #x00 out #x03 (variable->code (second value)))] + [(%cdr) (list #x00 out #x04 (variable->code (second value)))] + [(%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-car!) (list #x51 (variable->code (second form)) (variable->code (third form)) #x00 form)] - [(%set-cdr!) (list #x52 (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)] + [(%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