299 lines
10 KiB
Scheme
299 lines
10 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") #f 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 (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 (third (first forms))) '#%tail-call)
|
|
(begin
|
|
(write-char #\")
|
|
(write-tail-call (third (first forms))))
|
|
(let iter ([forms forms])
|
|
(map (lambda (x) (write-hex-char x))
|
|
(statement->code (car forms)))
|
|
(if (eq? (first (third (second forms))) '#%tail-call)
|
|
(begin
|
|
(if (verbose-rla?)
|
|
(begin
|
|
(write-string "\"; ")
|
|
(write (first forms)))
|
|
(write-char #\"))
|
|
(write-tail-call (third (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-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) '(#%include)))
|
|
(write-string "#i")
|
|
(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-char #\Space)
|
|
(write-rla-val (vector-ref value i)))
|
|
(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 (let ([index (find var transient-variables)])
|
|
(and index (+ #x00 index)))
|
|
(let ([index (find var global-variables)])
|
|
(and index (+ #x80 index)))
|
|
(let ([index (find var instance-variables)])
|
|
(and index (+ #xc0 index)))
|
|
(let ([index (find var '(#%f #%nil #%undef))])
|
|
(and index (+ #xf0 index)))
|
|
(let ([index (find var '(#%self #%globals #%inst #%argv #%kw-args #%kw-vals #%ctx #%k))])
|
|
(and index (+ #xf8 index)))
|
|
(error "No bytecode for variable:" var)))
|
|
|
|
(define (statement->code form)
|
|
(let ([vform (third form)]) ; (#%set! #%tNN vform)
|
|
(case (length (cdr vform))
|
|
[(1) (let ([item (assoc (first vform) unary-primitives)])
|
|
(or item (error "Invalid unary primitive:" vform))
|
|
(list #x00
|
|
#x00
|
|
(second item)
|
|
(variable->code (second vform))))]
|
|
[(2) (let ([item (assoc (first vform) binary-primitives)])
|
|
(or item (error "Invalid binary primitive:" vform))
|
|
(list #x00
|
|
(second item)
|
|
(variable->code (second vform))
|
|
(variable->code (third vform))))]
|
|
[(3) (let ([item (assoc (first vform) ternary-primitives)])
|
|
(or item (error "Invalid ternary primitive:" vform))
|
|
(if (eq? (first vform) '#%vector-ref-immed)
|
|
(list (second item)
|
|
(variable->code (second vform))
|
|
(third vform)
|
|
(fourth vform))
|
|
(list (second item)
|
|
(variable->code (second vform))
|
|
(variable->code (third vform))
|
|
(variable->code (fourth vform)))))]
|
|
[else (error "Unsupported form:" vform)])))
|
|
|
|
; vim:set sw=2 expandtab:
|