308 lines
11 KiB
Scheme
308 lines
11 KiB
Scheme
#lang scheme/base
|
|
|
|
(require scheme/list)
|
|
(require (file "utilities.scm"))
|
|
(require (file "primitives.scm"))
|
|
|
|
(provide write-rla-value
|
|
current-indent
|
|
current-indent-step
|
|
verbose-rla?)
|
|
|
|
(define current-indent (make-parameter 0))
|
|
(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)
|
|
(write-char #\Newline)
|
|
(for ([i (in-range 0 (current-indent))])
|
|
(write-char #\Space)))
|
|
|
|
(define (req-new-line)
|
|
(if (verbose-rla?)
|
|
(hard-new-line)
|
|
(write-char #\Space)))
|
|
|
|
(define (opt-new-line)
|
|
(when (verbose-rla?)
|
|
(hard-new-line)))
|
|
|
|
(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)
|
|
(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)
|
|
(write-char #\")
|
|
(for ([ch (in-string value)])
|
|
(cond
|
|
[(and (eq? ch #\"))
|
|
(write-string "\\\"")]
|
|
[(and (< (char->integer ch) 128) (char-graphic? ch))
|
|
(write-char ch)]
|
|
[else
|
|
(write-hex-char (char->integer ch))]))
|
|
(write-char #\"))
|
|
|
|
(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)))
|
|
(write-char #\"))
|
|
|
|
(define (write-rla-bytecode+tail-call forms)
|
|
(define (write-tail-call tc-form)
|
|
(req-new-line)
|
|
(write-string "#@\"")
|
|
(for ([var (in-list (cdr tc-form))])
|
|
(write-hex-char (variable->code var)))
|
|
(write-char #\")
|
|
(when (verbose-rla?)
|
|
(write-char #\;)
|
|
(for ([var (in-list (cdr tc-form))])
|
|
(write-char #\Space)
|
|
(write var))))
|
|
|
|
(let-values ([(line col pos) (port-next-location (current-output-port))])
|
|
(parameterize ([current-indent col])
|
|
(write-string "#@\"")
|
|
(if (eq? (first (first forms)) '#%tail-call)
|
|
(begin
|
|
(write-char #\")
|
|
(write-tail-call (first forms)))
|
|
(let iter ([forms forms])
|
|
(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 "\"; ")
|
|
(write (car forms)))
|
|
(write-char #\"))
|
|
(write-tail-call (second forms)))
|
|
(begin
|
|
(when (verbose-rla?)
|
|
(write-string "\\; ")
|
|
(write (car forms))
|
|
(hard-new-line)
|
|
(write-string " "))
|
|
(iter (cdr forms)))))))))
|
|
|
|
(define (write-rla-function value)
|
|
(define template? (eq? (first value) '#%template))
|
|
(let-values ([(line col pos) (port-next-location (current-output-port))])
|
|
(parameterize ([current-indent col])
|
|
(write-string "#@#S(")
|
|
(if (eq? (first value) '#%template)
|
|
(write-string "#=\"template\"")
|
|
(write-string "#=\"lambda\""))
|
|
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
|
|
(req-new-line)
|
|
(write-string "#@#(")
|
|
(unless (null? (second value))
|
|
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
|
|
(opt-new-line)
|
|
(write-rla-val (first (second value)))
|
|
(for ([global (in-list (cdr (second value)))])
|
|
(req-new-line)
|
|
(write-rla-val global)))
|
|
(opt-new-line))
|
|
(write-string ")")
|
|
(req-new-line)
|
|
(if template?
|
|
(write-instance-string (third value))
|
|
(begin
|
|
(write-string "#@#(")
|
|
(unless (null? (third value))
|
|
(parameterize ([current-indent (+ (current-indent-step) (current-indent))])
|
|
(opt-new-line)
|
|
(write-rla-val (first (third value)))
|
|
(for ([instance (in-list (cdr (third value)))])
|
|
(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-val value)
|
|
(let ([ref (hash-ref (current-object-map) value #f)])
|
|
(cond
|
|
[(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)
|
|
(let ([index (find var global-variables)])
|
|
(and index (+ #x01 index)))
|
|
(let ([index (find var instance-variables)])
|
|
(and index (+ #x40 index)))
|
|
(let ([index (find var frame-variables)])
|
|
(and index (+ #x80 index)))
|
|
(let ([index (find var '(#%self #%argv #%kw-args #%kw-vals #%ctx #%k))])
|
|
(and index (+ #xfa index)))
|
|
(error "No bytecode for variable:" var)))
|
|
|
|
(define (statement->code form)
|
|
(if (eq? (first form) '#%set!)
|
|
(let ([out (variable->code (second form))]
|
|
[value (third form)])
|
|
(cond
|
|
[(machine-variable? value)
|
|
(list #x00 out #x01 (variable->code value))]
|
|
[(eq? (length (cdr value)) 1)
|
|
(let ([item (assoc (first value) unary-value-primitives)])
|
|
(unless item (error "Invalid unary value primitive:" value))
|
|
(list #x00 out (second item) (variable->code (second value))))]
|
|
[(eq? (length (cdr value)) 2)
|
|
(let ([item (assoc (first value) binary-value-primitives)])
|
|
(unless item (error "Invalid binary value primitive:" value))
|
|
(list* (second item) out (map variable->code (cdr value))))]
|
|
[else
|
|
(unless (and (eq? (first value) '#%if)
|
|
(eq? (length (cdr value)) 3))
|
|
(error "Invalid ternary primitive:" form))
|
|
(list* out (map variable->code (cdr value)))]))
|
|
(case (length (cdr form))
|
|
[(1) (let ([item (assoc (first form) unary-statement-primitives)])
|
|
(unless item (error "Invalid unary statement primitive:" form))
|
|
(list (second item)
|
|
(variable->code (second form))
|
|
#x00
|
|
#x00))]
|
|
[(2) (let ([item (assoc (first form) binary-statement-primitives)])
|
|
(unless item (error "Invalid binary statement primitive:" form))
|
|
(list (second item)
|
|
(variable->code (second form))
|
|
(variable->code (third form))
|
|
#x00))]
|
|
[(3) (let ([item (assoc (first form) ternary-statement-primitives)])
|
|
(unless item (error "Invalid ternary statement primitive:" form))
|
|
(list (second item)
|
|
(variable->code (second form))
|
|
(variable->code (third form))
|
|
(variable->code (fourth form))))]
|
|
[else (error "Unsupported form:" form)])))
|
|
|
|
; vim:set sw=2 expandtab:
|