rosella/libcompiler/writer.scm

#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 hex-digits "0123456789abcdef")

(define (hard-new-line port)
  (write-char #\Newline port)
  (for ([i (in-range 0 (current-indent))])
    (write-char #\Space port)))

(define (req-new-line port)
  (if (verbose-rla?)
      (hard-new-line port)
      (write-char #\Space port)))

(define (opt-new-line port)
  (when (verbose-rla?)
    (hard-new-line 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)
    (req-new-line port)
    (write-char #\" port)
    (for ([var (in-list (cdr tc-form))])
      (write-hex-char (variable->code var) port))
    (write-char #\" port)
    (when (verbose-rla?)
      (write-char #\; port)
      (for ([var (in-list (cdr tc-form))])
        (write-char #\Space port)
        (write var 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
                  (if (verbose-rla?)
                      (begin
                        (write-string "\"; " port)
                        (write (car forms) port))
                      (write-char #\" port))
                  (write-tail-call (second forms)))
                (begin
                  (when (verbose-rla?)
                    (write-string "\\; " port)
                    (write (car forms) port)
                    (hard-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))])
        (req-new-line port)
        (write-string "#(" port)
        (unless (null? (second value))
          (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
            (opt-new-line port)
            (write-rla-value (first (second value)) port)
            (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)
        (if template?
            (write-instance-string (third value) port)
            (begin
              (write-string "#(" port)
              (unless (null? (third value))
                (parameterize ([current-indent (+ (current-indent-step) (current-indent))])
                  (opt-new-line port)
                  (write-rla-value (first (third value)) port)
                  (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)))

(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)]
      [(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)])))

(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)
           (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)])))

; vim:set sw=2 expandtab: