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.
This commit is contained in:
parent
cc16957256
commit
cb0d7b62e5
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
1
reader.c
1
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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue