diff --git a/libcompiler/mapper.scm b/libcompiler/mapper.scm index 5a92e46..27ffe52 100644 --- a/libcompiler/mapper.scm +++ b/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)) - (second value) - value)]) + (let ([value (cond [(and (pair? value) (eq? (first value) 'quote)) (second value)] + [(symbol? value) `(#%builtin ,(symbol->string value))] + [else value])]) (let/cc return (for ([g-var (in-list global-variables)] [val (in-list g-vars)]) diff --git a/libcompiler/primitives.scm b/libcompiler/primitives.scm index a5e34a4..ab78d28 100644 --- a/libcompiler/primitives.scm +++ b/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 diff --git a/libcompiler/simplifier.scm b/libcompiler/simplifier.scm index e0d3953..48442b8 100644 --- a/libcompiler/simplifier.scm +++ b/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) diff --git a/libcompiler/utilities.scm b/libcompiler/utilities.scm index 4fef50a..8b39d32 100644 --- a/libcompiler/utilities.scm +++ b/libcompiler/utilities.scm @@ -100,14 +100,13 @@ (append curried-non-keywords non-keywords)))))))) (define (variable-value? form) - (and (symbol? form) - (not (eq? form '#%undef)))) + (symbol? form)) (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 diff --git a/libcompiler/writer.scm b/libcompiler/writer.scm index 3ba583c..158f575 100644 --- a/libcompiler/writer.scm +++ b/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) - (write-char #\Newline port) +(define (hard-new-line) + (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) - (write-char #\Space port))) + (hard-new-line) + (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) - (write-string "\\x" port) - (write-char (string-ref hex-digits (quotient ord 16)) port) - (write-char (string-ref hex-digits (remainder ord 16)) port)) +(define (write-hex-char ord) + (write-string "\\x") + (write-char (string-ref hex-digits (quotient ord 16))) + (write-char (string-ref hex-digits (remainder ord 16)))) -(define (write-hex-byte ord port) - (write-string "0x" port) - (write-char (string-ref hex-digits (quotient ord 16)) port) - (write-char (string-ref hex-digits (remainder ord 16)) port)) +(define (write-hex-byte ord) + (write-string "0x") + (write-char (string-ref hex-digits (quotient ord 16))) + (write-char (string-ref hex-digits (remainder ord 16)))) -(define (write-rla-string value port) - (write-char #\" port) +(define (write-rla-string value) + (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-char #\" port)) + (write-hex-char (char->integer ch))])) + (write-char #\")) -(define (write-instance-string inst-vars port) - (write-string "#@\"" port) +(define (write-rla-struct value) + (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-char #\" port)) + (write-hex-char (variable->code var))) + (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) - (write-string "#@\"" port) + (req-new-line) + (write-string "#@\"") (for ([var (in-list (cdr tc-form))]) - (write-hex-char (variable->code var) port)) - (write-char #\" port) + (write-hex-char (variable->code var))) + (write-char #\") (when (verbose-rla?) - (write-char #\; port) + (write-char #\;) (for ([var (in-list (cdr tc-form))]) - (write-char #\Space port) - (write var port)))) + (write-char #\Space) + (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 (car forms) port)) - (write-char #\" port)) + (write-string "\"; ") + (write (car forms))) + (write-char #\")) (write-tail-call (second forms))) (begin (when (verbose-rla?) - (write-string "\\; " port) - (write (car forms) port) - (hard-new-line port) - (write-char #\Space port)) + (write-string "\\; ") + (write (car forms)) + (hard-new-line) + (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 "#=\"lambda\"" port)) + (write-string "#=\"template\"") + (write-string "#=\"lambda\"")) (parameterize ([current-indent (+ (current-indent-step) (current-indent))]) - (req-new-line port) - (write-string "#@#(" port) + (req-new-line) + (write-string "#@#(") (unless (null? (second value)) (parameterize ([current-indent (+ (current-indent-step) (current-indent))]) - (opt-new-line port) - (write-rla-value (first (second value)) port) + (opt-new-line) + (write-rla-val (first (second value))) (for ([global (in-list (cdr (second value)))]) - (req-new-line port) - (write-rla-value global port))) - (opt-new-line port)) - (write-string ")" port) - (req-new-line port) + (req-new-line) + (write-rla-val global))) + (opt-new-line)) + (write-string ")") + (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) - (write-rla-value (first (third value)) port) + (opt-new-line) + (write-rla-val (first (third value))) (for ([instance (in-list (cdr (third value)))]) - (req-new-line port) - (write-rla-value instance port))) - (opt-new-line port)) - (write-string ")" port))) - (req-new-line port) - (write-rla-value (length (second (fourth value))) port) - (req-new-line port) - (write-rla-bytecode+tail-call (cddr (fourth value)) port)) - (opt-new-line port)) - (write-string ")" port))) + (req-new-line) + (write-rla-val instance))) + (opt-new-line)) + (write-string ")"))) + (req-new-line) + (write-rla-val (length (second (fourth value)))) + (req-new-line) + (write-rla-bytecode+tail-call (cddr (fourth value)))) + (opt-new-line)) + (write-string ")"))) -(define (write-rla-value value [port (current-output-port)]) - (port-count-lines! port) - (void +(define (write-rla-val value) + (let ([ref (hash-ref (current-object-map) value #f)]) (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)] - [(char? value) - (write (char->integer value) port)] - [(string? value) - (write-rla-string value port)] - [(and (pair? value) (memq (car 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)] - [(null? value) - (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)]))) + [(number? ref) + (write-string "#=") + (write ref)] + [ref + (let ([objnum (next-object-number)]) + (hash-set! (current-object-map) value objnum) + (next-object-number (+ 1 objnum)) + (write-char #\#) + (write objnum) + (write-char #\=)) + (write-plain-rla-val value)] + [else + (write-plain-rla-val value)]))) + +(define (write-plain-rla-val value) + (cond + [(or (boolean? value) (number? value)) + (write value)] + [(char? value) + (write (char->integer value))] + [(symbol? value) + (write-plain-rla-val (symbol->struct value))] + [(string? value) + (write-rla-string value)] + [(and (pair? value) (memq (car value) '(#%builtin))) + (write-string "#=") + (write-rla-string (second value))] + [(and (pair? value) (memq (car value) '(#%immutable))) + (unless (number? (hash-ref (current-object-map) (second value) #f)) + (write-string "#@")) + (write-rla-val (second value))] + [(and (pair? value) (memq (car value) '(#%struct))) + (write-rla-struct value)] + [(and (pair? value) (memq (car value) '(#%lambda #%template))) + (write-rla-function value)] + [(vector? value) + (write-string "#(") + (unless (zero? (vector-length 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) diff --git a/reader.c b/reader.c index 0ada95f..ec1a4fd 100644 --- a/reader.c +++ b/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); diff --git a/src/reader.rls b/src/reader.rls index 1b6cca0..5c29920 100644 --- a/src/reader.rls +++ b/src/reader.rls @@ -1,11 +1,4 @@ -(define (make-structure-type supers nslots callable) - (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 s:symbol (struct-type 'a)) (define *symbols* '()) (define (make-symbol name)