198 lines
7.5 KiB
Scheme
198 lines
7.5 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)
|
|
|
|
(define current-indent (make-parameter 0))
|
|
(define current-indent-step (make-parameter 2))
|
|
|
|
(define hex-digits "0123456789abcdef")
|
|
|
|
(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)
|
|
(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-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-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)
|
|
(define (write-tail-call tc-form)
|
|
(new-line port) (write-hex-byte (variable->code (second tc-form)) port)
|
|
(new-line port) (write-hex-byte (variable->code (third tc-form)) port)
|
|
(new-line port) (write-hex-byte (variable->code (fourth tc-form)) port)
|
|
(new-line port) (write-hex-byte (variable->code (fifth tc-form)) 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)
|
|
(write-tail-call (first forms)))
|
|
(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)
|
|
(write-tail-call (second forms)))
|
|
(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 (+ (current-indent-step) (current-indent))])
|
|
(new-line port)
|
|
(write-string "#(" port)
|
|
(unless (null? (second value))
|
|
(parameterize ([current-indent (+ (current-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 (+ (current-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)))
|
|
|
|
(define (write-rla-value value [port (current-output-port)])
|
|
(port-count-lines! port)
|
|
(void
|
|
(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 (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 %ctx %k))])
|
|
(and index (+ #xfc 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)
|
|
(list #x00 out (second (assoc (first value) unary-value-primitives))
|
|
(variable->code (second value)))]
|
|
[(eq? (length (cdr value)) 2)
|
|
(list* (second (assoc (first value) binary-value-primitives))
|
|
out (map variable->code (cdr value)))]
|
|
[else
|
|
(unless (and (eq? (first value) '%if)
|
|
(eq? (length (cdr value)) 3))
|
|
(error "Unsupported ternary form:" form))
|
|
(list* out (map variable->code (cdr value)))]))
|
|
(case (length (cdr form))
|
|
[(1) (list (second (assoc (first form) unary-statement-primitives))
|
|
(variable->code (second form))
|
|
#x00
|
|
#x00)]
|
|
[(2) (list (second (assoc (first form) binary-statement-primitives))
|
|
(variable->code (second form))
|
|
(variable->code (third form))
|
|
#x00)]
|
|
[(3) (list (second (assoc (first form) ternary-statement-primitives))
|
|
(variable->code (second form))
|
|
(variable->code (third form))
|
|
(variable->code (fourth form)))]
|
|
[else (error "Unsupported form:" form)])))
|