wsi

#!/usr/bin/env gosh
;; -*- mode: scheme -*-

(define-module white-scheme.interpreter
  (use util.match)
  (use srfi-1)
  (use file.util)
  (export run-interpreter))
(select-module white-scheme.interpreter)

(define (tokenize c)
  (case c
    [(#\space) 'S]
    [(#\tab) 'T]
    [(#\x0a) 'L]))

(define-syntax define-insn-parsers
  (syntax-rules ()
    [(_ def0 def1 ...)
     (begin
       (define-insn-parser def0)
       (define-insn-parser def1)
       ...)]))

(define-syntax define-insn-parser
  (syntax-rules (N L)
    [(_ (name))
     (define (name code)
       (values '(name) code))]
    [(_ (name N))
     (define (name code)
       (receive (n code) (parse-number code)
	 (values `(name ,n) code)))]
    [(_ (name L))
     (define (name code)
       (receive (l code) (parse-label code)
	 (values `(name ,l) code)))]))

(define-insn-parsers
  (PUSH N)
  (COPY N)
  (SLIDE N)
  (DUP)
  (SWAP)
  (POP)
  (ADD)
  (SUB)
  (MUL)
  (DIV)
  (MOD)
  (STORE)
  (RETR)
  (PUTC)
  (PUTN)
  (GETC)
  (GETN)
  (LABEL L)
  (CALL L)
  (JUMP L)
  (BZERO L)
  (BNEG L)
  (RET)
  (QUIT))

(define *tokens->insn-parser*
  `((S (S . ,PUSH)
       (T (S . ,COPY)
	  (L . ,SLIDE))
       (L (S . ,DUP)
	  (T . ,SWAP)
	  (L . ,POP)))
    (T (S (S (S . ,ADD)
	     (T . ,SUB)
	     (L . ,MUL))
	  (T (S . ,DIV)
	     (T . ,MOD)))
       (T (S . ,STORE)
	  (T . ,RETR))
       (L (S (S . ,PUTC)
	     (T . ,PUTN))
	  (T (S . ,GETC)
	     (T . ,GETN))))
    (L (S (S . ,LABEL)
	  (T . ,CALL)
	  (L . ,JUMP))
       (T (S . ,BZERO)
	  (T . ,BNEG)
	  (L . ,RET))
       (L (L . ,QUIT)))))

;; Parser: tokens -> instructions
(define (parse code insns)
  (define (rec code is)
    (match code
      [()
       (if (eq? is insns)
	 '()
	 (error "unexpected EOF"))]
      [(token . code)
       (if-let1 v (assq token is)
	 (if (pair? (cdr v))
	   (rec code (cdr v))
	   (let1 parser (cdr v)
	     (receive (insn code) (parser code)
	       (cons insn (rec code insns)))))
	 (error "unexpected token" token))]))
  (rec code insns))

(define (parse-number code)
  (define (rec code sign n)
    (match code
      [('S . code) (rec code sign (* n 2))]
      [('T . code) (rec code sign (+ (* n 2) 1))]
      [('L . code) (values (sign n) code)]
      [() (error "unexpected EOF")]))
  (let* ([sign (car code)]
	 [code (cdr code)])
    (case sign
      [(S) (rec code identity 0)]
      [(T) (rec code - 0)]
      [else (error "unexpected token" sign)])))

(define (parse-label code)
  (define (rec code ts)
    (match code
      [(t . code)
       (if (or (eq? t 'S) (eq? t 'T))
	 (rec code (cons t ts))
	 (values (string->symbol
		   (string-join (reverse (map symbol->string ts))
				""))
		 code))]
      [() (error "unexpected EOF")]))
  (rec code '()))

;; Assembler: resolves labels
(define (assemble code)
  (define (copy-tree t)
    (if (pair? t)
      (cons (copy-tree (car t))
	    (copy-tree (cdr t)))
      t))
  (define (scan code insns labels)
    (match code
      [() (values insns labels)]
      [((and (command . args) insn) . code*)
       (case command
	 [(LABEL)
	  (if (assq (car args) labels)
	    (error "duplicate label")
	    (scan code* insns (acons (car args) code labels)))]
	 [(CALL JUMP BZERO BNEG)
	  (scan code* (cons insn insns) labels)]
	 [else
	  (scan code* insns labels)])]))
  (let1 code (copy-tree code)
    (receive (insns labels) (scan code '() '())
      (dolist (insn insns)
	(if-let1 label (assq (cadr insn) labels)
	  (set-cdr! insn (cdr label))
	  (error "unknown label"))))
    code))

;; Executor: executes instructions
(define (execute code heap)
  (define (step code vstack heap rstack)
    (define (next vstack)
      (step (cdr code) vstack heap rstack))
    (define (arith op)
      (next (cons (op (cadr vstack) (car vstack)) (cddr vstack))))
    (match code
      [() #t]
      [((comm . args) . code)
       (case comm
	 [(PUSH) (next (cons (car args) vstack))]
	 [(COPY) (next (cons (list-ref vstack (car args)) vstack))]
	 [(SLIDE) (next (cons (car vstack) (drop vstack (car args))))]
	 [(DUP) (next (cons (car vstack) vstack))]
	 [(SWAP) (next (cons* (cadr vstack) (car vstack) (cddr vstack)))]
	 [(POP) (next (cdr vstack))]
	 [(ADD)	(arith +)]
	 [(SUB) (arith -)]
	 [(MUL) (arith *)]
	 [(DIV) (arith quotient)]
	 [(MOD) (arith remainder)]
	 [(STORE)
	  (vector-set! heap (cadr vstack) (car vstack))
	  (next (cddr vstack))]
	 [(RETR)
	  (next (cons (vector-ref heap (car vstack)) (cdr vstack)))]
	 [(PUTC)
	  (display (integer->char (car vstack)))
	  (flush)
	  (next (cdr vstack))]
	 [(PUTN)
	  (display (car vstack))
	  (flush)
	  (next (cdr vstack))]
	 [(GETC)
	  (let1 c (read-char)
	    (next (cons (char->integer c) vstack)))]
	 [(GETN)
	  (let1 n (read)
	    (next (cons n vstack)))]
	 [(LABEL) (next vstack)]
	 [(CALL) (step args vstack heap (cons code rstack))]
	 [(JUMP L) (step args vstack heap rstack)]
	 [(BZERO L)
	  (if (zero? (car vstack))
	    (step args (cdr vstack) heap rstack)
	    (next (cdr vstack)))]
	 [(BNEG L)
	  (if (negative? (car vstack))
	    (step args (cdr vstack) heap rstack)
	    (next (cdr vstack)))]
	 [(RET) (step (car rstack) vstack heap (cdr rstack))]
	 [(QUIT) #t])]))
  (step code '() heap '()))

(define (run-interpreter args)
  (let1 code (string->list (file->string (cadr args)))
    (execute (assemble (parse (map tokenize code)
			      *tokens->insn-parser*))
	     '#()))
  0)

(select-module user)
(import white-scheme.interpreter)
(define main run-interpreter)